diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/README.txt b/README.txt new file mode 100644 --- /dev/null +++ b/README.txt @@ -0,0 +1,76 @@ + +CAO Compiler +==================== + +0. Dependencies +--- +To build the CAO Compiler you need: + - happy + - alex + - cabal package manager + +We recommend the installation of the Haskell Platform which contains all the aforementioned dependencies: + http://hackage.haskell.org/platform/ + +1. Build instructions +--- +$ cabal configure +$ cabal build +$ cabal install +--- + +2. Run dependencies (optional) +--- +To run the CAO Compiler you may need: + - Yices SMT solver (version 1) + +This SMT solver is used to check some more complex conditions when typechecking a CAO program. +The compiler works without Yices but some conditions may not be verified. A warning is shown in these cases. + +3. Backend library dependencies +--- +To compile the generated code with the backend library you need: + - NTL + - GMP (optional) + +NTL is available from + http://www.shoup.net/ntl/ +GMP is available from + https://gmplib.org + +Information about how to compile NTL with GMP can be found here: + http://www.shoup.net/ntl/doc/tour-gmp.html + +4. Run instructions +--- +To see a description of all compiler options: +$ cao help + +The basic compiler usage is: +$ cao comp [cao-file] + +5. Example +--- +In the 'example' directory you can find a CAO implementation of the SHA1 hash algorithm. +The Makefile provides an example of how a generated C program can be compiled and linked with the backend library. +You may have to adjust the script variable 'CAO_PATH' to the root directory of your installation. + +Contact Information +------------------- + +Bugs/Suggestions please mail to: + +Manuel Barbosa - mbb@di.uminho.pt +Paulo Silva - paufil@di.uminho.pt + +Contributors: +------------- + +Bárbara Vieira - barbarasv@di.uminho.pt +David Castro - dcastro@di.uminho.pt +Hélder Pereira - hpereira@di.uminho.pt +Manuel Barbosa - mbb@di.uminho.pt +Miguel Marques - mmarques@di.uminho.pt +Nuno Rodrigues - nfr@di.uminho.pt +Paulo Silva - paufil@di.uminho.pt +Tiago Oliveira - tfaoliveira@di.uminho.pt diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/backend_lib/C_generic/CAO_bool.cpp b/backend_lib/C_generic/CAO_bool.cpp new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_bool.cpp @@ -0,0 +1,7 @@ +#include "CAO_bool.h" + +CAO_RES CAO_bool_dump(CAO_bool b) +{ + std::cout << b << "\n"; + return CAO_OK; +} diff --git a/backend_lib/C_generic/CAO_bool.h b/backend_lib/C_generic/CAO_bool.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_bool.h @@ -0,0 +1,28 @@ +#ifndef CAO_BOOL_H +#define CAO_BOOL_H + +#include "CAO_globals.h" + +#ifdef __cplusplus + +#include + +extern "C" { +#endif + + #define CAO_bool_init(a,b) a = b + #define CAO_bool_assign(a,b) a = b + #define CAO_bool_equal(a,b,c) a = ((b) == (c)) + #define CAO_bool_nequal(a,b,c) a = ((b) != (c)) + #define CAO_bool_or(a,b,c) a = ((b) | (c)) + #define CAO_bool_and(a,b,c) a = ((b) & (c)) + #define CAO_bool_xor(a,b,c) a = ((b) ^ (c)) + #define CAO_bool_not(a,b) a = ((~(b)) & 1) + + CAO_RES CAO_bool_dump(CAO_bool); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/backend_lib/C_generic/CAO_globalOp.cpp b/backend_lib/C_generic/CAO_globalOp.cpp new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_globalOp.cpp @@ -0,0 +1,788 @@ +#include "CAO_globalOp.h" + +// type is a string that codes the folowing Haskell type +// data CAOType = A // Int +// | B // Bool +// | C Integer // Mod +// | D RInt // Unsigned Bit Array with dimension +// | E RInt CAOType // Vector n of type +// | F RInt RInt CAOType // Matrix n x m of type +// | G RInt [CAOType] // Struct with n components +// | H RInt [Integer] // ModPol degree [basemod,coef_0,..,coef_deg] +// | I // RInt +// | J RInt // Signed Bit Array with dimension + +#define INT_Type 'A' +#define BOOL_Type 'B' +#define MOD_Type 'C' +#define UBITS_Type 'D' +#define VECTOR_Type 'E' +#define MATRIX_Type 'F' +#define STRUCT_Type 'G' +#define MODPOL_Type 'H' +#define RINT_Type 'I' +#define SBITS_Type 'J' + +CAO_RES CAO_global_decl(CAO_REF * n, const char *type, void *indices[]) +{ + int jump; + return _CAO_global_decl(n, type, indices, &jump); +} + +CAO_RES _CAO_global_decl(CAO_REF * n, const char *type, void *indices[], + int *jump) +{ + + int res; + + switch (*type) + { + case INT_Type: + res = CAO_int_decl(n); + *jump = 1; + break; + + case BOOL_Type: + *(int **)n = new int; + **(int **)n = 0; + *jump = 1; + res = CAO_OK; + break; + + case MOD_Type: + res = CAO_mod_decl(n, (CAO_int) (indices[0])); + *jump = 1; + break; + + case UBITS_Type: + res = CAO_ubits_decl(n, *(CAO_rint *) (indices[0])); + *jump = 1; + break; + + case SBITS_Type: + res = CAO_sbits_decl(n, *(CAO_rint *) (indices[0])); + *jump = 1; + break; + + case VECTOR_Type: + res = + _CAO_vector_decl(n, *(CAO_rint *) (indices[0]), type + 1, + indices + 1, jump); + (*jump)++; + break; + + case MATRIX_Type: + res = + _CAO_matrix_decl(n, ((CAO_rint *) (indices[0]))[0], + ((CAO_rint *) (indices[0]))[1], type + 1, + indices + 1, jump); + (*jump)++; + break; + + case STRUCT_Type: + res = + _CAO_struct_decl(n, *(CAO_rint *) (indices[0]), type + 1, + indices + 1, jump); + (*jump)++; + break; + + case MODPOL_Type: + res = CAO_modpol_decl(n, ((CAO_int *)indices[0])[0], ((CAO_int *)indices[0])[1], (((CAO_int *)indices[0]) + 2)); + + //res = _CAO_modpol_decl(n, *(CAO_rint *) (((void **)(indices[0]))[0]), (CAO_mod *) (((void **)(indices[0]))[1])); // TODO: + // it + // should + // call + // CAO_modpol_decl + // not + // _CAO_modpol_decl + *jump = 1; + break; + + case RINT_Type: + *(int **)n = new int; + **(int **)n = 0; + *jump = 1; + res = CAO_OK; + break; + + default: + return CAO_ERR; + } + return res; +} + +CAO_RES CAO_global_dispose(CAO_REF r, char type) +{ + + int res; + + switch (type) + { + + case INT_Type: + res = CAO_int_dispose(r); + break; + + case BOOL_Type: + delete((int *)r); + res = CAO_OK; + break; + + case MOD_Type: + res = CAO_mod_dispose(r); + break; + + case UBITS_Type: + res = CAO_ubits_dispose(r); + break; + case SBITS_Type: + res = CAO_sbits_dispose(r); + break; + case VECTOR_Type: + res = CAO_vector_dispose(r); + break; + case MATRIX_Type: + res = CAO_matrix_dispose(r); + break; + case STRUCT_Type: + res = CAO_struct_dispose(r); + break; + case MODPOL_Type: + res = CAO_modpol_dispose(r); + break; + + case RINT_Type: + delete((int *)r); + res = CAO_OK; + break; + + default: + return CAO_ERR; + } + return res; +} + +CAO_RES CAO_global_assign(CAO_REF dest, CAO_REF source, char type) +{ + int res; + switch (type) + { + case INT_Type: + res = CAO_int_assign(dest, source); + break; + + case BOOL_Type: + *(int *)dest = *(int *)source; + res = CAO_OK; + break; + + case MOD_Type: + res = CAO_mod_assign(dest, source); + break; + + case UBITS_Type: + res = CAO_ubits_assign(dest, source); + break; + + case SBITS_Type: + res = CAO_sbits_assign(dest, source); + break; + case VECTOR_Type: + res = CAO_vector_assign(dest, source); + break; + case MATRIX_Type: + res = CAO_matrix_assign(dest, source); + break; + case STRUCT_Type: + res = CAO_struct_assign(dest, source); + break; + case MODPOL_Type: + res = CAO_modpol_assign(dest, source); + break; + case RINT_Type: + *(int *)dest = *(int *)source; + res = CAO_OK; + break; + default: + return CAO_ERR; + } + + return res; +} + +CAO_RES CAO_global_clone(CAO_REF * dest, CAO_REF source, char type) +{ + int res; + switch (type) + { + case INT_Type: + res = CAO_int_clone(dest, source); + break; + case BOOL_Type: + *((int **)dest) = new int; + *(*(int **)dest) = *(int *)source; + res = CAO_OK; + break; + case MOD_Type: + res = CAO_mod_clone(dest, source); + break; + case UBITS_Type: + res = CAO_ubits_clone(dest, source); + break; + case SBITS_Type: + res = CAO_sbits_clone(dest, source); + break; + case VECTOR_Type: + res = CAO_vector_clone(dest, source); + break; + case MATRIX_Type: + res = CAO_matrix_clone(dest, source); + break; + case STRUCT_Type: + res = CAO_struct_clone(dest, source); + break; + case MODPOL_Type: + res = CAO_modpol_clone(dest, source); + break; + case RINT_Type: + *(int **)dest = new int; + *(int *)dest = *(int *)source; + res = CAO_OK; + break; + default: + return CAO_ERR; + } + return res; +} + +CAO_bool _CAO_global_equal(CAO_REF a, CAO_REF b, char type) +{ + switch (type) + { + case INT_Type: + return _CAO_int_equal(a, b); + break; + case BOOL_Type: + return *(int *)a == *(int *)b; + break; + case MOD_Type: + return _CAO_mod_equal(a, b); + break; + case UBITS_Type: + return _CAO_ubits_equal(a, b); + break; + case SBITS_Type: + return _CAO_sbits_equal(a, b); + break; + case VECTOR_Type: + return _CAO_vector_equal(a, b); + break; + case MATRIX_Type: + return _CAO_matrix_equal(a, b); + break; + case STRUCT_Type: + return _CAO_struct_equal(a, b); + break; + case MODPOL_Type: + return _CAO_modpol_equal(a, b); + break; + case RINT_Type: + return *(int *)a == *(int *)b; + break; + default: + return false; + } +} + +CAO_RES CAO_global_const_init(CAO_REF r, void *value, char type) +{ + int res; + switch (type) + { + case INT_Type: + res = CAO_int_init(r, (char *)value); + break; + case BOOL_Type: + *(int *)r = *(int *)value; + res = CAO_OK; + break; + case MOD_Type: + res = CAO_mod_init(r, (char *)value); + break; + case UBITS_Type: + res = CAO_ubits_init(r, (char *)value); + break; + case SBITS_Type: + res = CAO_sbits_init(r, (char *)value); + break; + case VECTOR_Type: + res = CAO_vector_const_init(r, value); + break; + case MATRIX_Type: + res = CAO_matrix_const_init(r, value); + break; + case STRUCT_Type: + res = CAO_struct_const_init(r, value); + break; + case MODPOL_Type: + res = CAO_modpol_init(r, (char *)value); + break; + case RINT_Type: + *(int *)r = *(int *)value; + res = CAO_OK; + break; + default: + return CAO_ERR; + } + return res; + +} + +CAO_RES CAO_global_init(CAO_REF r, void *value[], char type) +{ + int vjump = 0; + return _CAO_global_init(r, value, &vjump, type); +} + +CAO_RES _CAO_global_init(CAO_REF r, void *value[], int *vjump, char type) +{ + int res; + switch (type) + { + case INT_Type: + res = CAO_int_init(r, (char *)value[0]); + *vjump = 1; + break; + + case BOOL_Type: + *(int *)r = *(int *)value[0]; + *vjump = 1; + res = CAO_OK; + break; + + case MOD_Type: + res = CAO_mod_init(r, (char *)value[0]); + *vjump = 1; + break; + + case UBITS_Type: + res = CAO_ubits_init(r, (char *)value[0]); + *vjump = 1; + break; + + case SBITS_Type: + res = CAO_sbits_init(r, (char *)value[0]); + *vjump = 1; + break; + + case VECTOR_Type: + res = _CAO_vector_init(r, value, vjump); + break; + + case MATRIX_Type: + res = _CAO_matrix_init(r, value, vjump); + break; + + case STRUCT_Type: + res = _CAO_struct_init(r, value, vjump); + break; + + case MODPOL_Type: + res = CAO_modpol_init(r, (char *)value[0]); + *vjump = 1; + break; + + case RINT_Type: + *(int *)r = *(int *)value[0]; + *vjump = 1; + res = CAO_OK; + break; + + default: + return CAO_ERR; + + } + return res; + +} + +CAO_RES CAO_global_dump(CAO_REF r, char type) +{ + int res; + switch (type) + { + case INT_Type: + res = CAO_int_dump(r); + break; + case BOOL_Type: + res = CAO_bool_dump(*(int *)r); + break; + case MOD_Type: + res = CAO_mod_dump(r); + break; + case UBITS_Type: + res = CAO_ubits_dump(r); + break; + case SBITS_Type: + res = CAO_sbits_dump(r); + break; + + case VECTOR_Type: + res = CAO_vector_dump(r); + break; + case MATRIX_Type: + res = CAO_matrix_dump(r); + break; + case STRUCT_Type: + res = CAO_struct_dump(r); + break; + + case MODPOL_Type: + res = CAO_modpol_dump(r); + break; + case RINT_Type: + res = CAO_rint_dump(*(int *)r); + break; + default: + return CAO_ERR; + } + return res; + +} + +CAO_RES CAO_global_ref(CAO_REF * res, CAO_REF root, char type, CAO_rint path[], + int pathlen) +{ + int container = 1, i = 0; + CAO_REF ref = root; + + while (container && (i < pathlen)) + switch (type) + { + case VECTOR_Type: + ref = _CAO_vector_ref(ref, path[i++], &type); + break; + case MATRIX_Type: + ref = _CAO_matrix_ref(ref, path[i], path[i + 1], &type); + i += 2; + break; + case STRUCT_Type: + ref = _CAO_struct_ref(ref, path[i++], &type); + break; + default: + container = 0; + } + *res = ref; + if (i == pathlen) + return CAO_OK; + else + return CAO_ERR; +} + +CAO_RES CAO_global_addTo(CAO_REF x, CAO_REF y, char type) +{ + CAO_RES res; + + switch (type) + { + case INT_Type: + res = CAO_int_addTo(x, y); + break; + case MOD_Type: + res = CAO_mod_addTo(x, y); + break; + case MODPOL_Type: + res = CAO_modpol_addTo(x, y); + break; + case MATRIX_Type: + res = CAO_matrix_addTo(x, y); + break; + case RINT_Type: + *(int *)x += *(int *)y; + res = CAO_OK; + break; + default: + return CAO_ERR; + } + return res; +} + +CAO_RES CAO_global_subTo(CAO_REF x, CAO_REF y, char type) +{ + CAO_RES res; + + switch (type) + { + case INT_Type: + res = CAO_int_subTo(x, y); + break; + case MOD_Type: + res = CAO_mod_subTo(x, y); + break; + case MODPOL_Type: + res = CAO_modpol_subTo(x, y); + break; + case MATRIX_Type: + res = CAO_matrix_subTo(x, y); + break; + case RINT_Type: + *(int *)x -= *(int *)y; + res = CAO_OK; + break; + default: + return CAO_ERR; + } + return res; +} + +CAO_RES CAO_global_sym(CAO_REF x, CAO_REF y, char type) +{ + CAO_RES res; + + switch (type) + { + case INT_Type: + res = CAO_int_sym(x, y); + break; + case MOD_Type: + res = CAO_mod_sym(x, y); + break; + case MODPOL_Type: + res = CAO_modpol_sym(x, y); + break; + case MATRIX_Type: + res = CAO_matrix_sym(x, y); + break; + case RINT_Type: + CAO_rint_sym(*(int *)x, *(int *)y); + res = CAO_OK; + break; + default: + return CAO_ERR; + } + return res; +} + +CAO_RES CAO_global_mul(CAO_REF r, CAO_REF a, CAO_REF b, char type) +{ + CAO_RES res; + + switch (type) + { + case INT_Type: + res = CAO_int_mul(r, a, b); + break; + case MOD_Type: + res = CAO_mod_mul(r, a, b); + break; + case MODPOL_Type: + res = CAO_modpol_mul(r, a, b); + break; + case MATRIX_Type: + res = CAO_matrix_mul(r, a, b); + break; + case RINT_Type: + CAO_rint_mul(*(int *)r, *(int *)a, *(int *)b); + res = CAO_OK; + break; + default: + return CAO_ERR; + } + return res; +} + +CAO_RES CAO_global_assign_zero(CAO_REF s, char type) +{ + CAO_RES res; + + switch (type) + { + case INT_Type: + res = CAO_int_assign_zero(s); + break; + case MOD_Type: + res = CAO_mod_assign_zero(s); + break; + case MODPOL_Type: + res = CAO_modpol_assign_zero(s); + break; + case MATRIX_Type: + res = CAO_matrix_assign_zero(s); + break; + case RINT_Type: + *(int *)s = 0; + res = CAO_OK; + break; + default: + return CAO_ERR; + } + return res; + +} + +CAO_RES CAO_global_assign_one(CAO_REF s, char type) +{ + CAO_RES res; + + switch (type) + { + case INT_Type: + res = CAO_int_assign_one(s); + break; + case MOD_Type: + res = CAO_mod_assign_one(s); + break; + case MODPOL_Type: + res = CAO_modpol_assign_one(s); + break; + case MATRIX_Type: + res = CAO_matrix_assign_one(s); + break; + case RINT_Type: + *(int *)s = 1; + res = CAO_OK; + break; + default: + return CAO_ERR; + } + return res; + +} + +CAO_RES CAO_global_cast(CAO_REF d, char td, CAO_REF s, char ts) +{ + CAO_RES res; + + switch (ts) + { + case INT_Type: + switch (td) + { + case RINT_Type: + CAO_int_cast_rint(*(int *)d, s); + res = CAO_OK; + break; + case UBITS_Type: + res = CAO_int_cast_ubits(d, s); + break; + case SBITS_Type: + res = CAO_int_cast_sbits(d, s); + break; + case MOD_Type: + res = CAO_int_cast_mod(d, s); + break; + default: + res = CAO_ERR; + } + break; + case MOD_Type: + switch (td) + { + case INT_Type: + res = CAO_mod_cast_int(d, s); + break; + case MOD_Type: + res = CAO_mod_cast_mod(d, s); + break; + case MODPOL_Type: + res = CAO_mod_cast_modpol(d, s); + break; + default: + res = CAO_ERR; + } + break; + case UBITS_Type: + switch (td) + { + case INT_Type: + res = CAO_ubits_cast_int(d, s); + break; + case UBITS_Type: + res = CAO_ubits_cast_ubits(d, s); + break; + default: + res = CAO_ERR; + } + break; + case SBITS_Type: + switch (td) + { + case INT_Type: + res = CAO_sbits_cast_int(d, s); + break; + case SBITS_Type: + res = CAO_sbits_cast_sbits(d, s); + break; + default: + res = CAO_ERR; + } + break; + case VECTOR_Type: + switch (td) + { + case VECTOR_Type: + res = CAO_vector_cast_vector(d, s); + break; + case MATRIX_Type: + res = CAO_vector_cast_matrix(d, s); + break; + case MODPOL_Type: + res = CAO_vector_cast_modpol(d, s); + break; + default: + res = CAO_ERR; + } + break; + case MATRIX_Type: + switch (td) + { + case MATRIX_Type: + res = CAO_matrix_cast_matrix(d, s); + break; + case VECTOR_Type: + res = CAO_matrix_cast_vector(d, s); + break; + case MODPOL_Type: + res = CAO_matrix_cast_modpol(d, s); + break; + default: + res = CAO_ERR; + } + break; + case STRUCT_Type: + switch (td) + { + case STRUCT_Type: + res = CAO_struct_assign(d, s); + break; + default: + res = CAO_ERR; + } + break; + case MODPOL_Type: + switch (td) + { + case VECTOR_Type: + res = CAO_modpol_cast_vector(d, s); + break; + case MATRIX_Type: + res = CAO_modpol_cast_matrix(d, s); + break; + default: + res = CAO_ERR; + } + break; + case RINT_Type: + switch (td) + { + case INT_Type: + res = CAO_rint_cast_int(d, *(int *)s); + break; + } + break; + default: + res = CAO_ERR; + } + return res; +} diff --git a/backend_lib/C_generic/CAO_globalOp.h b/backend_lib/C_generic/CAO_globalOp.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_globalOp.h @@ -0,0 +1,58 @@ +#ifndef CAO_GLOBALOP_H +#define CAO_GLOBALOP_H + +#include "CAO_globals.h" + +#include "CAO_rint.h" +#include "CAO_bool.h" +#include "CAO_int.h" +#include "CAO_ubits.h" +#include "CAO_sbits.h" +#include "CAO_mod.h" +#include "CAO_modpol.h" + +#include "CAO_struct.h" +#include "CAO_vector.h" +#include "CAO_matrix.h" + +#ifdef __cplusplus + +#include +#include +#include + +extern "C" { +#endif + + CAO_RES CAO_global_decl(CAO_REF *, const char *, void *[]); + CAO_RES _CAO_global_decl(CAO_REF *, const char *, void *[], int *); + + CAO_RES CAO_global_assign(CAO_REF, CAO_REF, char); + CAO_RES CAO_global_const_init(CAO_REF, void *, char); + + CAO_RES CAO_global_init(CAO_REF, void *[], char); + CAO_RES _CAO_global_init(CAO_REF, void *[], int *, char); + + CAO_RES CAO_global_clone(CAO_REF *, CAO_REF, char); + CAO_RES CAO_global_dispose(CAO_REF, char); + + CAO_RES CAO_global_ref(CAO_REF *, CAO_REF, char, CAO_rint *, int); + + #define CAO_global_equal(a,b,c,d) a = _CAO_global_equal(b,c,d) + CAO_bool _CAO_global_equal (CAO_REF, CAO_REF, char); + + CAO_RES CAO_global_addTo(CAO_REF, CAO_REF, char); + CAO_RES CAO_global_subTo(CAO_REF, CAO_REF, char); + CAO_RES CAO_global_sym(CAO_REF, CAO_REF, char); + CAO_RES CAO_global_mul(CAO_REF, CAO_REF, CAO_REF, char); + CAO_RES CAO_global_assign_zero(CAO_REF, char); + CAO_RES CAO_global_assign_one(CAO_REF, char); + + CAO_RES CAO_global_dump(CAO_REF, char); + CAO_RES CAO_global_cast(CAO_REF, char, CAO_REF, char); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/backend_lib/C_generic/CAO_globals.h b/backend_lib/C_generic/CAO_globals.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_globals.h @@ -0,0 +1,21 @@ +#ifndef CAO_GLOBALS_H +#define CAO_GLOBALS_H + +typedef int CAO_RES; +#define CAO_OK 0 +#define CAO_ERR (-1) + +typedef void* CAO_REF; + +typedef int CAO_rint; +typedef int CAO_bool; +typedef CAO_REF CAO_int; +typedef CAO_REF CAO_ubits; +typedef CAO_REF CAO_sbits; +typedef CAO_REF CAO_mod; +typedef CAO_REF CAO_vector; +typedef CAO_REF CAO_matrix; +typedef CAO_REF CAO_struct; +typedef CAO_REF CAO_modpol; + +#endif diff --git a/backend_lib/C_generic/CAO_int.cpp b/backend_lib/C_generic/CAO_int.cpp new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_int.cpp @@ -0,0 +1,222 @@ +#include "CAO_int.h" + +CAO_RES CAO_int_decl(CAO_int * i) +{ + *i = (CAO_int) new(ZZ); + return CAO_OK; +} + +CAO_RES CAO_int_init(CAO_int i, const char *val) +{ + ZZ *_i = (ZZ *) i; + (*_i) = to_ZZ(val); + return CAO_OK; +} + +CAO_RES CAO_int_assign(CAO_int i, CAO_int j) +{ + ZZ *_i = (ZZ *) i; + ZZ *_j = (ZZ *) j; + (*_i) = (*_j); + return CAO_OK; +} + +CAO_RES CAO_int_assign_one(CAO_int i) +{ + ZZ *_i = (ZZ *) i; + set(*_i); + return CAO_OK; +} + +CAO_RES CAO_int_assign_zero(CAO_int i) +{ + ZZ *_i = (ZZ *) i; + clear(*_i); + return CAO_OK; +} + +CAO_RES CAO_int_clone(CAO_int * i, CAO_int j) +{ + CAO_int_decl(i); + CAO_int_assign(*i, j); + return CAO_OK; +} + +CAO_RES CAO_int_dispose(CAO_int i) +{ + ZZ *_i = (ZZ *) i; + delete(_i); + return CAO_OK; +} + +CAO_RES CAO_int_add(CAO_int r, CAO_int a, CAO_int b) +{ + ZZ *_a = (ZZ *) a; + ZZ *_b = (ZZ *) b; + ZZ *_r = (ZZ *) r; + (*_r) = (*_a) + (*_b); + return CAO_OK; +} + +CAO_RES CAO_int_addTo(CAO_int r, CAO_int a) +{ + ZZ *_a = (ZZ *) a; + ZZ *_r = (ZZ *) r; + (*_r) += (*_a); + return CAO_OK; +} + +CAO_RES CAO_int_sub(CAO_int r, CAO_int a, CAO_int b) +{ + ZZ *_a = (ZZ *) a; + ZZ *_b = (ZZ *) b; + ZZ *_r = (ZZ *) r; + (*_r) = (*_a) - (*_b); + return CAO_OK; +} + +CAO_RES CAO_int_subTo(CAO_int r, CAO_int a) +{ + ZZ *_a = (ZZ *) a; + ZZ *_r = (ZZ *) r; + (*_r) -= (*_a); + return CAO_OK; +} + +CAO_RES CAO_int_sym(CAO_int r, CAO_int a) +{ + ZZ *_a = (ZZ *) a; + ZZ *_r = (ZZ *) r; + (*_r) = -(*_a); + return CAO_OK; +} + +CAO_RES CAO_int_mul(CAO_int r, CAO_int a, CAO_int b) +{ + ZZ *_a = (ZZ *) a; + ZZ *_b = (ZZ *) b; + ZZ *_r = (ZZ *) r; + (*_r) = (*_a) * (*_b); + return CAO_OK; +} + +CAO_RES CAO_int_div(CAO_int r, CAO_int a, CAO_int b) +{ + ZZ *_a = (ZZ *) a; + ZZ *_b = (ZZ *) b; + ZZ *_r = (ZZ *) r; + (*_r) = (*_a) / (*_b); + return CAO_OK; +} + +CAO_RES CAO_int_mod(CAO_int r, CAO_int a, CAO_int b) +{ + ZZ *_a = (ZZ *) a; + ZZ *_b = (ZZ *) b; + ZZ *_r = (ZZ *) r; + (*_r) = (*_a) % (*_b); + return CAO_OK; +} + +CAO_RES CAO_int_pow(CAO_int r, CAO_int a, CAO_int b) +{ + // r = a ^ b; + ZZ *_r = (ZZ *) r; + ZZ *_a = (ZZ *) a; + ZZ *_b = (ZZ *) b; + + long i, k = NumBits(*_b); + *_r = 1; + + for (i = k - 1; i >= 0; i--) + { + (*_r) = (*_r) * (*_r); + if (bit(*_b, i) == 1) + { + (*_r) = ((*_r) * (*_a)); + } + } + + return CAO_OK; +} + +CAO_bool _CAO_int_equal(CAO_int i, CAO_int j) +{ + ZZ *_i = (ZZ *) i; + ZZ *_j = (ZZ *) j; + CAO_bool r; + r = ((*_i) == (*_j)); + return r; +} + +CAO_bool _CAO_int_nequal(CAO_int i, CAO_int j) +{ + ZZ *_i = (ZZ *) i; + ZZ *_j = (ZZ *) j; + CAO_bool r; + r = ((*_i) != (*_j)); + return r; +} + +CAO_bool _CAO_int_lt(CAO_int i, CAO_int j) +{ + ZZ *_i = (ZZ *) i; + ZZ *_j = (ZZ *) j; + CAO_bool r; + r = ((*_i) < (*_j)); + return r; +} + +CAO_bool _CAO_int_lte(CAO_int i, CAO_int j) +{ + ZZ *_i = (ZZ *) i; + ZZ *_j = (ZZ *) j; + CAO_bool r; + r = ((*_i) <= (*_j)); + return r; +} + +CAO_bool _CAO_int_gt(CAO_int i, CAO_int j) +{ + ZZ *_i = (ZZ *) i; + ZZ *_j = (ZZ *) j; + CAO_bool r; + r = ((*_i) > (*_j)); + return r; +} + +CAO_bool _CAO_int_gte(CAO_int i, CAO_int j) +{ + ZZ *_i = (ZZ *) i; + ZZ *_j = (ZZ *) j; + CAO_bool r; + r = ((*_i) >= (*_j)); + return r; +} + +CAO_RES CAO_int_dump(CAO_int i) +{ + ZZ *_i = (ZZ *) i; + std::cout << (*_i) << "\n"; + return CAO_OK; +} + +CAO_rint _CAO_int_cast_rint(CAO_int i) +{ + unsigned char rep[4]; + int out; + ZZ *_i = (ZZ *) i; + + if (((unsigned long)NumBits(*_i)) > ((8 * sizeof(int)) - 1)) + { + return CAO_ERR; + } + + BytesFromZZ(rep, (*_i), 4); + out = rep[3]; + out = (out << 8) | rep[2]; + out = (out << 8) | rep[1]; + out = (out << 8) | rep[0]; + + return out; +} diff --git a/backend_lib/C_generic/CAO_int.h b/backend_lib/C_generic/CAO_int.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_int.h @@ -0,0 +1,57 @@ +#ifndef CAO_INT_H +#define CAO_INT_H + +#include "CAO_globals.h" +#include "CAO_bool.h" + +#ifdef __cplusplus + +#include +#include + +NTL_CLIENT + +extern "C" { +#endif + + CAO_RES CAO_int_decl(CAO_int *); + CAO_RES CAO_int_init(CAO_int, const char *); + CAO_RES CAO_int_assign(CAO_int, CAO_int); + CAO_RES CAO_int_assign_one(CAO_int); + CAO_RES CAO_int_assign_zero(CAO_int); + CAO_RES CAO_int_clone(CAO_int *, CAO_int); + CAO_RES CAO_int_dispose(CAO_int); + CAO_RES CAO_int_add(CAO_int, CAO_int, CAO_int); + CAO_RES CAO_int_addTo(CAO_int, CAO_int); + CAO_RES CAO_int_sub(CAO_int, CAO_int, CAO_int); + CAO_RES CAO_int_subTo(CAO_int, CAO_int); + CAO_RES CAO_int_sym(CAO_int, CAO_int); + CAO_RES CAO_int_mul(CAO_int, CAO_int, CAO_int); + CAO_RES CAO_int_div(CAO_int, CAO_int, CAO_int); + CAO_RES CAO_int_mod(CAO_int, CAO_int, CAO_int); + + CAO_RES CAO_int_pow(CAO_int, CAO_int, CAO_int); + + #define CAO_int_equal(a,b,c) a = _CAO_int_equal(b,c) + CAO_bool _CAO_int_equal(CAO_int, CAO_int); + #define CAO_int_nequal(a,b,c) a = _CAO_int_nequal(b,c) + CAO_bool _CAO_int_nequal(CAO_int, CAO_int); + #define CAO_int_lt(a,b,c) a = _CAO_int_lt(b,c) + CAO_bool _CAO_int_lt(CAO_int, CAO_int); + #define CAO_int_lte(a,b,c) a = _CAO_int_lte(b,c) + CAO_bool _CAO_int_lte(CAO_int, CAO_int); + #define CAO_int_gt(a,b,c) a = _CAO_int_gt(b,c) + CAO_bool _CAO_int_gt(CAO_int, CAO_int); + #define CAO_int_gte(a,b,c) a = _CAO_int_gte(b,c) + CAO_bool _CAO_int_gte(CAO_int, CAO_int); + + CAO_RES CAO_int_dump(CAO_int); + + #define CAO_int_cast_rint(a,b) a = _CAO_int_cast_rint(b) + CAO_rint _CAO_int_cast_rint(CAO_int); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/backend_lib/C_generic/CAO_matrix.cpp b/backend_lib/C_generic/CAO_matrix.cpp new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_matrix.cpp @@ -0,0 +1,587 @@ +#include "CAO_matrix.h" + +CAO_matrix_s *newMatrix(int rows, int cols, char type) +{ + CAO_matrix_s *newM; + + newM = (CAO_matrix_s *) malloc(sizeof(CAO_matrix_s)); + newM->rows = rows; + newM->cols = cols; + newM->type = type; + newM->value = (CAO_REF *) malloc(cols * rows * sizeof(CAO_REF)); + + return newM; +} + +CAO_RES +CAO_matrix_decl(CAO_matrix * m, int rows, int cols, const char type[], + void *indices[]) +{ + int jump; + return _CAO_matrix_decl(m, rows, cols, type, indices, &jump); +} + +CAO_RES +_CAO_matrix_decl(CAO_matrix * m, int rows, int cols, const char type[], + void *indices[], int *jump) +{ + int i, size = rows * cols, res = CAO_OK; + CAO_matrix_s *_m = newMatrix(rows, cols, type[0]); + + for (i = 0; ((res == CAO_OK) && (i < size)); i++) + res = _CAO_global_decl(&(_m->value[i]), type, indices, jump); + + *m = _m; + return res; +} + +int CAO_matrix_iscol(CAO_matrix m) +{ + CAO_matrix_s *_m = (CAO_matrix_s *) m; + if (_m->cols == 1) + return 1; + return 0; +} + +CAO_RES CAO_matrix_dispose(CAO_matrix m) +{ + int i, size; + CAO_RES res = CAO_OK; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + size = _m->rows * _m->cols; + + for (i = 0; ((i < size) && (res == CAO_OK)); i++) + res = CAO_global_dispose(_m->value[i], _m->type); + + free(_m->value); + free(_m); + + return res; +} + +CAO_RES CAO_matrix_const_init(CAO_matrix m, void *value) +{ + CAO_matrix_s *_m = (CAO_matrix_s *) m; + + int s = _m->rows * _m->cols, i; + + for (i = 0; (i < s); i++) + CAO_global_const_init(_m->value[i], value, _m->type); + + return CAO_OK; +} + +CAO_RES CAO_matrix_init(CAO_matrix m, void *value[]) +{ + int vjump = 0; + return _CAO_matrix_init(m, value, &vjump); +} + +CAO_RES _CAO_matrix_init(CAO_matrix m, void *value[], int *vjump) +{ + + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int offset = 0; + + int s = (_m->rows * _m->cols), i; + + for (i = 0; (i < s); i++) + { + _CAO_global_init(_m->value[i], value + offset, vjump, _m->type); + offset += *vjump; + } + *vjump = offset; + return CAO_OK; +} + +CAO_RES CAO_matrix_assign(CAO_matrix r, CAO_matrix m) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int sr = (_r->rows * _r->cols); + + int i; + for (i = 0; i < sr; i++) + CAO_global_assign(_r->value[i], _m->value[i], _r->type); + + return CAO_OK; +} + +CAO_RES CAO_matrix_clone(CAO_matrix * r, CAO_matrix m) +{ + CAO_matrix_s *_m = (CAO_matrix_s *) m; + CAO_matrix_s *_r = newMatrix(_m->rows, _m->cols, _m->type); + + int size = (_m->rows * _m->cols); + + int i; + for (i = 0; i < size; i++) + CAO_global_clone(&(_r->value[i]), _m->value[i], _m->type); + *r = _r; + return CAO_OK; +} + +CAO_bool _CAO_matrix_equal(CAO_matrix a, CAO_matrix b) +{ + CAO_bool r; + + CAO_matrix_s *_a = (CAO_matrix_s *) a; + CAO_matrix_s *_b = (CAO_matrix_s *) b; + int sa = (_a->rows * _a->cols); + int i; + + r = true; + i = 0; + while ((r) && (i < sa)) + { + CAO_global_equal(r, _a->value[i], _b->value[i], _a->type); + i++; + } + + return r; +} + +CAO_RES CAO_matrix_select(CAO_REF r, CAO_matrix m, CAO_rint i, CAO_rint j) +{ + CAO_matrix_s *_m = (CAO_matrix_s *) m; + + if ((i >= 0) && (i < _m->rows) && (j >= 0) && (j < _m->cols)) + { + CAO_global_assign(r, _m->value[i * _m->cols + j], _m->type); + } + else + { + return CAO_ERR; + } + return CAO_OK; +} + +CAO_REF CAO_matrix_ref(CAO_matrix m, CAO_rint i, CAO_rint j) +{ + char type; + return _CAO_matrix_ref(m, i, j, &type); +} + +CAO_REF _CAO_matrix_ref(CAO_matrix m, CAO_rint i, CAO_rint j, char *t) +{ + CAO_matrix_s *_m = (CAO_matrix_s *) m; + *t = _m->type; + return (_m->value[i * _m->cols + j]); +} + +CAO_RES +CAO_matrix_range_select(CAO_matrix r, CAO_matrix m, CAO_rint ri, CAO_rint rj, + CAO_rint ci, CAO_rint cj) +{ + + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int i, j, pr, pm; + + if ((ri >= 0) && (ri < _m->rows) && + (rj >= 0) && (rj < _m->rows) && (ri <= rj) && (ci >= 0) + && (ci < _m->rows) && (cj >= 0) && (cj < _m->rows) && (ci <= cj)) + { + pr = 0; + for (i = ri; (i <= rj); i++) + { + pm = i * _m->cols + ci; + for (j = ci; (j <= cj); j++) + { + CAO_global_assign(_r->value[pr++], _m->value[pm++], _r->type); + } + } + } + else + { + return CAO_ERR; + } + + return CAO_OK; +} + +CAO_RES +CAO_matrix_row_range_select(CAO_matrix r, CAO_matrix m, CAO_rint c, + CAO_rint ri, CAO_rint rj) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int size; + int i, pr, pm; + + size = (rj - ri + 1); + + if ((ri >= 0) && (ri < _m->rows) && (rj >= 0) && (rj < _m->rows) + && (ri <= rj)) + { + pr = 0; + pm = ri * _m->cols + c; + for (i = 0; (i < size); i++) + { + CAO_global_assign(_r->value[pr], _m->value[pm], _r->type); + pr++; + pm += _m->cols; + } + } + else + { + return CAO_ERR; + } + return CAO_OK; +} + +CAO_RES +CAO_matrix_col_range_select(CAO_matrix r, CAO_matrix m, CAO_rint row, + CAO_rint ci, CAO_rint cj) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int size; + int i, pr, pm; + + size = (cj - ci + 1); + + if ((ci >= 0) && (ci < _m->rows) && (cj >= 0) && (cj < _m->rows) + && (ci <= cj)) + { + pr = 0; + pm = row * _m->cols + ci; + for (i = 0; (i < size); i++) + CAO_global_assign(_r->value[pr++], _m->value[pm++], _r->type); + } + else + { + return CAO_ERR; + } + + return CAO_OK; +} + +CAO_RES +CAO_matrix_range_set(CAO_matrix r, CAO_matrix m, CAO_rint ri, CAO_rint rj, + CAO_rint ci, CAO_rint cj) +{ + + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int i, j, pr, pm; + + if ((ri >= 0) && (ri < _r->rows) && + (rj >= 0) && (rj < _r->rows) && (ri <= rj) && (ci >= 0) + && (ci < _r->rows) && (cj >= 0) && (cj < _r->rows) && (ci <= cj)) + { + pm = 0; + for (i = ri; (i <= rj); i++) + { + pr = i * _r->cols + ci; + for (j = ci; (j <= cj); j++) + { + CAO_global_assign(_r->value[pr++], _m->value[pm++], _r->type); + } + } + } + else + { + return CAO_ERR; + } + + return CAO_OK; +} + +CAO_RES +CAO_matrix_row_range_set(CAO_matrix r, CAO_matrix m, CAO_rint c, CAO_rint ri, + CAO_rint rj) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int size; + int i, pr, pm; + + size = (rj - ri + 1); + + if ((ri >= 0) && (ri < _r->rows) && (rj >= 0) && (rj < _r->rows) + && (ri <= rj)) + { + pr = _r->cols * ri + c; + pm = 0; + for (i = 0; (i < size); i++) + { + CAO_global_assign(_r->value[pr], _m->value[pm], _r->type); + pr += _r->cols; + pm++; + } + } + else + { + return CAO_ERR; + } + return CAO_OK; +} + +CAO_RES +CAO_matrix_col_range_set(CAO_matrix r, CAO_matrix m, CAO_rint row, CAO_rint ci, + CAO_rint cj) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int size; + int i, pr, pm; + + size = cj - ci + 1; + + if ((ci >= 0) && (ci < _r->rows) && (cj >= 0) && (cj < _r->rows) + && (ci <= cj)) + { + pr = row * _r->cols + ci; + pm = 0; + for (i = 0; (i < size); i++) + { + CAO_global_assign(_r->value[pr++], _m->value[pm++], _r->type); + } + } + else + { + return CAO_ERR; + } + + return CAO_OK; +} + +CAO_RES CAO_matrix_concat(CAO_matrix r, CAO_matrix a, CAO_matrix b) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_a = (CAO_matrix_s *) a; + CAO_matrix_s *_b = (CAO_matrix_s *) b; + + int pr, p, i, j; + + pr = 0; + p = 0; + for (i = 0; (i < _a->rows); i++) + { + for (j = 0; (j < _a->cols); j++) + { + CAO_global_assign(_r->value[pr++], _a->value[p++], _r->type); + } + } + + p = 0; + for (i = 0; (i < _b->rows); i++) + { + for (j = 0; (j < _b->cols); j++) + { + CAO_global_assign(_r->value[pr++], _b->value[p++], _r->type); + } + } + + return CAO_OK; +} + +CAO_RES CAO_matrix_dump(CAO_matrix m) +{ + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int rm = _m->rows, cm = _m->cols, i, j, k; + + cout << "matrix[" << rm << " x " << cm << "] = \n"; + k = 0; + for (i = 0; (i < rm); i++) + { + cout << "row " << i << "\n"; + for (j = 0; (j < cm); j++) + { + CAO_global_dump(_m->value[k++], _m->type); + std::cout << "\n"; + } + } + cout << "end of matrix[" << rm << " x " << cm << "] = \n"; + + return CAO_OK; +} + +CAO_RES CAO_matrix_addTo(CAO_matrix r, CAO_matrix m) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int rsize = (_r->rows * _r->cols), i; + + CAO_RES res = CAO_OK; + + for (i = 0; ((i < rsize) && (res == CAO_OK)); i++) + { + res = CAO_global_addTo(_r->value[i], _m->value[i], _m->type); + } + + return res; +} + +CAO_RES CAO_matrix_add(CAO_matrix r, CAO_matrix a, CAO_matrix b) +{ + + if ((CAO_matrix_assign(r, a) == CAO_OK) + && (CAO_matrix_addTo(r, b) == CAO_OK)) + { + return CAO_OK; + } + else + { + return CAO_ERR; + } +} + +CAO_RES CAO_matrix_subTo(CAO_matrix r, CAO_matrix m) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int rsize = (_r->rows * _r->cols), i; + CAO_RES res = CAO_OK; + + for (i = 0; ((i < rsize) && (res == CAO_OK)); i++) + { + res = CAO_global_subTo(_r->value[i], _m->value[i], _m->type); + } + + return res; +} + +CAO_RES CAO_matrix_sub(CAO_matrix r, CAO_matrix a, CAO_matrix b) +{ + + if ((CAO_matrix_assign(r, a) == CAO_OK) + && (CAO_matrix_subTo(r, b) == CAO_OK)) + { + return CAO_OK; + } + else + { + return CAO_ERR; + } +} + +CAO_RES CAO_matrix_sym(CAO_matrix r, CAO_matrix m) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int rsize = (_r->rows * _r->cols), i; + CAO_RES res = CAO_OK; + + for (i = 0; ((i < rsize) && (res == CAO_OK)); i++) + { + res = CAO_global_sym(_r->value[i], _m->value[i], _m->type); + } + + return res; +} + +CAO_RES CAO_matrix_mul(CAO_matrix r, CAO_matrix a, CAO_matrix b) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + CAO_matrix_s *_a = (CAO_matrix_s *) a; + CAO_matrix_s *_b = (CAO_matrix_s *) b; + + CAO_REF tmp; + char type = _r->type; + int i, j, k; + + CAO_global_clone(&tmp, _r->value[0], type); + + for (i = 0; (i < _a->rows); i++) + { + for (j = 0; (j < _b->cols); j++) + { + CAO_global_mul(_r->value[i * _r->cols + j], + _a->value[i * _a->cols], _b->value[j], type); + + for (k = 1; (k < _a->cols); k++) + CAO_global_mul(tmp, _a->value[i * _a->cols + k], + _b->value[k * _b->cols + j], type); + + CAO_global_addTo(_r->value[i * _r->cols + j], tmp, type); + } + } + + CAO_global_dispose(tmp, type); + + return CAO_OK; +} + +CAO_RES CAO_matrix_assign_zero(CAO_matrix r) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + + int i, size = (_r->rows * _r->cols); + CAO_RES res = CAO_OK; + + for (i = 0; ((i < size) && (res == CAO_OK)); i++) + res = CAO_global_assign_zero(_r->value[i], _r->type); + + return res; +} + +CAO_RES CAO_matrix_assign_one(CAO_matrix r) +{ + CAO_matrix_s *_r = (CAO_matrix_s *) r; + int i, size = _r->rows * _r->cols; + CAO_RES res = CAO_OK; + + for (i = 0; ((i < size) && (res == CAO_OK)); i++) + res = CAO_global_assign_zero(_r->value[i], _r->type); + + for (i = 0; ((i < _r->rows) && (res = CAO_OK)); i += _r->cols) + res = CAO_global_assign_one(_r->value[i], _r->type); + + return res; +} + +CAO_RES CAO_matrix_pow(CAO_matrix r, CAO_matrix m, CAO_int n) +{ + + CAO_matrix a, aAux, rAux; + int junk = 1; + CAO_RES res = CAO_OK; + ZZ _n = *(ZZ *) n; + // Check for negative? + CAO_matrix_clone(&a, m); + CAO_matrix_clone(&aAux, a); + CAO_matrix_clone(&(rAux), r); + + while (!IsZero(_n)) + { + if (IsOdd(_n)) + { + if (junk) + { + junk = 0; + CAO_matrix_assign(r, a); + } + else + { + CAO_matrix_assign(rAux, r); + CAO_matrix_mul(r, rAux, a); + } + } + CAO_matrix_mul(aAux, a, a); + CAO_matrix_assign(a, aAux); + _n = _n / 2; + } + if (junk) + res = CAO_ERR; + CAO_matrix_dispose(a); + CAO_matrix_dispose(aAux); + CAO_matrix_dispose(rAux); + return res; +} + +CAO_RES CAO_matrix_cast_matrix(CAO_matrix d, CAO_matrix s) +{ + CAO_matrix_s *_s = (CAO_matrix_s *) s; + CAO_matrix_s *_d = (CAO_matrix_s *) d; + + int i, size = (_s->rows * _s->cols); + CAO_RES res; + + res = CAO_OK; + for (i = 0; ((res == CAO_OK) && (i < size)); i++) + res = CAO_global_cast(_d->value[i], _d->type, _s->value[i], _s->type); + + return res; +} diff --git a/backend_lib/C_generic/CAO_matrix.h b/backend_lib/C_generic/CAO_matrix.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_matrix.h @@ -0,0 +1,68 @@ +#ifndef CAO_MATRIX_H +#define CAO_MATRIX_H + +#include "CAO_globals.h" +#include "CAO_globalOp.h" + +#ifdef __cplusplus + +#include +#include + +NTL_CLIENT + +typedef struct CAO_matrix_s { + int rows; + int cols; + char type; + CAO_REF *value; +} CAO_matrix_s; + +extern "C" { +#endif + + CAO_RES CAO_matrix_decl(CAO_matrix *, CAO_rint, CAO_rint, const char *, void **); + CAO_RES _CAO_matrix_decl(CAO_matrix *, CAO_rint, CAO_rint, const char *, void **, int *); + + CAO_RES CAO_matrix_dispose(CAO_matrix); + CAO_RES CAO_matrix_const_init(CAO_matrix, void *); + + CAO_RES CAO_matrix_init(CAO_matrix, void **); + CAO_RES _CAO_matrix_init(CAO_matrix, void **, int *); + + CAO_RES CAO_matrix_assign(CAO_matrix, CAO_matrix); + CAO_RES CAO_matrix_clone(CAO_matrix *, CAO_matrix); + + CAO_REF CAO_matrix_ref(CAO_matrix, CAO_rint, CAO_rint); + CAO_REF _CAO_matrix_ref(CAO_matrix, CAO_rint, CAO_rint, char *); + + CAO_RES CAO_matrix_dump(CAO_matrix); + + #define CAO_matrix_equal(a,b,c) a = _CAO_matrix_equal(b,c) + CAO_bool _CAO_matrix_equal(CAO_matrix, CAO_matrix); + + CAO_RES CAO_matrix_select(CAO_REF, CAO_matrix, CAO_rint, CAO_rint); + CAO_RES CAO_matrix_range_select(CAO_matrix, CAO_matrix, CAO_rint, CAO_rint, CAO_rint, CAO_rint); + CAO_RES CAO_matrix_range_set(CAO_matrix, CAO_matrix, CAO_rint, CAO_rint, CAO_rint, CAO_rint); + CAO_RES CAO_matrix_row_range_select(CAO_matrix r, CAO_matrix m, CAO_rint c, CAO_rint ri, CAO_rint rj); + CAO_RES CAO_matrix_col_range_select (CAO_matrix r, CAO_matrix m, CAO_rint row, CAO_rint ci, CAO_rint cj); + CAO_RES CAO_matrix_row_range_set (CAO_matrix r, CAO_matrix m, CAO_rint c, CAO_rint ri, CAO_rint rj); + CAO_RES CAO_matrix_col_range_set (CAO_matrix r, CAO_matrix m, CAO_rint row, CAO_rint ci, CAO_rint cj); + + CAO_RES CAO_matrix_addTo (CAO_matrix r, CAO_matrix m8); + CAO_RES CAO_matrix_add (CAO_matrix r, CAO_matrix a, CAO_matrix b); + CAO_RES CAO_matrix_subTo (CAO_matrix r, CAO_matrix m); + CAO_RES CAO_matrix_sub (CAO_matrix r, CAO_matrix a, CAO_matrix b); + CAO_RES CAO_matrix_sym (CAO_matrix r, CAO_matrix m); + CAO_RES CAO_matrix_mul (CAO_matrix r, CAO_matrix a, CAO_matrix b); + CAO_RES CAO_matrix_assign_zero (CAO_matrix); + CAO_RES CAO_matrix_assign_one (CAO_matrix); + CAO_RES CAO_matrix_pow (CAO_matrix r, CAO_matrix m, CAO_int n); + + CAO_RES CAO_matrix_cast_matrix (CAO_matrix, CAO_matrix); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/backend_lib/C_generic/CAO_mod.cpp b/backend_lib/C_generic/CAO_mod.cpp new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_mod.cpp @@ -0,0 +1,232 @@ +#include "CAO_mod.h" + +CAO_RES CAO_mod_decl(CAO_mod * a, CAO_int n) +{ + ZZ _n = *(ZZ *) n; + CAO_mod_s *_a = (CAO_mod_s *) malloc(sizeof(CAO_mod_s)); + ZZ_p::init(_n); + _a->val = new ZZ_p(); + _a->bak = new ZZ_pBak(); + _a->bak->save(); + (*a) = (CAO_mod) _a; + return CAO_OK; +} + +CAO_RES CAO_mod_init(CAO_mod a, const char *val) +{ + istringstream ins; + CAO_mod_s *_a = (CAO_mod_s *) a; + _a->bak->restore(); + ins.str(val); + ins >> *_a->val; + _a->bak->save(); + return CAO_OK; +} + +CAO_RES _CAO_mod_init(CAO_mod a, CAO_int b) +{ + stringstream ss; + CAO_mod_s *_a = (CAO_mod_s *) a; + ZZ *_b = (ZZ *) b; + _a->bak->restore(); + ss << *_b; + ss >> *_a->val; + _a->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_mod_assign(CAO_mod a, CAO_mod b) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_mod_s *_b = (CAO_mod_s *) b; + _a->bak->restore(); + *_a->val = *_b->val; + _a->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_mod_assign_one(CAO_mod a) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + _a->bak->restore(); + set(*_a->val); + return CAO_OK; +} + +CAO_RES CAO_mod_assign_zero(CAO_mod a) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + _a->bak->restore(); + clear(*_a->val); + return CAO_OK; +} + +CAO_RES CAO_mod_clone(CAO_mod * a, CAO_mod b) +{ + CAO_mod_s *_a = (CAO_mod_s *) malloc(sizeof(CAO_mod_s)); + CAO_mod_s *_b = (CAO_mod_s *) b; + _b->bak->restore(); + _a->val = new ZZ_p(*_b->val); + _a->bak = new ZZ_pBak(); + _a->bak->save(); + _b->bak->save(); + *a = _a; + return CAO_OK; +} + +CAO_RES CAO_mod_dispose(CAO_mod a) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + delete(_a->val); + delete(_a->bak); + free(_a); + return CAO_OK; +} + +CAO_RES CAO_mod_add(CAO_mod r, CAO_mod a, CAO_mod b) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_mod_s *_b = (CAO_mod_s *) b; + CAO_mod_s *_r = (CAO_mod_s *) r; + _a->bak->restore(); + *_r->val = (*_a->val) + (*_b->val); + _a->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_mod_addTo(CAO_mod r, CAO_mod a) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_mod_s *_r = (CAO_mod_s *) r; + _a->bak->restore(); + *_r->val += (*_a->val); + _a->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_mod_sub(CAO_mod r, CAO_mod a, CAO_mod b) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_mod_s *_b = (CAO_mod_s *) b; + CAO_mod_s *_r = (CAO_mod_s *) r; + _a->bak->restore(); + *_r->val = (*_a->val) - (*_b->val); + _a->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_mod_subTo(CAO_mod r, CAO_mod a) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_mod_s *_r = (CAO_mod_s *) r; + _a->bak->restore(); + *_r->val -= (*_a->val); + _a->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_mod_mul(CAO_mod r, CAO_mod a, CAO_mod b) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_mod_s *_b = (CAO_mod_s *) b; + CAO_mod_s *_r = (CAO_mod_s *) r; + _a->bak->restore(); + *_r->val = (*_a->val) * (*_b->val); + _a->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_mod_div(CAO_mod r, CAO_mod a, CAO_mod b) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_mod_s *_b = (CAO_mod_s *) b; + CAO_mod_s *_r = (CAO_mod_s *) r; + _a->bak->restore(); + *_r->val = (*_a->val) / (*_b->val); + _a->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_mod_pow(CAO_mod r, CAO_mod a, CAO_int b) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + ZZ *_b = (ZZ *) b; + CAO_mod_s *_r = (CAO_mod_s *) r; + _a->bak->restore(); + *_r->val = power(*_a->val, *_b); + _a->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_mod_sym(CAO_mod r, CAO_mod a) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_mod_s *_r = (CAO_mod_s *) r; + _a->bak->restore(); + *_r->val = -(*_a->val); + _a->bak->save(); + return CAO_OK; +} + +CAO_bool _CAO_mod_equal(CAO_mod a, CAO_mod b) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_mod_s *_b = (CAO_mod_s *) b; + _a->bak->restore(); + CAO_bool r = (*_a->val == *_b->val); + _a->bak->save(); + return r; +} + +CAO_bool _CAO_mod_nequal(CAO_mod a, CAO_mod b) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_mod_s *_b = (CAO_mod_s *) b; + _a->bak->restore(); + CAO_bool r = (*_a->val != *_b->val); + _a->bak->save(); + return r; +} + +CAO_RES CAO_mod_dump(CAO_mod a) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + _a->bak->restore(); + std::cout << *_a->val << " mod " << ZZ_p::modulus() << "\n"; + _a->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_mod_cast_int(CAO_int b, CAO_mod a) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + ZZ *_b = (ZZ *) b; + _a->bak->restore(); + *_b = rep(*_a->val); + _a->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_mod_cast_mod(CAO_mod b, CAO_mod a) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_mod_s *_b = (CAO_mod_s *) b; + _b->bak->restore(); + stringstream ss(stringstream::in | stringstream::out); + ss << *_a->val; + ss >> *_b->val; + _b->bak->save(); + return CAO_OK; +} + +CAO_RES CAO_int_cast_mod(CAO_mod b, CAO_int a) +{ + CAO_mod_s *_b = (CAO_mod_s *) b; + ZZ *_a = (ZZ *) a; + _b->bak->restore(); + stringstream ss(stringstream::in | stringstream::out); + ss << *_a; + ss >> *_b->val; + _b->bak->save(); + return CAO_OK; +} diff --git a/backend_lib/C_generic/CAO_mod.h b/backend_lib/C_generic/CAO_mod.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_mod.h @@ -0,0 +1,55 @@ +#ifndef CAO_MOD_H +#define CAO_MOD_H + +#include "CAO_globals.h" + +#ifdef __cplusplus + +#include +#include +#include + +NTL_CLIENT + +typedef struct CAO_Mod_s { + ZZ_pBak *bak; + ZZ_p *val; +} CAO_mod_s; + +extern "C" { +#endif + + CAO_RES CAO_mod_decl(CAO_mod *, CAO_int); + + CAO_RES CAO_mod_init(CAO_mod, const char *); + CAO_RES _CAO_mod_init(CAO_mod, CAO_int); + + CAO_RES CAO_mod_assign(CAO_mod, CAO_mod); + CAO_RES CAO_mod_assign_one(CAO_mod); + CAO_RES CAO_mod_assign_zero(CAO_mod); + CAO_RES CAO_mod_clone(CAO_mod *, CAO_mod); + CAO_RES CAO_mod_dispose(CAO_mod); + CAO_RES CAO_mod_add(CAO_mod, CAO_mod, CAO_mod); + CAO_RES CAO_mod_addTo(CAO_mod, CAO_mod); + CAO_RES CAO_mod_subTo(CAO_mod, CAO_mod); + CAO_RES CAO_mod_sub(CAO_mod, CAO_mod, CAO_mod); + CAO_RES CAO_mod_mul(CAO_mod, CAO_mod, CAO_mod); + CAO_RES CAO_mod_div(CAO_mod, CAO_mod, CAO_mod); + CAO_RES CAO_mod_pow(CAO_mod, CAO_mod, CAO_int); + CAO_RES CAO_mod_sym(CAO_mod, CAO_mod); + + #define CAO_mod_equal(a,b,c) a = _CAO_mod_equal(b,c) + CAO_bool _CAO_mod_equal(CAO_mod, CAO_mod); + #define CAO_mod_nequal(a,b,c) a = _CAO_mod_nequal(b,c) + CAO_bool _CAO_mod_nequal(CAO_mod, CAO_mod); + + CAO_RES CAO_mod_dump(CAO_mod); + CAO_RES CAO_mod_cast_int(CAO_int, CAO_mod); + CAO_RES CAO_mod_cast_mod(CAO_mod, CAO_mod); + CAO_RES CAO_int_cast_mod(CAO_mod, CAO_int); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/backend_lib/C_generic/CAO_modpol.cpp b/backend_lib/C_generic/CAO_modpol.cpp new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_modpol.cpp @@ -0,0 +1,389 @@ +#include "CAO_modpol.h" + +CAO_RES CAO_modpol_decl(CAO_modpol * a, CAO_int degree, CAO_int p, + CAO_int par_list[]) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) malloc(sizeof(CAO_modpol_s)); + + CAO_mod m; + CAO_mod_decl(&m, p); + _CAO_mod_init(m, par_list[0]); + ((CAO_mod_s *) m)->bak->restore(); + + CAO_rint _degree = _CAO_int_cast_rint(degree); + + ZZ_pX modulus(INIT_SIZE, _degree); + + for (int j = _degree; j >= 0; j--) + { + _CAO_mod_init(m, par_list[j]); + ZZ_p c = *((CAO_mod_s *) m)->val; + SetCoeff(modulus, j, c); + } + + CAO_mod_dispose(m); + + ZZ_pE::init(modulus); + + _a->val = new ZZ_pE(); + _a->bak = new ZZ_pBak(); + _a->bakE = new ZZ_pEBak(); + + _a->bak->save(); + _a->bakE->save(); + + *a = (CAO_modpol) _a; + return CAO_OK; +} + +CAO_RES _CAO_modpol_decl(CAO_modpol * a, const int degree, CAO_mod par_list[]) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) malloc(sizeof(CAO_modpol_s)); + ((CAO_mod_s *) (par_list[0]))->bak->restore(); + + ZZ_pX modulus(INIT_SIZE, degree); + + for (int j = degree; j >= 0; j--) + { + ZZ_p c = *((CAO_mod_s *) (par_list[j]))->val; + SetCoeff(modulus, j, c); + } + + ZZ_pE::init(modulus); + + _a->val = new ZZ_pE(); + _a->bak = new ZZ_pBak(); + _a->bakE = new ZZ_pEBak(); + + _a->bak->save(); + _a->bakE->save(); + + *a = (CAO_modpol) _a; + return CAO_OK; +} + +CAO_RES CAO_modpol_init(CAO_modpol a, const char *par_list) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) a; + _a->bak->restore(); + _a->bakE->restore(); + int degree = _a->val->degree(); + + // coefficient starts + end of last + int *parameters = (int *)malloc((degree + 1) * sizeof(int)); + int i = (degree - 1), offset = 0; + + while(i >= 0) + { + parameters[i] = offset; + + while ((par_list[offset] >= '0') && (par_list[offset] <= '9')) + offset++; + + offset++; // jump to first digit of next param (may be off + // limits) + i--; + } + parameters[degree] = offset; + + char *buffer = (char *)malloc(offset * sizeof(char)); + memcpy(buffer, par_list, offset); + + istringstream ins; + ZZ_pX val(INIT_SIZE, degree); + ZZ_p c; + for (int j = 0; j < degree; j++) + { + buffer[parameters[j + 1] - 1] = '\0'; + ins.str(buffer + parameters[j]); + ins >> c; + ins.clear(); + SetCoeff(val, j, c); + } + free(parameters); + free(buffer); + *_a->val = to_ZZ_pE(val); + _a->bak->save(); + _a->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_assign(CAO_modpol a, CAO_modpol b) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) a; + CAO_modpol_s *_b = (CAO_modpol_s *) b; + _a->bak->restore(); + _a->bakE->restore(); + *_a->val = *_b->val; + _a->bak->save(); + _a->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_assign_one(CAO_modpol a) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) a; + _a->bak->restore(); + _a->bakE->restore(); + set(*_a->val); + return CAO_OK; +} + +CAO_RES CAO_modpol_assign_zero(CAO_modpol a) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) a; + _a->bak->restore(); + _a->bakE->restore(); + clear(*_a->val); + return CAO_OK; +} + +CAO_RES CAO_modpol_clone(CAO_modpol * a, CAO_modpol b) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) malloc(sizeof(CAO_modpol_s)); + CAO_modpol_s *_b = (CAO_modpol_s *) b; + _b->bak->restore(); + _b->bakE->restore(); + _a->val = new ZZ_pE(*_b->val); + _a->bak = new ZZ_pBak(); + _a->bakE = new ZZ_pEBak(); + _a->bak->save(); + _a->bakE->save(); + _b->bak->save(); + _b->bakE->save(); + *a = _a; + return CAO_OK; +} + +CAO_RES CAO_modpol_add(CAO_modpol r, CAO_modpol a, CAO_modpol b) +{ + CAO_modpol_s *_r = (CAO_modpol_s *) r; + CAO_modpol_s *_a = (CAO_modpol_s *) a; + CAO_modpol_s *_b = (CAO_modpol_s *) b; + _r->bak->restore(); + _r->bakE->restore(); + *_r->val = (*_a->val) + (*_b->val); + _r->bak->save(); + _r->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_addTo(CAO_modpol r, CAO_modpol a) +{ + CAO_modpol_s *_r = (CAO_modpol_s *) r; + CAO_modpol_s *_a = (CAO_modpol_s *) a; + _r->bak->restore(); + _r->bakE->restore(); + *_r->val += (*_a->val); + _r->bak->save(); + _r->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_sub(CAO_modpol r, CAO_modpol a, CAO_modpol b) +{ + CAO_modpol_s *_r = (CAO_modpol_s *) r; + CAO_modpol_s *_a = (CAO_modpol_s *) a; + CAO_modpol_s *_b = (CAO_modpol_s *) b; + _r->bak->restore(); + _r->bakE->restore(); + *_r->val = (*_a->val) - (*_b->val); + _r->bak->save(); + _r->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_subTo(CAO_modpol r, CAO_modpol a) +{ + CAO_modpol_s *_r = (CAO_modpol_s *) r; + CAO_modpol_s *_a = (CAO_modpol_s *) a; + _r->bak->restore(); + _r->bakE->restore(); + *_r->val -= (*_a->val); + _r->bak->save(); + _r->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_mul(CAO_modpol r, CAO_modpol a, CAO_modpol b) +{ + CAO_modpol_s *_r = (CAO_modpol_s *) r; + CAO_modpol_s *_a = (CAO_modpol_s *) a; + CAO_modpol_s *_b = (CAO_modpol_s *) b; + _r->bak->restore(); + _r->bakE->restore(); + *_r->val = (*_a->val) * (*_b->val); + _r->bak->save(); + _r->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_div(CAO_modpol r, CAO_modpol a, CAO_modpol b) +{ + CAO_modpol_s *_r = (CAO_modpol_s *) r; + CAO_modpol_s *_a = (CAO_modpol_s *) a; + CAO_modpol_s *_b = (CAO_modpol_s *) b; + _r->bak->restore(); + _r->bakE->restore(); + *_r->val = (*_a->val) / (*_b->val); + _r->bak->save(); + _r->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_pow(CAO_modpol r, CAO_modpol a, CAO_int b) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) a; + ZZ *_b = (ZZ *) b; + CAO_modpol_s *_r = (CAO_modpol_s *) r; + _r->bak->restore(); + _r->bakE->restore(); + *_r->val = power(*_a->val, *_b); + _r->bak->save(); + _r->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_sym(CAO_modpol r, CAO_modpol a) +{ + CAO_modpol_s *_r = (CAO_modpol_s *) r; + CAO_modpol_s *_a = (CAO_modpol_s *) a; + _r->bak->restore(); + _r->bakE->restore(); + *_r->val = -*_a->val; + _r->bak->save(); + _r->bakE->save(); + return CAO_OK; +} + +CAO_bool _CAO_modpol_equal(CAO_modpol a, CAO_modpol b) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) a; + CAO_modpol_s *_b = (CAO_modpol_s *) b; + _a->bak->restore(); + _a->bakE->restore(); + CAO_bool r = ((*_a->val) == (*_b->val)); + _a->bak->save(); + _a->bakE->save(); + return r; +} + +CAO_bool _CAO_modpol_nequal(CAO_modpol a, CAO_modpol b) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) a; + CAO_modpol_s *_b = (CAO_modpol_s *) b; + _a->bak->restore(); + _a->bakE->restore(); + CAO_bool r = ((*_a->val) != (*_b->val)); + _a->bak->save(); + _a->bakE->save(); + return r; +} + +CAO_RES CAO_modpol_dump(CAO_modpol a) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) a; + _a->bak->restore(); + _a->bakE->restore(); + cout << *_a->val << "\n"; + _a->bak->save(); + _a->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_dispose(CAO_modpol a) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) a; + delete(_a->val); + delete(_a->bak); + delete(_a->bakE); + free(_a); + return CAO_OK; +} + +CAO_RES CAO_mod_cast_modpol(CAO_modpol b, CAO_mod a) +{ + CAO_mod_s *_a = (CAO_mod_s *) a; + CAO_modpol_s *_b = (CAO_modpol_s *) b; + _b->bak->restore(); + _b->bakE->restore(); + *(_b->val) = *(_a->val); + _b->bak->save(); + _b->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_matrix_cast_modpol(CAO_modpol b, CAO_matrix a) +{ + CAO_matrix_s *_a = (CAO_matrix_s *) a; + CAO_modpol_s *_b = (CAO_modpol_s *) b; + _b->bak->restore(); + _b->bakE->restore(); + ZZ_p c; + int degree = _b->val->degree(); + ZZ_pX val(INIT_SIZE, degree); + for (int i = 0; i <= degree; i++) + { + c = *((ZZ_p *) _a->value[i]); + SetCoeff(val, i, c); + } + *_b->val = to_ZZ_pE(val); + _b->bak->save(); + _b->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_cast_matrix(CAO_matrix b, CAO_modpol a) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) a; + CAO_matrix_s *_b = (CAO_matrix_s *) b; + _a->bak->restore(); + _a->bakE->restore(); + ZZ_p *c; + int degree = _a->val->degree(); + for (int i = 0; i < degree; i++) + { + c = (ZZ_p *) _b->value[i]; + GetCoeff(*c, rep(*_a->val), i); + } + _a->bak->save(); + _a->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_vector_cast_modpol(CAO_modpol b, CAO_vector a) +{ + CAO_vector_s *_a = (CAO_vector_s *) a; + CAO_modpol_s *_b = (CAO_modpol_s *) b; + _b->bak->restore(); + _b->bakE->restore(); + ZZ_p c; + int degree = _b->val->degree(); + ZZ_pX val(INIT_SIZE, degree); + for (int i = 0; i < _a->size; i++) + { + c = *((ZZ_p *) _a->value[i]); + SetCoeff(val, i, c); + } + *_b->val = to_ZZ_pE(val); + _b->bak->save(); + _b->bakE->save(); + return CAO_OK; +} + +CAO_RES CAO_modpol_cast_vector(CAO_vector b, CAO_modpol a) +{ + CAO_modpol_s *_a = (CAO_modpol_s *) a; + CAO_vector_s *_b = (CAO_vector_s *) b; + _a->bak->restore(); + _a->bakE->restore(); + ZZ_p *c; + for (int i = 0; i < _b->size; i++) + { + c = (ZZ_p *) _b->value[i]; + GetCoeff(*c, rep(*_a->val), i); + } + _a->bak->save(); + _a->bakE->save(); + return CAO_OK; +} diff --git a/backend_lib/C_generic/CAO_modpol.h b/backend_lib/C_generic/CAO_modpol.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_modpol.h @@ -0,0 +1,71 @@ +#ifndef CAO_MODPOL_H +#define CAO_MODPOL_H + +#include "CAO_globals.h" + +#ifdef __cplusplus + +#include "CAO_bool.h" +#include "CAO_int.h" +#include "CAO_ubits.h" +#include "CAO_sbits.h" +#include "CAO_mod.h" +#include "CAO_modpol.h" +#include "CAO_struct.h" +#include "CAO_vector.h" +#include "CAO_matrix.h" +#include "CAO_globalOp.h" +#include "CAO_rint.h" +#include +#include +#include +#include +#include + +NTL_CLIENT + +typedef struct CAO_ModPol_s { + ZZ_pEBak *bakE; + ZZ_pBak *bak; + ZZ_pE *val; +} CAO_modpol_s; + +extern "C" { +#endif + + //TODO remove when deploy + //CAO_RES CAO_modpol_decl(CAO_modpol *, CAO_rint, CAO_int, CAO_int *); + CAO_RES CAO_modpol_decl(CAO_modpol *, CAO_int, CAO_int, CAO_int *); + CAO_RES _CAO_modpol_decl (CAO_modpol *, CAO_rint, CAO_mod *); + + CAO_RES CAO_modpol_init(CAO_modpol , const char *); + CAO_RES CAO_modpol_assign(CAO_modpol , CAO_modpol ); + CAO_RES CAO_modpol_assign_one(CAO_modpol); + CAO_RES CAO_modpol_assign_zero(CAO_modpol); + CAO_RES CAO_modpol_clone(CAO_modpol *, CAO_modpol); + CAO_RES CAO_modpol_equal(CAO_bool r, CAO_modpol , CAO_modpol); + CAO_RES CAO_modpol_add(CAO_modpol,CAO_modpol,CAO_modpol); + CAO_RES CAO_modpol_addTo(CAO_modpol,CAO_modpol); + CAO_RES CAO_modpol_subTo(CAO_modpol,CAO_modpol); + CAO_RES CAO_modpol_sub(CAO_modpol,CAO_modpol,CAO_modpol); + CAO_RES CAO_modpol_mul(CAO_modpol,CAO_modpol,CAO_modpol); + CAO_RES CAO_modpol_div(CAO_modpol,CAO_modpol,CAO_modpol); + CAO_RES CAO_modpol_pow(CAO_modpol,CAO_modpol,CAO_int); + CAO_RES CAO_modpol_sym(CAO_modpol,CAO_modpol); + #define CAO_modpol_equal(a,b,c) a = _CAO_modpol_equal(b,c) + CAO_bool _CAO_modpol_equal(CAO_modpol, CAO_modpol); + #define CAO_modpol_nequal(a,b,c) a = _CAO_modpol_nequal(b,c) + CAO_bool _CAO_modpol_nequal(CAO_modpol, CAO_modpol); + CAO_RES CAO_modpol_dump(CAO_modpol); + CAO_RES CAO_modpol_dispose(CAO_modpol); + CAO_RES CAO_mod_cast_modpol(CAO_modpol, CAO_mod); + CAO_RES CAO_matrix_cast_modpol(CAO_modpol, CAO_matrix); + CAO_RES CAO_modpol_cast_matrix(CAO_matrix, CAO_modpol); + CAO_RES CAO_vector_cast_modpol(CAO_modpol, CAO_vector); + CAO_RES CAO_modpol_cast_vector(CAO_vector, CAO_modpol); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/backend_lib/C_generic/CAO_rint.cpp b/backend_lib/C_generic/CAO_rint.cpp new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_rint.cpp @@ -0,0 +1,14 @@ +#include "CAO_rint.h" + +CAO_RES CAO_rint_cast_int(CAO_int o, CAO_rint i) +{ + ZZ *_o = (ZZ *) o; + *_o = i; + return CAO_OK; +} + +CAO_RES CAO_rint_dump(CAO_rint b) +{ + std::cout << b << "\n"; + return CAO_OK; +} diff --git a/backend_lib/C_generic/CAO_rint.h b/backend_lib/C_generic/CAO_rint.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_rint.h @@ -0,0 +1,37 @@ +#ifndef CAO_RINT_H +#define CAO_RINT_H + +#include "CAO_globals.h" + +#ifdef __cplusplus + +#include +#include + +NTL_CLIENT + +extern "C" { +#endif + + #define CAO_rint_init(a,b) a = b + #define CAO_rint_assign(a,b) a = b + #define CAO_rint_add(a,b,c) a = ((b) + (c)) + #define CAO_rint_sub(a,b,c) a = ((b) - (c)) + #define CAO_rint_sym(a,b) a = (-(b)) + #define CAO_rint_mul(a,b,c) a = ((b) * (c)) + #define CAO_rint_div(a,b,c) a = ((b) / (c)) + #define CAO_rint_mod(a,b,c) a = ((b) % (c)) + #define CAO_rint_equal(a,b,c) a = ((b) == (c)) + #define CAO_rint_nequal(a,b,c) a = ((b) != (c)) + #define CAO_rint_lt(a,b,c) a = ((b) < (c)) + #define CAO_rint_lte(a,b,c) a = ((b) <= (c)) + #define CAO_rint_gt(a,b,c) a = ((b) > (c)) + #define CAO_rint_gte(a,b,c) a = ((b) >= (c)) + CAO_RES CAO_rint_cast_int(CAO_int, CAO_rint); + CAO_RES CAO_rint_dump(CAO_rint); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/backend_lib/C_generic/CAO_sbits.cpp b/backend_lib/C_generic/CAO_sbits.cpp new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_sbits.cpp @@ -0,0 +1,330 @@ +#include "CAO_sbits.h" + +CAO_RES CAO_sbits_decl(CAO_sbits * b, const int s) +{ + CAO_sbits_s *_b = (CAO_sbits_s *) malloc(sizeof(CAO_sbits_s)); + _b->size = s; + _b->value = new ZZ; + *b = _b; + return CAO_OK; +} + +CAO_RES CAO_sbits_init(CAO_sbits b, const char *val) +{ + CAO_sbits_s *_b = (CAO_sbits_s *) b; + *(_b->value) = to_ZZ(val); + // b = _b; + return CAO_OK; +} + +CAO_RES CAO_sbits_assign(CAO_sbits r, CAO_sbits b) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_b = (CAO_sbits_s *) b; + + ZZ *zr = _r->value; + ZZ *zb = _b->value; + (*zr) = (*zb); + return CAO_OK; +} + +CAO_RES CAO_sbits_clone(CAO_sbits * b, CAO_sbits a) +{ + CAO_sbits_s *_a = (CAO_sbits_s *) a; + CAO_sbits_decl(b, _a->size); + CAO_sbits_assign(*b, a); + return CAO_OK; +} + +CAO_bool _CAO_sbits_equal(CAO_sbits i, CAO_sbits j) +{ + CAO_sbits_s *_i = (CAO_sbits_s *) i; + CAO_sbits_s *_j = (CAO_sbits_s *) j; + + ZZ *zi = _i->value; + ZZ *zj = _j->value; + CAO_bool r = ((*zi) == (*zj)); + return r; +} + +CAO_bool _CAO_sbits_nequal(CAO_sbits i, CAO_sbits j) +{ + CAO_sbits_s *_i = (CAO_sbits_s *) i; + CAO_sbits_s *_j = (CAO_sbits_s *) j; + + ZZ *zi = _i->value; + ZZ *zj = _j->value; + CAO_bool r = !((*zi) == (*zj)); + + return r; +} + +CAO_RES CAO_sbits_or(CAO_sbits r, CAO_sbits i, CAO_sbits j) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_i = (CAO_sbits_s *) i; + CAO_sbits_s *_j = (CAO_sbits_s *) j; + + ZZ *zr = _r->value; + ZZ *zi = _i->value; + ZZ *zj = _j->value; + *zr = (*zi) | (*zj); + + return CAO_OK; +} + +CAO_RES CAO_sbits_and(CAO_sbits r, CAO_sbits i, CAO_sbits j) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_i = (CAO_sbits_s *) i; + CAO_sbits_s *_j = (CAO_sbits_s *) j; + + ZZ *zr = _r->value; + ZZ *zi = _i->value; + ZZ *zj = _j->value; + *zr = (*zi) & (*zj); + + return CAO_OK; +} + +CAO_RES CAO_sbits_xor(CAO_sbits r, CAO_sbits i, CAO_sbits j) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_i = (CAO_sbits_s *) i; + CAO_sbits_s *_j = (CAO_sbits_s *) j; + + ZZ *zr = _r->value; + ZZ *zi = _i->value; + ZZ *zj = _j->value; + *zr = (*zi) ^ (*zj); + + return CAO_OK; +} + +CAO_RES CAO_sbits_not(CAO_sbits r, CAO_sbits i) +{ + long j; + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_i = (CAO_sbits_s *) i; + + ZZ *zr = _r->value; + ZZ *zi = _i->value; + *zr = *zi; + + for (j = 0; j < _i->size; j++) + { + SwitchBit(*zr, j); + } + + return CAO_OK; +} + +CAO_RES CAO_sbits_shift_up(CAO_sbits r, CAO_sbits i, CAO_rint e) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_i = (CAO_sbits_s *) i; + ZZ base; + + ZZ *zr = _r->value; + ZZ *zi = _i->value; + int si = _i->size; + power(base, 2, si); + *zr = ((*zi) << e) % base; + + return CAO_OK; +} + +CAO_RES CAO_sbits_shift_down(CAO_sbits r, CAO_sbits i, CAO_rint e) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_i = (CAO_sbits_s *) i; + ZZ base; + + ZZ *zi = _i->value; + ZZ *zr = _r->value; + *zr = (*zi) >> e; + + return CAO_OK; +} + +CAO_RES CAO_sbits_rot_up(CAO_sbits r, CAO_sbits i, CAO_rint e) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_i = (CAO_sbits_s *) i; + ZZ a, base, upper; + + ZZ *zr = _r->value; + ZZ *zi = _i->value; + int si = _i->size; + power(base, 2, si); + a = *zi << e; + upper = a / base; + a = a % base; + *zr = a + upper; + + return CAO_OK; +} + +CAO_RES CAO_sbits_rot_down(CAO_sbits r, CAO_sbits i, CAO_rint e) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_i = (CAO_sbits_s *) i; + ZZ a, base, lower; + + ZZ *zi = _i->value; + ZZ *zr = _r->value; + power(base, 2, e); + lower = *zi % base; + a = *zi / base; + lower = lower * base; + *zr = a + lower; + + return CAO_OK; +} + +CAO_RES CAO_sbits_select(CAO_sbits r, CAO_sbits b, CAO_rint e) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_b = (CAO_sbits_s *) b; + + ZZ *zb = _b->value; + ZZ *zr = _r->value; + long _bit = bit(*zb, e); + *zr = _bit; + + return CAO_OK; +} + +CAO_RES CAO_sbits_set(CAO_sbits r, CAO_sbits b, CAO_rint e) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_b = (CAO_sbits_s *) b; + + ZZ *zb = _b->value; + ZZ *zr = _r->value; + + if (bit(*zr, e) != bit(*zb, 0)) + { + SwitchBit(*zr, e); + } + + return CAO_OK; +} + +CAO_RES CAO_sbits_range_select(CAO_sbits r, CAO_sbits b, CAO_rint e, CAO_rint j) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_b = (CAO_sbits_s *) b; + ZZ a, base, lower; + + ZZ *zb = _b->value; + ZZ *zr = _r->value; + int ns = j - e + 1; + power(base, 2, ns); + a = (*zb) >> e; + lower = a % base; + *zr = lower; + + return CAO_OK; +} + +CAO_RES CAO_sbits_range_set(CAO_sbits r, CAO_sbits b, CAO_rint e, CAO_rint j) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_b = (CAO_sbits_s *) b; + ZZ a, base, lower; + + ZZ *zb = _b->value; + ZZ *zr = _r->value; + int ns = j - e + 1; + power(base, 2, e); + lower = *zr % base; + a = (*zr) >> (j + 1); + a <<= ns; + a += *zb; + a <<= e; + *zr = a + lower; + + return CAO_OK; +} + +CAO_RES CAO_sbits_concat(CAO_sbits r, CAO_sbits a, CAO_sbits b) +{ + CAO_sbits_s *_r = (CAO_sbits_s *) r; + CAO_sbits_s *_a = (CAO_sbits_s *) a; + CAO_sbits_s *_b = (CAO_sbits_s *) b; + ZZ nval, base; + + ZZ *zr = _r->value; + ZZ *za = _a->value; + ZZ *zb = _b->value; + int sa = _a->size; + power(base, 2, sa); + nval = (*zb) * base; + *zr = nval + *za; + + return CAO_OK; +} + +CAO_RES CAO_sbits_dump(CAO_sbits b) +{ + CAO_sbits_s *_b = (CAO_sbits_s *) b; + + int size = _b->size; + ZZ *val = _b->value; + cout << "sbits[" << size << "] = " << (*val) << "\n"; + + return CAO_OK; +} + +CAO_RES CAO_sbits_dispose(CAO_sbits a) +{ + CAO_sbits_s *_a = (CAO_sbits_s *) a; + delete(_a->value); + free(_a); + return CAO_OK; +} + +CAO_RES CAO_sbits_cast_int(CAO_int b, CAO_sbits a) +{ + CAO_sbits_s *_a = (CAO_sbits_s *) a; + ZZ base; + + ZZ *_b = (ZZ *) b; + power(base, 2, _a->size); + *_b = *_a->value - base; + + return CAO_OK; +} + +CAO_RES CAO_int_cast_sbits(CAO_sbits b, CAO_int a) +{ + CAO_sbits_s *_b = (CAO_sbits_s *) b; + ZZ base; + + ZZ *_a = (ZZ *) a; + power(base, 2, _b->size); + if (sign(*_a) == -1) + { + *_b->value = base + (*_a); + } + else + { + *_b->value = *_a; + } + *_b->value = (*_b->value) % base; + + return CAO_OK; +} + +CAO_RES CAO_sbits_cast_sbits(CAO_sbits b, CAO_sbits a) +{ + CAO_sbits_s *_b = (CAO_sbits_s *) b; + CAO_sbits_s *_a = (CAO_sbits_s *) a; + ZZ base; + + power(base, 2, _b->size); + *_b->value = *_a->value % base; + + return CAO_OK; +} diff --git a/backend_lib/C_generic/CAO_sbits.h b/backend_lib/C_generic/CAO_sbits.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_sbits.h @@ -0,0 +1,54 @@ +#ifndef CAO_SBITS_H +#define CAO_SBITS_H + +#include "CAO_globals.h" + +#ifdef __cplusplus + +#include +#include + +NTL_CLIENT + +typedef struct CAO_sbits_s { + int size; + ZZ *value; +} CAO_sbits_s; + +extern "C" { +#endif + + CAO_RES CAO_sbits_decl(CAO_sbits *, CAO_rint); + CAO_RES CAO_sbits_init(CAO_sbits, const char *); + CAO_RES CAO_sbits_assign(CAO_sbits, CAO_sbits); + CAO_RES CAO_sbits_clone(CAO_sbits *, CAO_sbits); + CAO_RES CAO_sbits_dispose(CAO_sbits); + + #define CAO_sbits_equal(a,b,c) a = _CAO_sbits_equal(b,c) + CAO_bool _CAO_sbits_equal(CAO_sbits, CAO_sbits); + #define CAO_sbits_nequal(a,b,c) a = _CAO_sbits_nequal(b,c) + CAO_bool _CAO_sbits_nequal(CAO_sbits, CAO_sbits); + CAO_RES CAO_ubits_not(CAO_ubits, CAO_ubits); + CAO_RES CAO_sbits_or(CAO_sbits, CAO_sbits, CAO_sbits); + CAO_RES CAO_sbits_xor(CAO_sbits, CAO_sbits, CAO_sbits); + CAO_RES CAO_sbits_and(CAO_sbits, CAO_sbits, CAO_sbits); + CAO_RES CAO_sbits_shift_up(CAO_sbits, CAO_sbits, CAO_rint); + CAO_RES CAO_sbits_shift_down(CAO_sbits, CAO_sbits, CAO_rint); + CAO_RES CAO_sbits_rot_up(CAO_sbits, CAO_sbits, CAO_rint); + CAO_RES CAO_sbits_rot_down(CAO_sbits, CAO_sbits, CAO_rint); + CAO_RES CAO_sbits_range_select(CAO_sbits, CAO_sbits, CAO_rint, CAO_rint); + CAO_RES CAO_sbits_select(CAO_sbits, CAO_sbits, CAO_rint); + CAO_RES CAO_sbits_range_set(CAO_sbits, CAO_sbits, CAO_rint, CAO_rint); + CAO_RES CAO_sbits_set(CAO_sbits, CAO_sbits, CAO_rint); + CAO_RES CAO_sbits_concat(CAO_sbits, CAO_sbits, CAO_ubits); + + CAO_RES CAO_sbits_dump(CAO_sbits); + CAO_RES CAO_sbits_cast_int(CAO_int, CAO_sbits); + CAO_RES CAO_int_cast_sbits(CAO_sbits, CAO_int); + CAO_RES CAO_sbits_cast_sbits(CAO_ubits, CAO_ubits); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/backend_lib/C_generic/CAO_struct.cpp b/backend_lib/C_generic/CAO_struct.cpp new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_struct.cpp @@ -0,0 +1,168 @@ +#include "CAO_struct.h" + +CAO_struct_s *newStruct(int size) +{ + CAO_struct_s *newS; + newS = (CAO_struct_s *) malloc(sizeof(CAO_struct_s)); + newS->size = size; + newS->types = (char *)malloc(size * sizeof(char)); + newS->fields = (CAO_REF *) malloc(size * sizeof(CAO_REF)); + return newS; +} + +CAO_RES CAO_struct_decl(CAO_struct * n, int size, const char type[], + void *indices[]) +{ + int jump; + return _CAO_struct_decl(n, size, type, indices, &jump); +} + +CAO_RES _CAO_struct_decl(CAO_struct * n, int size, const char type[], + void *indices[], int *jump) +{ + int i, offset = 0; + CAO_RES res = CAO_OK; + CAO_struct_s *_s = newStruct(size); + + for (i = 0; ((i < size) && (res == CAO_OK)); i++) + { + _s->types[i] = type[offset]; + res = + _CAO_global_decl(&(_s->fields[i]), type + offset, indices + offset, + jump); + offset += (*jump); + } + *n = _s; + *jump = offset; + + return res; +} + +CAO_RES CAO_struct_dispose(CAO_struct s) +{ + int i; + CAO_RES res = CAO_OK; + CAO_struct_s *_s = (CAO_struct_s *) s; + + for (i = 0; ((i < _s->size) && (res == CAO_OK)); i++) + res = CAO_global_dispose(_s->fields[i], _s->types[i]); + free(_s->types); + free(_s->fields); + free(_s); + return res; +} + +CAO_RES CAO_struct_const_init(CAO_struct s, void *value) +{ + int i; + CAO_struct_s *_s = (CAO_struct_s *) s; + + for (i = 0; i < _s->size; i++) + CAO_global_const_init(_s->fields[i], value, _s->types[i]); + return CAO_OK; +} + +CAO_RES CAO_struct_init(CAO_struct s, void *value[]) +{ + int jval = 0; + return _CAO_struct_init(s, value, &jval); +} + +CAO_RES _CAO_struct_init(CAO_struct s, void *value[], int *jval) +{ + // jval é parâmetro de saída + int i, offValue = 0; + CAO_struct_s *_s = (CAO_struct_s *) s; + + for (i = 0; i < _s->size; i++) + { + _CAO_global_init(_s->fields[i], value + offValue, jval, _s->types[i]); + offValue += *jval; + } + *jval = offValue; + return CAO_OK; +} + +CAO_RES CAO_struct_assign(CAO_struct r, CAO_struct s) +{ + + CAO_struct_s *_r = (CAO_struct_s *) r; + CAO_struct_s *_s = (CAO_struct_s *) s; + + int i; + + for (i = 0; i < _r->size; i++) + { + CAO_global_assign(_r->fields[i], _s->fields[i], _r->types[i]); + } + return CAO_OK; +} + +CAO_RES CAO_struct_clone(CAO_struct * r, CAO_struct s) +{ + + CAO_struct_s *_s = (CAO_struct_s *) s; + CAO_struct_s *_r = newStruct(_s->size); + + int i; + + for (i = 0; (i < _s->size); i++) + { + _r->types[i] = _s->types[i]; + CAO_global_clone(&(_r->fields[i]), _s->fields[i], _s->types[i]); + } + *r = _r; + return CAO_OK; +} + +CAO_bool _CAO_struct_equal(CAO_struct si, CAO_struct sj) +{ + CAO_struct_s *_si = (CAO_struct_s *) si; + CAO_struct_s *_sj = (CAO_struct_s *) sj; + + int i = 0, size = _si->size; + CAO_bool r = true; + while (r && (i < size)) + { + r = _CAO_global_equal(_si->fields[i], _sj->fields[i], _si->types[i]); + i++; + } + return r; +} + +CAO_RES CAO_struct_select(CAO_REF r, CAO_struct s, CAO_rint i) +{ + CAO_struct_s *_s = (CAO_struct_s *) s; + + CAO_global_assign(r, _s->fields[i], _s->types[i]); + return CAO_OK; +} + +CAO_REF CAO_struct_ref(CAO_struct s, CAO_rint i) +{ + char type; + return _CAO_struct_ref(s, i, &type); +} + +CAO_REF _CAO_struct_ref(CAO_struct s, CAO_rint i, char *t) +{ + CAO_struct_s *_s = (CAO_struct_s *) s; + *t = _s->types[i]; + return (_s->fields[i]); +} + +CAO_RES CAO_struct_dump(CAO_struct s) +{ + CAO_struct_s *_s = (CAO_struct_s *) s; + + int f = (_s->size), i; + + std::cout << "struct with" << f << "fields \n"; + for (i = 0; (i < f); i++) + { + CAO_global_dump(_s->fields[i], _s->types[i]); + std::cout << "\n"; + } + std::cout << "end of struct with" << f << "fields \n"; + return CAO_OK; +} diff --git a/backend_lib/C_generic/CAO_struct.h b/backend_lib/C_generic/CAO_struct.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_struct.h @@ -0,0 +1,46 @@ +#ifndef CAO_STRUCT_H +#define CAO_STRUCT_H + +#include "CAO_globals.h" + +#ifdef __cplusplus + +#include "CAO_globalOp.h" +#include +#include + +typedef struct CAO_struct_s { + int size; + char *types; + CAO_REF *fields; +} CAO_struct_s ; + +extern "C" { +#endif + + CAO_RES CAO_struct_decl(CAO_struct *, CAO_rint, const char *, void **); + CAO_RES _CAO_struct_decl(CAO_struct *, CAO_rint, const char *, void **, int *); + + CAO_RES CAO_struct_const_init(CAO_struct, void *); + + CAO_RES CAO_struct_init(CAO_struct, void **); + CAO_RES _CAO_struct_init(CAO_struct, void **, int *); + + CAO_RES CAO_struct_assign(CAO_struct, CAO_struct); + CAO_RES CAO_struct_clone(CAO_struct *, CAO_struct); + CAO_RES CAO_struct_dispose(CAO_struct); + + #define CAO_struct_equal(a,b,c) a = _CAO_struct_equal(b,c) + CAO_bool _CAO_struct_equal(CAO_struct, CAO_struct); + CAO_RES CAO_struct_select(CAO_REF, CAO_struct, CAO_rint); + + CAO_REF CAO_struct_ref(CAO_struct, CAO_rint); + CAO_REF _CAO_struct_ref(CAO_struct, CAO_rint, char *); + + CAO_RES CAO_struct_dump(CAO_struct); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/backend_lib/C_generic/CAO_ubits.cpp b/backend_lib/C_generic/CAO_ubits.cpp new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_ubits.cpp @@ -0,0 +1,325 @@ +#include "CAO_ubits.h" + +CAO_RES CAO_ubits_decl(CAO_ubits * b, const int s) +{ + CAO_ubits_s *_b = (CAO_ubits_s *) malloc(sizeof(CAO_ubits_s)); + _b->size = s; + _b->value = new ZZ; + *b = _b; + return CAO_OK; +} + +CAO_RES CAO_ubits_init(CAO_ubits b, const char *val) +{ + CAO_ubits_s *_b = (CAO_ubits_s *) b; + *(_b->value) = to_ZZ(val); + // b = _b; + return CAO_OK; +} + +CAO_RES CAO_ubits_assign(CAO_ubits r, CAO_ubits b) +{ + CAO_ubits_s *_b = (CAO_ubits_s *) b; + CAO_ubits_s *_r = (CAO_ubits_s *) r; + ZZ *zr = _r->value; + ZZ *zb = _b->value; + *zr = (*zb); + return CAO_OK; +} + +CAO_RES CAO_ubits_clone(CAO_ubits * b, CAO_ubits a) +{ + CAO_ubits_s *_a = (CAO_ubits_s *) a; + CAO_ubits_decl(b, _a->size); + CAO_ubits_assign(*b, a); + return CAO_OK; +} + +CAO_bool _CAO_ubits_equal(CAO_ubits i, CAO_ubits j) +{ + CAO_ubits_s *_i = (CAO_ubits_s *) i; + CAO_ubits_s *_j = (CAO_ubits_s *) j; + ZZ *zi = _i->value; + ZZ *zj = _j->value; + CAO_bool r = ((*zi) == (*zj)); + return r; +} + +CAO_bool _CAO_ubits_nequal(CAO_ubits i, CAO_ubits j) +{ + CAO_ubits_s *_i = (CAO_ubits_s *) i; + CAO_ubits_s *_j = (CAO_ubits_s *) j; + ZZ *zi = _i->value; + ZZ *zj = _j->value; + CAO_bool r = !((*zi) == (*zj)); // != + return r; +} + +CAO_RES CAO_ubits_or(CAO_ubits r, CAO_ubits i, CAO_ubits j) +{ + CAO_ubits_s *_r = (CAO_ubits_s *) r; + CAO_ubits_s *_i = (CAO_ubits_s *) i; + CAO_ubits_s *_j = (CAO_ubits_s *) j; + ZZ *zr = _r->value; + ZZ *zi = _i->value; + ZZ *zj = _j->value; + *zr = (*zi) | (*zj); + return CAO_OK; +} + +CAO_RES CAO_ubits_and(CAO_ubits r, CAO_ubits i, CAO_ubits j) +{ + CAO_ubits_s *_i = (CAO_ubits_s *) i; + CAO_ubits_s *_j = (CAO_ubits_s *) j; + CAO_ubits_s *_r = (CAO_ubits_s *) r; + ZZ *zi = _i->value; + ZZ *zj = _j->value; + ZZ *zr = _r->value; + *zr = (*zi) & (*zj); + return CAO_OK; +} + +CAO_RES CAO_ubits_xor(CAO_ubits r, CAO_ubits i, CAO_ubits j) +{ + CAO_ubits_s *_i = (CAO_ubits_s *) i; + CAO_ubits_s *_j = (CAO_ubits_s *) j; + CAO_ubits_s *_r = (CAO_ubits_s *) r; + ZZ *zi = _i->value; + ZZ *zj = _j->value; + ZZ *zr = _r->value; + *zr = (*zi) ^ (*zj); + return CAO_OK; +} + +CAO_RES CAO_ubits_not(CAO_ubits r, CAO_ubits i) +{ + long j; + CAO_ubits_s *_i = (CAO_ubits_s *) i; + CAO_ubits_s *_r = (CAO_ubits_s *) r; + ZZ *zi = _i->value; + ZZ *zr = _r->value; + *zr = *zi; + for (j = 0; j < _i->size; j++) + { + SwitchBit(*zr, j); + } + return CAO_OK; +} + +CAO_RES CAO_ubits_shift_up(CAO_ubits r, CAO_ubits i, CAO_rint e) +{ + CAO_ubits_s *_i = (CAO_ubits_s *) i; + CAO_ubits_s *_r = (CAO_ubits_s *) r; + ZZ base; + ZZ *zi = _i->value; + ZZ *zr = _r->value; + int si = _i->size; + power(base, 2, si); + *zr = ((*zi) << e) % base; + return CAO_OK; +} + +CAO_RES CAO_ubits_shift_down(CAO_ubits r, CAO_ubits i, CAO_rint e) +{ + CAO_ubits_s *_i = (CAO_ubits_s *) i; + CAO_ubits_s *_r = (CAO_ubits_s *) r; + ZZ base; + ZZ *zi = _i->value; + ZZ *zr = _r->value; + *zr = (*zi) >> e; + return CAO_OK; +} + +CAO_RES CAO_ubits_rot_up(CAO_ubits r, CAO_ubits i, CAO_rint e) +{ + CAO_ubits_s *_i = (CAO_ubits_s *) i; + CAO_ubits_s *_r = (CAO_ubits_s *) r; + ZZ a, base, upper; + + ZZ *zi = _i->value; + ZZ *zr = _r->value; + int si = _i->size; + + power(base, 2, si); + a = *zi << e; + upper = a / base; + a = a % base; + *zr = a + upper; + return CAO_OK; +} + +CAO_RES CAO_ubits_rot_down(CAO_ubits r, CAO_ubits i, CAO_rint e) +{ + CAO_ubits_s *_i = (CAO_ubits_s *) i; + CAO_ubits_s *_r = (CAO_ubits_s *) r; + ZZ a, base, lower; + + ZZ *zi = _i->value; + ZZ *zr = _r->value; + int si = _i->size; + + power(base, 2, e); + lower = *zi % base; + a = *zi >> e; + lower = lower << (si - e); + *zr = a + lower; + return CAO_OK; +} + +CAO_RES CAO_ubits_select(CAO_ubits r, CAO_ubits b, CAO_rint e) +{ + CAO_ubits_s *_b = (CAO_ubits_s *) b; + CAO_ubits_s *_r = (CAO_ubits_s *) r; + + ZZ *zb = _b->value; + ZZ *zr = _r->value; + long _bit = bit(*zb, e); + *zr = _bit; + return CAO_OK; +} + +CAO_RES CAO_ubits_set(CAO_ubits r, CAO_ubits b, CAO_rint e) +{ + CAO_ubits_s *_r = (CAO_ubits_s *) r; + CAO_ubits_s *_b = (CAO_ubits_s *) b; + + ZZ *zr = _r->value; + ZZ *zb = _b->value; + + if (bit(*zr, e) != bit(*zb, 0)) + { + SwitchBit(*zr, e); + } + + return CAO_OK; +} + +CAO_RES CAO_ubits_range_select(CAO_ubits r, CAO_ubits b, CAO_rint e, CAO_rint j) +{ + CAO_ubits_s *_r = (CAO_ubits_s *) r; + CAO_ubits_s *_b = (CAO_ubits_s *) b; + ZZ a, base, lower; + + ZZ *zb = _b->value; + ZZ *zr = _r->value; + int ns = j - e + 1; + + power(base, 2, ns); + a = (*zb) >> e; + lower = a % base; + *zr = lower; + return CAO_OK; +} + +CAO_RES CAO_ubits_range_set(CAO_ubits r, CAO_ubits b, CAO_rint e, CAO_rint j) +{ + CAO_ubits_s *_r = (CAO_ubits_s *) r; + CAO_ubits_s *_b = (CAO_ubits_s *) b; + ZZ a, base, lower; + + ZZ *zb = _b->value; + ZZ *zr = _r->value; + int ns = j - e + 1; + + power(base, 2, e); + lower = *zr % base; + a = (*zr) >> (j + 1); + a <<= ns; + a += *zb; + a <<= e; + *zr = a + lower; + return CAO_OK; +} + +CAO_RES CAO_ubits_concat(CAO_ubits r, CAO_ubits a, CAO_ubits b) +{ + CAO_ubits_s *_r = (CAO_ubits_s *) r; + CAO_ubits_s *_a = (CAO_ubits_s *) a; + CAO_ubits_s *_b = (CAO_ubits_s *) b; + ZZ nval, base; + + ZZ *zr = _r->value; + ZZ *za = _a->value; + ZZ *zb = _b->value; + int sa = _a->size; + + power(base, 2, sa); + nval = (*zb) * base; + *zr = nval + *za; + + return CAO_OK; +} + +CAO_RES CAO_ubits_dump(CAO_ubits b) +{ + CAO_ubits_s *_b = (CAO_ubits_s *) b; + int size = (_b->size); + ZZ *val = _b->value; + cout << "bits[" << size << "] = " << *val << "\n"; + return CAO_OK; +} + +CAO_RES CAO_ubits_dispose(CAO_ubits a) +{ + CAO_ubits_s *_a = (CAO_ubits_s *) a; + delete(_a->value); + free(_a); + return CAO_OK; +} + +CAO_RES CAO_ubits_cast_int(CAO_int b, CAO_ubits a) +{ + CAO_ubits_s *_a = (CAO_ubits_s *) a; + ZZ *_b = (ZZ *) b; + *_b = *_a->value; + return CAO_OK; +} + +CAO_RES CAO_int_cast_ubits(CAO_ubits b, CAO_int a) +{ + CAO_ubits_s *_b = (CAO_ubits_s *) b; + ZZ *_a = (ZZ *) a; + ZZ base; + + power(base, 2, _b->size); + if (sign(*_a) == -1) + { + *_b->value = base + (*_a); + } + else + { + *_b->value = *_a; + } + *_b->value = (*_b->value) % base; + return CAO_OK; +} + +CAO_RES CAO_ubits_cast_mod(CAO_mod b, CAO_ubits a) +{ + CAO_int aux; + CAO_int_decl(&aux); + CAO_ubits_cast_int(aux, a); + CAO_int_cast_mod(b, aux); + CAO_int_dispose(aux); + return CAO_OK; +} + +CAO_RES CAO_mod_cast_ubits(CAO_ubits b, CAO_mod a) +{ + CAO_int aux; + CAO_int_decl(&aux); + CAO_mod_cast_int(aux, a); + CAO_int_cast_ubits(b, aux); + CAO_int_dispose(aux); + return CAO_OK; +} + +CAO_RES CAO_ubits_cast_ubits(CAO_ubits b, CAO_ubits a) +{ + CAO_ubits_s *_b = (CAO_ubits_s *) b; + CAO_ubits_s *_a = (CAO_ubits_s *) a; + ZZ base; + power(base, 2, _b->size); + *_b->value = (*_a->value) % base; + return CAO_OK; +} diff --git a/backend_lib/C_generic/CAO_ubits.h b/backend_lib/C_generic/CAO_ubits.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_ubits.h @@ -0,0 +1,60 @@ +#ifndef CAO_UBITS_H +#define CAO_UBITS_H + +#include "CAO_globals.h" +#include "CAO_bool.h" +#include "CAO_int.h" +#include "CAO_mod.h" + +#ifdef __cplusplus + +#include +#include + +NTL_CLIENT + +typedef struct CAO_ubits_s { + int size; + ZZ *value; +} CAO_ubits_s; + +extern "C" { +#endif + + CAO_RES CAO_ubits_decl(CAO_ubits*, CAO_rint); + CAO_RES CAO_ubits_init(CAO_ubits, const char *); + CAO_RES CAO_ubits_assign(CAO_ubits ,CAO_ubits); + CAO_RES CAO_ubits_clone(CAO_ubits *, CAO_ubits); + CAO_RES CAO_ubits_dispose(CAO_ubits); + + #define CAO_ubits_equal(a,b,c) a = _CAO_ubits_equal(b,c) + CAO_bool _CAO_ubits_equal(CAO_ubits, CAO_ubits); + #define CAO_ubits_nequal(a,b,c) a = _CAO_ubits_nequal(b,c) + CAO_bool _CAO_ubits_nequal(CAO_ubits, CAO_ubits); + + CAO_RES CAO_ubits_not(CAO_ubits, CAO_ubits); + CAO_RES CAO_ubits_or(CAO_ubits, CAO_ubits, CAO_ubits); + CAO_RES CAO_ubits_xor(CAO_ubits, CAO_ubits, CAO_ubits); + CAO_RES CAO_ubits_and(CAO_ubits, CAO_ubits, CAO_ubits); + CAO_RES CAO_ubits_shift_up(CAO_ubits, CAO_ubits, CAO_rint); + CAO_RES CAO_ubits_shift_down(CAO_ubits, CAO_ubits, CAO_rint); + CAO_RES CAO_ubits_rot_up(CAO_ubits, CAO_ubits, CAO_rint); + CAO_RES CAO_ubits_rot_down(CAO_ubits, CAO_ubits, CAO_rint); + CAO_RES CAO_ubits_range_select(CAO_ubits, CAO_ubits, CAO_rint, CAO_rint); + CAO_RES CAO_ubits_select(CAO_ubits, CAO_ubits, CAO_rint); + CAO_RES CAO_ubits_range_set(CAO_ubits, CAO_ubits, CAO_rint, CAO_rint); + CAO_RES CAO_ubits_set(CAO_ubits, CAO_ubits, CAO_rint); + CAO_RES CAO_ubits_concat(CAO_ubits, CAO_ubits, CAO_ubits); + CAO_RES CAO_ubits_dump(CAO_ubits); + + CAO_RES CAO_ubits_cast_int(CAO_int, CAO_ubits); + CAO_RES CAO_int_cast_ubits(CAO_ubits, CAO_int); + CAO_RES CAO_ubits_cast_mod(CAO_int, CAO_ubits); + CAO_RES CAO_mod_cast_ubits(CAO_ubits, CAO_int); + CAO_RES CAO_ubits_cast_ubits(CAO_ubits, CAO_ubits); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/backend_lib/C_generic/CAO_vector.cpp b/backend_lib/C_generic/CAO_vector.cpp new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_vector.cpp @@ -0,0 +1,293 @@ +#include "CAO_vector.h" + +CAO_vector_s *newVector(int size, char type) +{ + CAO_vector_s *newV = (CAO_vector_s *) malloc(sizeof(CAO_vector_s)); + + newV->size = size; + newV->type = type; + newV->value = (CAO_REF *) malloc(size * sizeof(CAO_REF)); + + return newV; +} + +CAO_RES CAO_vector_decl(CAO_vector * n, int size, const char type[], + void *indices[]) +{ + int jump; + return _CAO_vector_decl(n, size, type, indices, &jump); +} + +CAO_RES _CAO_vector_decl(CAO_vector * n, int size, const char type[], + void *indices[], int *jump) +{ + + int i; + CAO_RES res = CAO_OK; + CAO_vector_s *_v = newVector(size, type[0]); + + for (i = 0; ((i < size) && (res == CAO_OK)); i++) + res = _CAO_global_decl(&(_v->value[i]), type, indices, jump); + + *n = _v; + + return res; +} + +CAO_RES CAO_vector_dispose(CAO_vector v) +{ + int i; + CAO_RES res = CAO_OK; + CAO_vector_s *_v = (CAO_vector_s *) v; + + for (i = 0; ((i < _v->size) && (res == CAO_OK)); i++) + res = CAO_global_dispose(_v->value[i], _v->type); + + free(_v->value); + free(_v); + + return res; +} + +CAO_RES CAO_vector_const_init(CAO_vector v, void *value) +{ + int i; + CAO_vector_s *_v = (CAO_vector_s *) v; + + for (i = 0; (i < _v->size); i++) + CAO_global_const_init(_v->value[i], value, _v->type); + + return CAO_OK; +} + +CAO_RES CAO_vector_init(CAO_vector v, void *value[]) +{ + int jval = 0; + return _CAO_vector_init(v, value, &jval); +} + +CAO_RES _CAO_vector_init(CAO_vector v, void *value[], int *jval) +{ + // jval é parâmetro de output + int i, offset = 0; + CAO_vector_s *_v = (CAO_vector_s *) v; + + for (i = 0; (i < _v->size); i++) + { + _CAO_global_init(_v->value[i], value + offset, jval, _v->type); + offset += *jval; + } + *jval = offset; + return CAO_OK; +} + +CAO_RES CAO_vector_assign(CAO_vector r, CAO_vector v) +{ + + CAO_vector_s *_r = (CAO_vector_s *) r; + CAO_vector_s *_v = (CAO_vector_s *) v; + + int i, s; + + if ((_r->size == _v->size) && (_r->type == _v->type)) + for (s = _r->size, i = 0; (i < s); i++) + CAO_global_assign(_r->value[i], _v->value[i], _r->type); + else + return CAO_ERR; + + return CAO_OK; +} + +CAO_RES CAO_vector_clone(CAO_vector * r, CAO_vector v) +{ + CAO_vector_s *_v = (CAO_vector_s *) v; + CAO_vector_s *_r = newVector(_v->size, _v->type); + + int i; + for (i = 0; i < _v->size; i++) + CAO_global_clone(&(_r->value[i]), _v->value[i], _v->type); + *r = _r; + return CAO_OK; +} + +CAO_bool _CAO_vector_equal(CAO_vector vi, CAO_vector vj) +{ + CAO_vector_s *_i = (CAO_vector_s *) vi; + CAO_vector_s *_j = (CAO_vector_s *) vj; + + int i = 0, s = _i->size; + CAO_bool r = true; + while (r && (i < s)) + { + r = _CAO_global_equal(_i->value[i], _j->value[i], _i->type); + i++; + } + + return r; +} + +CAO_RES CAO_vector_rot_up(CAO_vector r, CAO_vector v, CAO_rint n) +{ + // o que é suposto acontecer se r == v? + CAO_vector_s *_r = (CAO_vector_s *) r; + CAO_vector_s *_v = (CAO_vector_s *) v; + int i, j, s = _r->size; + + i = 0; + j = n; + while (i < s) + { + j = j % s; + CAO_global_assign(_r->value[j++], _v->value[i++], _r->type); + } + return CAO_OK; +} + +CAO_RES CAO_vector_rot_down(CAO_vector r, CAO_vector v, CAO_rint n) +{ + CAO_vector_s *_r = (CAO_vector_s *) r; + CAO_vector_s *_v = (CAO_vector_s *) v; + int i, j, s = _r->size; + + i = 0; + j = n; + while (i < s) + { + j = j % s; + CAO_global_assign(_r->value[i++], _v->value[j++], _r->type); + } + return CAO_OK; +} + +CAO_RES CAO_vector_select(CAO_REF r, CAO_vector v, CAO_rint i) +{ + CAO_vector_s *_v = (CAO_vector_s *) v; + + if ((i < _v->size) && (i >= 0)) + { + CAO_global_assign(r, _v->value[i], _v->type); + } + else + return CAO_ERR; + return CAO_OK; +} + +CAO_REF CAO_vector_ref(CAO_vector v, CAO_rint i) +{ + char type; + return _CAO_vector_ref(v, i, &type); +} + +CAO_REF _CAO_vector_ref(CAO_vector v, CAO_rint i, char *t) +{ + CAO_vector_s *_v = (CAO_vector_s *) v; + if ((i < _v->size) && (i >= 0)) + { + *t = _v->type; + } + else + { + return NULL; + } + return (_v->value[i]); +} + +CAO_RES CAO_vector_range_select(CAO_vector r, CAO_vector v, CAO_rint i, + CAO_rint j) +{ + CAO_vector_s *_r = (CAO_vector_s *) r; + CAO_vector_s *_v = (CAO_vector_s *) v; + int k, size; + + size = j - i + 1; + k = 0; + while (k < size) + CAO_global_assign(_r->value[k++], _v->value[i++], _r->type); + return CAO_OK; +} + +CAO_RES CAO_vector_range_set(CAO_vector r, CAO_vector v, CAO_rint i, CAO_rint j) +{ + CAO_vector_s *_r = (CAO_vector_s *) r; + CAO_vector_s *_v = (CAO_vector_s *) v; + int k, size; + + size = j - i + 1; + k = 0; + while (k < size) + CAO_global_assign(_r->value[i++], _v->value[k++], _r->type); + return CAO_OK; +} + +CAO_RES CAO_vector_concat(CAO_vector r, CAO_vector a, CAO_vector b) +{ + CAO_vector_s *_r = (CAO_vector_s *) r; + CAO_vector_s *_a = (CAO_vector_s *) a; + CAO_vector_s *_b = (CAO_vector_s *) b; + + int _sa = _a->size; + int _sb = _b->size; + + int i, j; + + i = 0; + j = 0; + while (i < _sa) + CAO_global_assign(_r->value[j++], _a->value[i++], _r->type); + i = 0; + while (i < _sb) + CAO_global_assign(_r->value[j++], _b->value[i++], _r->type); + return CAO_OK; +} + +CAO_RES CAO_vector_dump(CAO_vector v) +{ + CAO_vector_s *_v = (CAO_vector_s *) v; + + int s = (_v->size), i; + + std::cout << "vector[" << s << "] = \n"; + for (i = 0; (i < s); i++) + { + CAO_global_dump(_v->value[i], _v->type); + std::cout << " , "; + } + std::cout << "\n end of vector[" << s << "] = \n"; + return CAO_OK; +} + +CAO_RES CAO_vector_cast_vector(CAO_vector d, CAO_vector s) +{ + CAO_vector_s *_s = (CAO_vector_s *) d, *_d = (CAO_vector_s *) d; + int i; + CAO_RES res = CAO_OK; + + for (i = 0; ((res == CAO_OK) && (i < _s->size)); i++) + res = CAO_global_cast(_d->value[i], _d->type, _s->value[i], _s->type); + + return res; +} + +CAO_RES CAO_vector_cast_matrix(CAO_matrix m, CAO_vector v) +{ + CAO_vector_s *_v = (CAO_vector_s *) v; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int i; + CAO_RES res = CAO_OK; + + for (i = 0; ((res == CAO_OK) && (i < _v->size)); i++) + res = CAO_global_cast(_m->value[i], _m->type, _v->value[i], _v->type); + return res; +} + +CAO_RES CAO_matrix_cast_vector(CAO_vector v, CAO_matrix m) +{ + CAO_vector_s *_v = (CAO_vector_s *) v; + CAO_matrix_s *_m = (CAO_matrix_s *) m; + int i; + CAO_RES res = CAO_OK; + for (i = 0; ((res == CAO_OK) && (i < _v->size)); i++) + res = CAO_global_cast(_v->value[i], _v->type, _m->value[i], _m->type); + + return res; +} diff --git a/backend_lib/C_generic/CAO_vector.h b/backend_lib/C_generic/CAO_vector.h new file mode 100644 --- /dev/null +++ b/backend_lib/C_generic/CAO_vector.h @@ -0,0 +1,54 @@ +#ifndef CAO_VECTOR_H +#define CAO_VECTOR_H + +#include "CAO_globals.h" + +#ifdef __cplusplus + +#include "CAO_matrix.h" + +#include + +typedef struct CAO_Vector_s { + int size; + char type; + CAO_REF *value; +} CAO_vector_s ; + +extern "C" { +#endif + + CAO_RES CAO_vector_decl (CAO_vector*, CAO_rint, const char *, void **); + CAO_RES _CAO_vector_decl (CAO_vector*, CAO_rint, const char *, void **, int *); + + CAO_RES CAO_vector_dispose (CAO_vector); + CAO_RES CAO_vector_const_init (CAO_vector, void *); + + CAO_RES CAO_vector_init (CAO_vector, void **); + CAO_RES _CAO_vector_init (CAO_vector, void **, int *); + + + CAO_RES CAO_vector_assign (CAO_vector, CAO_vector); + CAO_RES CAO_vector_clone (CAO_vector *, CAO_vector); + + CAO_REF CAO_vector_ref (CAO_vector, CAO_rint); + CAO_REF _CAO_vector_ref (CAO_vector, CAO_rint, char *); + + CAO_RES CAO_vector_dump (CAO_vector); + #define CAO_vector_equal(a,b,c,d) a = _CAO_vector_equal(b,c) + CAO_bool _CAO_vector_equal (CAO_vector, CAO_vector); + CAO_RES CAO_vector_rot_up (CAO_vector ,CAO_vector, CAO_rint); + CAO_RES CAO_vector_rot_down (CAO_vector ,CAO_vector, CAO_rint); + CAO_RES CAO_vector_range_select(CAO_vector ,CAO_vector, CAO_rint, CAO_rint); + CAO_RES CAO_vector_range_set (CAO_vector ,CAO_vector, CAO_rint, CAO_rint); + CAO_RES CAO_vector_select (CAO_REF,CAO_vector, CAO_rint); + CAO_RES CAO_vector_concat (CAO_vector, CAO_vector, CAO_vector); + CAO_RES CAO_vector_cast_vector (CAO_vector, CAO_vector); + CAO_RES CAO_vector_cast_matrix (CAO_matrix, CAO_vector); + CAO_RES CAO_matrix_cast_vector (CAO_vector, CAO_matrix); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/cao.cabal b/cao.cabal new file mode 100644 --- /dev/null +++ b/cao.cabal @@ -0,0 +1,99 @@ +Name: cao +Version: 0.1 +Description: CAO Compiler +License: GPL +License-file: LICENSE +Author: SMART Team / HASLab - University of Minho +Maintainer: Paulo Silva +Bug-reports: maito:paufil@di.uminho.pt +Stability: experimental +Homepage: http://haslab.uminho.pt/mbb/software/cao-domain-specific-language-cryptography +Category: Compiler, Cryptography, Language +Build-Type: Simple +Cabal-Version: >=1.6 +Tested-with: GHC==7.6.3 +Synopsis: CAO Compiler +Data-dir: backend_lib +Data-files: C_generic/*.h + C_generic/*.cpp + +Extra-Source-Files: README.txt default.plat example/Makefile example/main_sha1.c example/sha1.cao + +Executable cao + Main-is: Main/Main.hs + Other-Modules: + Main.Compiler + Main.Dot + Main.Flags + Language.CAO.Analysis.CFG + Language.CAO.Analysis.Dominance + Language.CAO.Analysis.PhiInsert + Language.CAO.Analysis.SSA + Language.CAO.Analysis.SsaBack + Language.CAO.Common.Error + Language.CAO.Common.Fresh + Language.CAO.Common.Literal + Language.CAO.Common.Monad + Language.CAO.Common.Name + Language.CAO.Common.Operator + Language.CAO.Common.Outputable + Language.CAO.Common.Polynomial + Language.CAO.Common.Representation + Language.CAO.Common.SrcLoc + Language.CAO.Common.State + Language.CAO.Common.Utils + Language.CAO.Common.Var + Language.CAO.Index + Language.CAO.Index.Eval + Language.CAO.Index.Utils + Language.CAO.Parser.Config + Language.CAO.Parser.Lexer + Language.CAO.Parser.Parser + Language.CAO.Parser.Tokens + Language.CAO.Platform.Literals + Language.CAO.Platform.Naming + Language.CAO.Platform.Query + Language.CAO.Platform.Specification + Language.CAO.Semantics.Bits + Language.CAO.Semantics.Bool + Language.CAO.Semantics.Casts + Language.CAO.Semantics.Integer + Language.CAO.Syntax + Language.CAO.Syntax.Codes + Language.CAO.Syntax.Tidy + Language.CAO.Syntax.Utils + Language.CAO.Transformation.Eval + Language.CAO.Transformation.Expand + Language.CAO.Transformation.Indist + Language.CAO.Transformation.Simplify + Language.CAO.Transformation.Target + Language.CAO.Translation.C + Language.CAO.Translation.C.Wrappers + Language.CAO.Translation.Names + Language.CAO.Translation.PreC + Language.CAO.Translation.Yices + Language.CAO.Type + Language.CAO.Type.Utils + Language.CAO.Typechecker + Language.CAO.Typechecker.Check + Language.CAO.Typechecker.Constraint + Language.CAO.Typechecker.Expr + Language.CAO.Typechecker.Heap + Language.CAO.Typechecker.Index + Language.CAO.Typechecker.PostProcessor + Language.CAO.Typechecker.SMT + Language.CAO.Typechecker.Solver + Language.CAO.Typechecker.Unification + + Hs-source-dirs: src + Build-Depends: base >= 4 && < 5, cmdargs, pretty, containers, mtl, + ConfigFile, language-c, array, process, directory, yices, dlist, filepath + ghc-prof-options: -prof -fprof-auto -fprof-cafs -fforce-recomp + if impl(ghc < 7.4.1) + -- -fno-spec-constr-count is set because of this: http://hackage.haskell.org/trac/ghc/ticket/4288 + Ghc-Options: -fno-spec-constr-count -Wall + else + Ghc-Options: -rtsopts -Wall + + Build-Tools: alex==3.0.5, happy + diff --git a/default.plat b/default.plat new file mode 100644 --- /dev/null +++ b/default.plat @@ -0,0 +1,133 @@ +[DEFAULT] + +initproc: init +disposeproc: dispose + +typeprefix: CAO +callprefix: CAO + +header: CAO_globals.h +fields: inlined +safety: unsafe +word: 32 + +[rint] +type: rint +header: CAO_rint.h +code: I +declaration: var +memory: auto +return: ref +opcall: macro +operands: mixed +size: 1 +operations: decl(macro, safe), init(macro, safe), add(macro, safe), sub(macro, safe), mul(macro, safe), div(macro, safe), assign(macro, safe), lte(macro, safe), lt(macro, safe), gte(macro, safe), cast, equal(macro, safe) + +[int] +type: int +header: CAO_int.h +code: A +declaration: var +memory: alloc +return: ref +opcall: func +operands: vars_global +size: undefined +operations: init, decl, dispose, assign, add, sub, mul, div, pow, sym, mod, equal(macro), nequal(macro), lte(macro), lt(macro), gte(macro), gt(macro), cast(macro) + +[bool] +type: bool +header: CAO_bool.h +code: B +declaration: var +memory: auto +return: val +opcall: macro +operands: mixed +size: undefined +operations: init(macro, safe), decl(macro, safe), dispose(macro, safe), assign(macro, safe), equal(macro, safe), nequal(macro, safe), or(macro, safe), and(macro, safe), xor(macro, safe), not(macro, safe) + +[ubits] +type: ubits +header: CAO_ubits.h +code: D +declaration: var +memory: alloc +return: ref +opcall: func +operands: vars_global +size: undefined +operations: init, decl, dispose, assign, equal(macro), nequal(macro), or, and, xor, not, shift_up, shift_down, rot_up, rot_down, range_select(safe), select(safe), range_set, set, concat, cast + +[sbits] +type: sbits +header: CAO_sbits.h +code: J +declaration: var +memory: alloc +return: ref +opcall: func +operands: vars_global +size: undefined +operations: init, decl, dispose, assign, equal(macro), nequal(macro), or, and, xor, not, shift_up, shift_down, rot_up, rot_down, range_select(safe), select(safe), range_set, set, concat, cast + +[mod] +type: mod +header: CAO_mod.h +code: C +declaration: var +memory: alloc +return: ref +opcall: func +operands: vars_global +size: undefined +operations: init, decl, dispose, assign, add, sub, mul, div, pow, sym, equal(macro), nequal(macro), cast + +[vector] +type: vector +header: CAO_vector.h +code: E +declaration: var +memory: alloc +return: ref +opcall: func +operands: vars_global +size: undefined +operations: init, decl(vars_global), dispose, assign, ref(safe, func(val)), equal(macro), rot_up, rot_down, range_select(safe), range_set, select(safe), concat, cast + +[matrix] +type: matrix +header: CAO_matrix.h +code: F +declaration: var +memory: alloc +return: ref +opcall: func +operands: vars_global +size: undefined +operations: init, decl(mixed), dispose, assign, ref(safe, func(val)), equal(macro), select(safe), range_select(safe), row_range_select(safe), col_range_select(safe), range_set, row_range_set, col_range_set, concat, add, sub, mul, div, pow, sym, cast + +[struct] +type: struct +header: CAO_struct.h +code: G +declaration: var +memory: alloc +return: ref +opcall: func +operands: vars_global +size: undefined +operations: init, decl, dispose, assign, equal(macro), select(safe), ref(safe, func(val)) + +[modpol] +type: modpol +header: CAO_modpol.h +code: H +declaration: var +memory: alloc +return: ref +opcall: func +operands: vars_global +size: undefined +operations: init, decl, dispose, assign, add, sub, mul, div, pow, sym, equal(macro), nequal(macro), cast + diff --git a/example/Makefile b/example/Makefile new file mode 100644 --- /dev/null +++ b/example/Makefile @@ -0,0 +1,7 @@ +CAO_PATH = .. + +sha1_test : sha1.cao + $(CAO_PATH)/dist/build/cao/cao comp --config $(CAO_PATH)/default.plat sha1.cao + gcc -c sha1.c main_sha1.c -I$(CAO_PATH)/backend_lib/C_generic/ + g++ sha1.o main_sha1.o $(CAO_PATH)/backend_lib/C_generic/*.cpp -lgmp -m64 -lntl -o sha1_test + diff --git a/example/main_sha1.c b/example/main_sha1.c new file mode 100644 --- /dev/null +++ b/example/main_sha1.c @@ -0,0 +1,44 @@ +#include "CAO_globals.h" +#include "CAO_globalOp.h" +#include "CAO_bool.h" +#include "CAO_int.h" +#include "CAO_ubits.h" +#include "CAO_sbits.h" +#include "CAO_mod.h" +#include "CAO_modpol.h" +#include "CAO_vector.h" +#include "CAO_matrix.h" +#include "CAO_struct.h" + +CAO_RES init(void); +CAO_RES dispose(void); +CAO_RES c_sha1_test1(void); +CAO_RES c_sha1_test2(void); +CAO_RES c_sha1_test3(void); +CAO_RES c_sha1_test4(void); + +extern CAO_ubits c_output; + +int main(void){ + init(); + c_sha1_test1(); + CAO_ubits_dump(c_output); + c_sha1_test2(); + CAO_ubits_dump(c_output); + c_sha1_test3(); + CAO_ubits_dump(c_output); + c_sha1_test4(); + CAO_ubits_dump(c_output); + dispose(); + return 0; +} + +/* Expected output: + + bits[160] = 968236873715988614170569073515315707566766479517 + bits[160] = 756981919157381189150916787291668349464288325873 + bits[160] = 939734261995848132309376323405959335045052539481 + bits[160] = 300671821421526032173293932193251544739706306927 + +consistently with http://www.di-mgt.com.au/sha_testvectors.html */ + diff --git a/example/sha1.cao b/example/sha1.cao new file mode 100644 --- /dev/null +++ b/example/sha1.cao @@ -0,0 +1,182 @@ +typedef byte := unsigned bits[8]; +typedef word := unsigned bits[32]; +typedef wordA := mod[2**32]; + +def A : word; +def B : word; +def C : word; +def D : word; +def E : word; +def W : vector[80] of word; + +def K : vector[4] of word := { + (word)0x5A827999, (word)0x6ED9EBA1, (word)0x8F1BBCDC, (word)0xCA62C1D6 +}; + +/* SHA1 compression function modifying global state */ + +def sha1_compress(Mi : vector[16] of word) : void { + + def Al, Bl, Cl, Dl, El, T : word; + + W[0..15] := Mi; + seq j := 16 to 79 { W[j] := (W[j-3] ^ W[j-8] ^ W[j-14] ^ W[j-16]) <| 1; } + Al := A; Bl := B; Cl := C; Dl := D; El := E; + seq j := 0 to 19 { + T := (word)((wordA)(A <| 5) + (wordA)((B&C)|((~B)&D)) + + (wordA)E + (wordA)K[0] + (wordA)W[j]); + E := D; D := C; C := B <| 30; B := A; A := T; + } + seq j := 20 to 39 { + T := (word)((wordA)(A <| 5) + (wordA)(B^C^D) + + (wordA)E + (wordA)K[1] + (wordA)W[j]); + E := D; D := C; C := B <| 30; B := A; A := T; + } + seq j := 40 to 59 { + T := (word)((wordA)(A <| 5) + (wordA)((B&C)|(B&D)|(C&D)) + + (wordA)E + (wordA)K[2] + (wordA)W[j]); + E := D; D := C; C := B <| 30; B := A; A := T; + } + seq j := 60 to 79 { + T := (word)((wordA)(A <| 5) + (wordA)(B^C^D) + + (wordA)E + (wordA)K[3] + (wordA)W[j]); + E := D; D := C; C := B <| 30; B := A; A := T; + } + A := (word)((wordA)A + (wordA)Al); + B := (word)((wordA)B + (wordA)Bl); + C := (word)((wordA)C + (wordA)Cl); + D := (word)((wordA)D + (wordA)Dl); + E := (word)((wordA)E + (wordA)El); + } + +/* SHA1 padding: nWords is the correct multiple of 16 */ +def sha1_padd(const l : register int { l > 0 }, const nWords : register int { nWords > 0}, msg : vector[l] of byte) : vector[nWords] of word { + def c : register int; + def M : vector[nWords] of word; + + c := 0; + + seq i := 0 to l / 4 - 1 { + M[i] := msg[c+3] @ msg[c+2] @ msg[c+1] @ msg[c]; + c := c + 4; + } + + if (l - c == 0) { + M[l / 4] := 0b10000000000000000000000000000000; + } + else { + if (l - c == 1) { + M[l / 4] := 0b100000000000000000000000 @ msg[c]; + } + else { + if (l - c == 2) { + M[l / 4] := 0b1000000000000000 @ msg[c+1] @ msg[c]; + } + else /* (l - c == 3) */ { + M[l / 4] := 0b10000000 @ msg[c+2] @ msg[c+1] @ msg[c]; + } + } + } + + seq i := (l / 4 + 1) to (nWords - 3) { + M[i] := 0b00000000000000000000000000000000; + } + + M[nWords - 2] := (word) ((int)l * 8 / 0x100000000); + M[nWords - 1] := (word) ((int)l * 8); + + return M; +} + +/* SHA1 algorithm taking message of length l bytes */ +def sha1(const l : register int { l > 0 }, msg : vector[l] of byte) : unsigned bits[160] { + def M : vector[16] of word; + def c, k: register int; + def res : unsigned bits[160]; + + /* Compute the padded input as vector of words */ + def const nBlocks : register int := (l * 8 + 64) / 512 + 1; + def blocks : vector[16 * nBlocks] of word; + blocks := sha1_padd(l, 16 * nBlocks, msg); + + /* Initialize state */ + A := (word)0x67452301; + B := (word)0xEFCDAB89; + C := (word)0x98BADCFE; + D := (word)0x10325476; + E := (word)0xC3D2E1F0; + + /* Iterate compression function */ + seq i := 0 to nBlocks - 1 { + M[0..15] := blocks[i * 16 .. i * 16 + 15]; + sha1_compress(M); + } + + res := E @ D @ C @ B @ A; + + return res; +} + +/* SHA1 test vector #1: "abc" */ + +def output : unsigned bits[160]; + +def sha1_test1() : void { + def msg : vector[3] of byte := { (byte)0x61, (byte)0x62, (byte)0x63 }; + output := sha1(3,msg); +} + +/* SHA1 test vector #2: "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" */ + +def sha1_test2() : void { + def msg : vector[56] of byte := { (byte)0x61, (byte)0x62, (byte)0x63, (byte)0x64, (byte)0x62, (byte)0x63, + (byte)0x64, (byte)0x65, (byte)0x63, (byte)0x64, (byte)0x65, (byte)0x66, + (byte)0x64, (byte)0x65, (byte)0x66, (byte)0x67, (byte)0x65, (byte)0x66, + (byte)0x67, (byte)0x68, (byte)0x66, (byte)0x67, (byte)0x68, (byte)0x69, + (byte)0x67, (byte)0x68, (byte)0x69, (byte)0x6a, (byte)0x68, (byte)0x69, + (byte)0x6a, (byte)0x6b, (byte)0x69, (byte)0x6a, (byte)0x6b, (byte)0x6c, + (byte)0x6a, (byte)0x6b, (byte)0x6c, (byte)0x6d, (byte)0x6b, (byte)0x6c, + (byte)0x6d, (byte)0x6e, (byte)0x6c, (byte)0x6d, (byte)0x6e, (byte)0x6f, + (byte)0x6d, (byte)0x6e, (byte)0x6f, (byte)0x70, (byte)0x6e, (byte)0x6f, + (byte)0x70, (byte)0x71 }; + + output := sha1(56,msg); +} + +/* SHA1 test vector #3: "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" */ + +def sha1_test3() : void { + def msg : vector[112] of byte := {(byte)0x61, (byte)0x62, (byte)0x63, (byte)0x64, (byte)0x65, (byte)0x66, + (byte)0x67, (byte)0x68, (byte)0x62, (byte)0x63, (byte)0x64, (byte)0x65, + (byte)0x66, (byte)0x67, (byte)0x68, (byte)0x69, (byte)0x63, (byte)0x64, + (byte)0x65, (byte)0x66, (byte)0x67, (byte)0x68, (byte)0x69, (byte)0x6a, + (byte)0x64, (byte)0x65, (byte)0x66, (byte)0x67, (byte)0x68, (byte)0x69, + (byte)0x6a, (byte)0x6b, (byte)0x65, (byte)0x66, (byte)0x67, (byte)0x68, + (byte)0x69, (byte)0x6a, (byte)0x6b, (byte)0x6c, (byte)0x66, (byte)0x67, + (byte)0x68, (byte)0x69, (byte)0x6a, (byte)0x6b, (byte)0x6c, (byte)0x6d, + (byte)0x67, (byte)0x68, (byte)0x69, (byte)0x6a, (byte)0x6b, (byte)0x6c, + (byte)0x6d, (byte)0x6e, (byte)0x68, (byte)0x69, (byte)0x6a, (byte)0x6b, + (byte)0x6c, (byte)0x6d, (byte)0x6e, (byte)0x6f, (byte)0x69, (byte)0x6a, + (byte)0x6b, (byte)0x6c, (byte)0x6d, (byte)0x6e, (byte)0x6f, (byte)0x70, + (byte)0x6a, (byte)0x6b, (byte)0x6c, (byte)0x6d, (byte)0x6e, (byte)0x6f, + (byte)0x70, (byte)0x71, (byte)0x6b, (byte)0x6c, (byte)0x6d, (byte)0x6e, + (byte)0x6f, (byte)0x70, (byte)0x71, (byte)0x72, (byte)0x6c, (byte)0x6d, + (byte)0x6e, (byte)0x6f, (byte)0x70, (byte)0x71, (byte)0x72, (byte)0x73, + (byte)0x6d, (byte)0x6e, (byte)0x6f, (byte)0x70, (byte)0x71, (byte)0x72, + (byte)0x73, (byte)0x74, (byte)0x6e, (byte)0x6f, (byte)0x70, (byte)0x71, + (byte)0x72, (byte)0x73, (byte)0x74, (byte)0x75 }; + + output := sha1(112,msg); +} + +/* SHA1 test vector #4: one million repetitions of "a" */ + +def sha1_test4() : void { + def msg : vector[1000000] of byte; + + seq i := 0 to 999999 { + msg[i] := (byte)0x61; + } + + output := sha1(1000000,msg); +} diff --git a/src/Language/CAO/Analysis/CFG.hs b/src/Language/CAO/Analysis/CFG.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Analysis/CFG.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} + +{- | + Module : $Header$ + Description : CAO control flow graph. + Copyright : (c) SMART Team / HASLab + License : GPL + + Maintainer : Paulo Silva + Stability : experimental + Portability : non-portable + + CAO control flow graph abstractions. +-} + +module Language.CAO.Analysis.CFG + ( NodeId + , BasicBlock + , Connections + , LocalGraph + , CaoCFG(..) + , buildCFG + , toAST + , getDefFromBlocks + , swaps + , showCFG + , entryNode + , exitNode + , removeSsaDecl + , graphFromEdges_ + ) where + +import Control.Monad.State +import Data.Graph +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map + +import Language.CAO.Analysis.Dominance + +import Language.CAO.Common.Outputable +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils (isSimpleVDecl) + +-------------------------------------------------------------------------------- + +type NodeId = Int +type BasicBlock = [LStmt Var] +type Connections = [NodeId] +type LocalGraph = Map NodeId (BasicBlock, Connections) + +data CaoCFG = CaoCFG { + definition :: LDef Var, + blocks :: LocalGraph + } + +data CFGState = CFGState { + currentId :: !NodeId, + currentNode :: BasicBlock, + graph :: LocalGraph + } + +emptyState :: CFGState +emptyState = CFGState (entryNode + 1) [] $ + Map.fromList [ (entryNode, ([], [])), (exitNode, ([], [])) ] + +entryNode :: NodeId +entryNode = 1 + +exitNode :: NodeId +exitNode = 0 + +currentNodeId :: State CFGState NodeId +currentNodeId = gets currentId + +addToCurrentNode :: LStmt Var -> State CFGState () +addToCurrentNode stmt = + modify $ \ s -> s { currentNode = stmt : currentNode s } + +endCurrentNode :: State CFGState () +endCurrentNode = modify $ \ s -> let + cnode = currentNode s + in if null cnode + then s + else s { graph = Map.insert (currentId s) (reverse cnode, []) (graph s), + currentNode = [], + currentId = succ (currentId s) } + +addEmptyNode :: State CFGState NodeId +addEmptyNode = get >>= \ s -> do + let i = currentId s + cnode = reverse $ currentNode s + put $ s { graph = Map.insert i (cnode, []) (graph s), + currentNode = [], + currentId = succ i + } + return i + +-- Precondition: endCurrentNode should have been called first +addSingleNode :: LStmt Var -> State CFGState NodeId +addSingleNode stmt = do + addToCurrentNode stmt + cid <- currentNodeId + endCurrentNode + return cid + +addEdges :: [NodeId] -> [NodeId] -> State CFGState () +addEdges origin target = mapM_ (`addEdge` target) origin + +-- This needs to add target nodes to the end of the list, +-- in order to ensure the correct order when translating +-- back to an AST +addEdge :: NodeId -> [NodeId] -> State CFGState () +addEdge origin target = modify $ \ s -> + s { graph = Map.adjust (mapSnd (++ target)) origin (graph s) } + +-------------------------------------------------------------------------------- +-- Generation of CFG + +-------------------------------------------------------------------------------- +------------------------------------------ Prog -------------------------------- + +buildCFG :: Prog Var -> [CaoCFG] +buildCFG (Prog defs _) = map definitionCFG defs + +-------------------------------------------------------------------------------- +--------------------------------------- Definition ----------------------------- + +definitionCFG :: LDef Var -> CaoCFG +definitionCFG (L l (FunDef (Fun n args rt body))) + | [] <- filter (not . isSimpleVDecl . unLoc) body = + let st = flip execState emptyState $ do + nd <- addEmptyNode + addEdges [entryNode] [nd] + addEdges [nd] [exitNode] + in CaoCFG fd (graph st) + | otherwise = + let st = flip execState emptyState $ do + (entry, exit) <- toGraph body + addEdges [entryNode] entry + addEdges exit [exitNode] + in CaoCFG fd (graph st) + where + fd = L l $ FunDef $ Fun n args rt [] +definitionCFG def + = CaoCFG def Map.empty + + +-------------------------------------------------------------------------------- +------------------------------------------ Func -------------------------------- + +-- The function returns the id of the entry node of a sub-graph and the list +-- of id's of exit blocks of a sub-graph +toGraph :: [LStmt Var] -> State CFGState ([NodeId], [NodeId]) +toGraph [] = do + curNode <- currentNodeId + endCurrentNode + return ([curNode], [curNode]) +toGraph (L l (VDecl (ContD vn _ exs)) : xs) = do + let sv = L (getLoc vn) $ mkStoreInit $ varName $ unLoc vn + declEntry l vn sv exs + toGraph xs +-- Ignoring variable declaration +toGraph (L l (VDecl (VarD vn _ _)) : xs) = do + declEntrySSA l vn + toGraph xs +toGraph (L l (VDecl (MultiD vns _)) : xs) = do + mapM_ (declEntrySSA l) vns + toGraph xs +toGraph (L l (CDecl (ConstD cn _ _)) : xs) = do + declEntrySSA l cn + toGraph xs +toGraph (L l (CDecl (MultiConstD cns _ _)) : xs) = do + mapM_ (declEntrySSA l) cns + toGraph xs +toGraph (s@(L _ (Assign _ _)) : xs) = + addToCurrentNode s >> toGraph xs +toGraph (s@(L _ (FCallS _ _)) : xs) = + addToCurrentNode s >> toGraph xs +toGraph (s@(L _ (Ret _)) : _) = do + curNode <- currentNodeId + addToCurrentNode s + endCurrentNode + addEdges [curNode] [exitNode] + return ([curNode], []) -- There is no exit point since the node is final +toGraph (L l (Ite i t Nothing) : xs) = do + curNode <- currentNodeId + addToCurrentNode (L l $ Ite i [] Nothing) + endCurrentNode + (ifEntryNode, ifExitNodes) <- toGraph t + (nextEntryNode, nextExitNodes) <- toGraphRest xs + addEdges [curNode] (ifEntryNode ++ nextEntryNode) + addEdges ifExitNodes nextEntryNode + return ([curNode], if null xs then curNode : ifExitNodes else nextExitNodes) +toGraph (L l (Ite i t (Just e)) : xs) = do + curNode <- currentNodeId + addToCurrentNode (L l $ Ite i [] (Just [])) + endCurrentNode + (ifEntryNode, ifExitNodes) <- toGraph t + (elseEntryNode, elseExitNodes) <- toGraph e + (nextEntryNode, nextExitNodes) <- toGraphRest xs + addEdges [curNode] (ifEntryNode ++ elseEntryNode) + addEdges (ifExitNodes ++ elseExitNodes) nextEntryNode + return ([curNode], + if null xs then ifExitNodes ++ elseExitNodes else nextExitNodes) +toGraph (L l (While cond wstmts) : xs) = do + curNode <- currentNodeId + endCurrentNode + whileNode <- addSingleNode (L l $ While cond []) + (bodyEntryNode, bodyExitNodes) <- toGraph wstmts + (nextEntryNode, nextExitNodes) <- toGraphRest xs + when (curNode /= whileNode) $ addEdges [curNode] [whileNode] + addEdges [whileNode] (bodyEntryNode ++ nextEntryNode) + addEdges bodyExitNodes [whileNode] + return ([curNode], if null xs then [whileNode] else nextExitNodes) +toGraph (L l (Seq iter stmts) : xs) = do + curNode <- currentNodeId + endCurrentNode + seqNode <- addSingleNode (L l $ Seq iter []) + (bodyEntryNode, bodyExitNodes) <- toGraph stmts + (nextEntryNode, nextExitNodes) <- toGraphRest xs + when (curNode /= seqNode) $ addEdges [curNode] [seqNode] + addEdges [seqNode] (bodyEntryNode ++ nextEntryNode) + addEdges bodyExitNodes [seqNode] + return ([curNode], if null xs then [seqNode] else nextExitNodes) +toGraph (s@(L _ (Nop _)) : xs) = + addToCurrentNode s >> toGraph xs + +declEntrySSA :: SrcLoc -> Located Var -> State CFGState () +declEntrySSA l vn = declEntry l vn (genLoc ssaDecl) [] + +declEntry :: SrcLoc -> Located Var -> Located Var -> [TLExpr Var] -> State CFGState () +declEntry l v fc exs = addToCurrentNode $ + L l $ Assign [LVVar v] [ L l $ annTyE (varType $ unLoc v) $ FunCall fc exs] + +toGraphRest :: [LStmt Var] -> State CFGState ([NodeId], [NodeId]) +toGraphRest [] = return ([], []) +toGraphRest xs = toGraph xs +-------------------------------------------------------------------------------- +-- Back from CFG + +toAST :: [CaoCFG] -> Prog Var +toAST cfg = Prog (map getDefFromBlocks cfg) Nothing + +getDefFromBlocks :: CaoCFG -> LDef Var +getDefFromBlocks (CaoCFG cdef cblocks) = case unLoc cdef of + FunDef (Fun n args rt []) -> + L (getLoc cdef) $ FunDef $ Fun n args rt $ bodyFromBlocks cblocks + _ -> cdef + +bodyFromBlocks :: LocalGraph -> [LStmt Var] +bodyFromBlocks blks = let + g = graphFromEdges_ blks + dt = invertMap $ genDomTree g + in bodyFromBlocks' dt blks $ head $ snd $ blks Map.! entryNode + +graphFromEdges_ :: LocalGraph -> Graph +graphFromEdges_ blks = let + (g,_,_) = graphFromEdges $ map (\ (k, (_, c)) -> (k, k, c) ) $ Map.assocs blks + in g + +bodyFromBlocks' :: Map Vertex [Vertex] -> LocalGraph -> NodeId -> [LStmt Var] +bodyFromBlocks' domTree blks nid = + if nid == exitNode then [] else let + nextNodes = domTree Map.! nid + (bn, cn) = blks Map.! nid + (stmts, lastStmt) = initLast bn + in if null bn then [] else + case unLoc lastStmt of + Ite i _ Nothing -> stmts ++ ( L (getLoc lastStmt) + (Ite i (fetchNextBlock (cn !! 0)) Nothing) : + fetchNext (nextNodes \\ [cn !! 0])) + Ite i _ (Just _) -> stmts ++ ( L (getLoc lastStmt) + (Ite i (fetchNextBlock (cn !! 0)) + (Just $ fetchNextBlock (cn !! 1))) : + fetchNext (nextNodes \\ [cn !! 0, cn !! 1])) + While c _ -> stmts ++ ( L (getLoc lastStmt) + (While c (fetchNextBlock (cn !! 0))) : + fetchNext (nextNodes \\ [cn !! 0])) + Seq i _ -> stmts ++ ( L (getLoc lastStmt) + (Seq i (fetchNextBlock (cn !! 0) )) : + fetchNext (nextNodes \\ [cn !! 0])) + _ -> bn ++ fetchNext nextNodes + where + fetchNextBlock = bodyFromBlocks' domTree blks + fetchNext = concatMap (bodyFromBlocks' domTree blks) + +--- auxiliary --- + +showCFG :: [CaoCFG] -> String +showCFG cfg = "digraph cao_cfg {\n" ++ unlines (map aux cfg) ++ invisedgs ++ "\n}" + where + + invisedgs + | null invisedgs' = "" + | otherwise = "edge [style = invis]\n" ++ unlines invisedgs' + + invisedgs' = graphs cfg + + graphs :: [CaoCFG] -> [String] + graphs [] = [] + graphs [_] = [] + graphs ((CaoCFG (unLoc->FunDef f1) _):c@(CaoCFG (unLoc->FunDef f2) _):rest) + = let edg = "\"0" ++ showPprIds (funId f1) + ++ "\" -> \"1" ++ showPprIds (funId f2) ++ "\"\n" + in edg:(graphs (c:rest)) + graphs (d@(CaoCFG (unLoc->FunDef _) _):_:rest) + = graphs (d:rest) + graphs (_:rest) + = graphs rest + + aux :: CaoCFG -> String + aux (CaoCFG def bk) = case unLoc def of + FunDef f -> let fundef = showPprIds (funId f) + in unlines $ + ["subgraph " ++ fundef ++ " {\n"] ++ nodes fundef bk ++ cfgEdges fundef bk ++ + ["}"] + _ -> "" + + nodes str = map (\ (k, (s, _)) -> let + sst = if k == entryNode then "Entry\\l" ++ str ++ "\\n" else if k == exitNode then "Exit\\n" else "" + in "node [label=\"" ++ sst ++ showStmts s ++ "\"]\n\"" ++ show k ++ str ++ "\" [shape=box];") + . Map.assocs + cfgEdges str = concatMap (\ (k, (_, nl)) -> + map (\b -> '"':show k ++ str ++ "\" -> \"" ++ show b ++ str ++ "\"") nl) . Map.assocs + + showStmts :: PP a => [a] -> String + showStmts = concatMap ((++ "\\l") . filter (/= '\n') . showPprIds) + +removeSsaDecl :: CaoCFG -> CaoCFG +removeSsaDecl cfg = cfg { blocks = Map.map filterSsaDecls (blocks cfg) } + where filterSsaDecls :: (BasicBlock, Connections) -> (BasicBlock, Connections) + filterSsaDecls (ss, n) = (filter (not . isSsaDeclStmt . unLoc) ss, n) + + isSsaDeclStmt :: Stmt Var -> Bool + isSsaDeclStmt (Assign [LVVar _] [unLoc -> unTyp -> FunCall fn []]) = isSsaDecl $ unLoc fn + isSsaDeclStmt _ = False diff --git a/src/Language/CAO/Analysis/Dominance.hs b/src/Language/CAO/Analysis/Dominance.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Analysis/Dominance.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE PatternGuards #-} +{- | +Module : $Header$ +Description : Graph dominance algorithm. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +Graph dominance algorithm. +-} + +module Language.CAO.Analysis.Dominance + ( genDomTree + , predecessors + , successors + , domFront + , invertMap + ) where + +import Data.Graph +import Data.List hiding ( intersect ) +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + + +-------------------------------------------------------------------------------- +{- DOMINATOR TREE -} +-- pag 13 + +-- for all nodes, b /* initialize the dominators array */ +-- doms[b] <- Undefined +-- doms[start node] <- start node +-- Changed <- true +-- while (Changed) +-- Changed <- false +-- for all nodes, b, in reverse postorder (except start node) +-- new idom <- first (processed) predecessor of b /* (pick one) */ +-- for all other predecessors, p, of b +-- if doms[p] /= Undefined /* i.e., if doms[p] already calculated */ +-- new idom <- intersect(p, new idom) +-- if doms[b] /= new idom +-- doms[b] <- new idom +-- Changed <- true +-- + +genDomTree :: Graph -> Map Vertex Vertex +genDomTree g = let + (ns, ss) = partition withPreds (vertices g) + initSelf = foldl' (\m n -> Map.insert n n m) Map.empty ss + in genDomTree' ns initSelf + where + -- Fixpoint: this could be improved to avoid using equality + genDomTree' :: [Vertex] -> Map Vertex Vertex -> Map Vertex Vertex + genDomTree' ns doms = let + doms' = foldl' (upDomTree g) doms ns + in if doms' == doms then doms else genDomTree' ns doms' + + withPreds :: Vertex -> Bool + withPreds = not . null . predecessors g + +upDomTree :: Graph -> Map Vertex Vertex -> Vertex -> Map Vertex Vertex +upDomTree g doms b = Map.alter alterNewIdiom b doms + where + alterNewIdiom :: Maybe Vertex -> Maybe Vertex + alterNewIdiom = const $ Just $ getNewIdiom $ predecessors g b + + getNewIdiom :: [Vertex] -> Vertex + getNewIdiom (p:ps) = foldl' fNewIdiom p ps + getNewIdiom _ = error $ ".\ + \: no predecessors!" + + fNewIdiom :: Vertex -> Vertex -> Vertex + fNewIdiom ni p = if Map.member p doms then intersect p ni doms else ni + +predecessors :: Graph -> Vertex -> [Vertex] +predecessors g v = [ a | (a, b) <- edges g, b == v] + +successors :: Graph -> Vertex -> [Vertex] +successors g v = [ b | (a, b) <- edges g, a == v] + +--function intersect(b1, b2) returns node +-- finger1 <- b1 +-- finger2 <- b2 +-- while (finger1 /= finger2) +-- while (finger1 < finger2) +-- finger1 = doms[finger1] +-- while (finger2 < finger1) +-- finger2 = doms[finger2] +-- return finger1 + +intersect :: Vertex -> Vertex -> Map Vertex Vertex -> Vertex +intersect v1 v2 doms + = maximum [ f1 | f1 <- follow v1 , f1 `elem` follow v2 ] + where + follow :: Vertex -> [Vertex] + follow v = case Map.lookup v doms of + Just v' | v > v' -> v : follow v' + _ -> [v] + +-------------------------------------------------------------------------------- +---- Dominance Frontier -------------------------------------------------------- + +--for all nodes, b +-- if the number of predecessors of b >= 2 +-- for all predecessors, p, of b +-- runner <- p +-- while runner /= doms[b] +-- add b to runner's dominance frontier set +-- runner = doms[runner] + +domFront :: Graph -> Map Vertex (Set Vertex) +domFront g = foldl' (nodeDomFront g doms) Map.empty $ vertices g + where + doms :: Map Vertex Vertex + doms = genDomTree g + + +nodeDomFront :: Graph + -> Map Vertex Vertex + -> Map Vertex (Set Vertex) + -> Vertex + -> Map Vertex (Set Vertex) +nodeDomFront g doms df b = let + preds = predecessors g b + in case preds of + _:_:_ -> foldl' addDoms df preds + _ -> df + where + addDoms :: Map Vertex (Set Vertex) + -> Vertex + -> Map Vertex (Set Vertex) + addDoms df' = foldl' addDom df' . follow + + addDom :: Map Vertex (Set Vertex) + -> Vertex + -> Map Vertex (Set Vertex) + addDom = flip (Map.alter dfSet) + + dfSet :: Maybe (Set Vertex) -> Maybe (Set Vertex) + dfSet Nothing = Just $ Set.singleton b + dfSet (Just s) = Just $ Set.insert b s + + follow :: Vertex -> [Vertex] + follow r = case Map.lookup r doms of + Just d | d /= r -> r : follow d + _ -> [r] + +-------------------------------------------------------------------------------- +invertMap :: Map Vertex Vertex -> Map Vertex [Vertex] +invertMap domTree = Map.foldrWithKey aux (Map.map (const []) domTree) domTree + where + aux :: Vertex -> Vertex -> Map Vertex [Vertex] -> Map Vertex [Vertex] + aux k v m = if k == v + then m + else let newVal = k : Map.findWithDefault [] v m + in Map.insert v newVal m + diff --git a/src/Language/CAO/Analysis/PhiInsert.hs b/src/Language/CAO/Analysis/PhiInsert.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Analysis/PhiInsert.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} +{- +Module : $Header$ +Description : Insertion of phi function in SSA form. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} +module Language.CAO.Analysis.PhiInsert where + +import Data.Graph ( Graph, Vertex ) +import Data.List +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Maybe ( fromMaybe ) +import Data.Set ( Set ) +import qualified Data.Set as Set + +import Language.CAO.Common.Var +import Language.CAO.Common.SrcLoc + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils hiding ( getVars ) + +import Language.CAO.Analysis.Dominance +import Language.CAO.Analysis.CFG + + +--To decide what blocks require a phi +--function to join a definition to a variable +--v in block b: +-- 1. Compute D1 = DF(b). +-- Place Phi functions at the head of all +-- members of D1. +-- +-- 2. Compute D2 = DF(D1). +-- Place Phi functions at the head of all +-- members of D2-D1. +-- +-- 3. Compute D3 = DF(D2). +-- Place Phi functions at the head of all +-- members of D3-D2-D1. +-- +-- 4. Repeat until no additional Phi +-- functions can be added. + +insertPhiFuncs :: Graph -> CaoCFG -> (CaoCFG, [Var]) +insertPhiFuncs g cfg = (phiIns phiFuns cfg, allVars) + where + phiFuns :: Set (Vertex, Var, Int) + phiFuns = phiLocArity g locOf + allVars :: [Var] + allVars = Map.keys locOf + locOf :: Map Var (Set Vertex) + locOf = Map.foldWithKey getLocs Map.empty (blocks cfg) + +getLocs :: Vertex -> ([LStmt Var], [NodeId]) -> Map Var (Set Vertex) + -> Map Var (Set Vertex) +getLocs nI (stmts, _) lo = foldl' (addVerts nI) lo $ getVars stmts + +addVerts :: Vertex -> Map Var (Set Vertex) -> Var -> Map Var (Set Vertex) +addVerts nI lo v = Map.alter (addVertex nI) v lo + +addVertex :: Vertex -> Maybe (Set Vertex) -> Maybe (Set Vertex) +addVertex v Nothing = Just $ Set.singleton v +addVertex v (Just s) = Just $ Set.insert v s + + +phiLocArity :: Graph -> Map Var (Set Vertex) -> Set (Vertex, Var , Int) +phiLocArity g = Map.foldWithKey foldDf Set.empty + where + foldDf :: Var -> Set Vertex -> Set (Vertex, Var, Int) + -> Set (Vertex, Var, Int) + foldDf s v acc + | Set.size v > 1 = + Set.map (phiVarArity s) (followDf Set.empty v) `Set.union` acc + | otherwise = acc + + phiVarArity :: Var -> Vertex -> (Vertex, Var, Int) + phiVarArity s v = (v, s, length $ predecessors g v) + + followDf :: Set Vertex -> Set Vertex -> Set Vertex + followDf ini d1 + | d2 <- Set.fold getDF ini d1, d1 /= d2 = followDf d2 d2 + | otherwise = d1 + + getDF :: Vertex -> Set Vertex -> Set Vertex + getDF v s0 = Set.union s0 $ fromMaybe Set.empty $ Map.lookup v df + + df :: Map Vertex (Set Vertex) + df = domFront g + +phiIns :: Set (Vertex, Var, Int) -> CaoCFG -> CaoCFG +phiIns s cfg | Set.size s == 0 = cfg + | otherwise = phiIns s' cfg' + where + (phiAt@(_, n, _), s') = Set.deleteFindMax s + phiFunN = mkPhiFunVar (varName n) + cfg' = phiIns_ phiFunN phiAt cfg + +phiIns_ :: Var -> (Vertex, Var, Int) -> CaoCFG -> CaoCFG +phiIns_ phiFunN (nodeI, vname, arity) cfg + | nodeI == exitNode = cfg + | otherwise = addStmtAt nodeI phiFunAssign cfg + where + phiFunAssign :: LStmt Var + phiFunAssign = genLoc $ Assign [lval] [phiFun] + lval :: LVal Var + lval = LVVar (genLoc vname) + phiFun :: TLExpr Var + -- XXX: Is this the correct annotation type? + phiFun = genLoc $ annTyE (varType vname) $ FunCall (genLoc phiFunN) args + args :: [TLExpr Var] + args = map (genLoc . annTyE (varType vname) . Var) $ replicate arity vname + +addStmtAt :: Vertex -> LStmt Var -> CaoCFG -> CaoCFG +addStmtAt nodeI stmt cfg = cfg { blocks = Map.insert nodeI (stmt:stmts, c) blk } + where + blk = blocks cfg + (stmts,c) = blk Map.! nodeI + +getVars :: [LStmt Var] -> [Var] +getVars = concatMap (variableName . unLoc) + where + variableName :: Stmt Var -> [Var] + variableName (VDecl v) = Set.toList $ bvs v + variableName (Assign lvalues _) = Set.toList $ fvs lvalues + variableName _ = [] diff --git a/src/Language/CAO/Analysis/SSA.hs b/src/Language/CAO/Analysis/SSA.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Analysis/SSA.hs @@ -0,0 +1,544 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} +{- +Module : $Header$ +Description : CAO static single assignment form. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +CAO static single assignment form. +-} + +module Language.CAO.Analysis.SSA + ( toSSA + , fromSSA + ) where + +import Control.Monad.State.Strict +import Data.Graph +import Data.List hiding (insert) +import Data.Map (Map) +import qualified Data.Map as Map + +import Language.CAO.Analysis.CFG +import Language.CAO.Analysis.Dominance +import Language.CAO.Analysis.PhiInsert +import qualified Language.CAO.Analysis.SsaBack as BT + +import Language.CAO.Common.Monad +import Language.CAO.Common.Var +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.State +import Language.CAO.Common.Utils ( mapFst, mapSnd, replaceAt ) + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils + +import Language.CAO.Type + + +---- Renaming Variables -------------------------------------------------------- + +-- Local definition +newtype Stack a = Stack [a] + +push :: a -> Stack a -> Stack a +push a (Stack s) = Stack (a : s) + +pop :: Stack a -> (a, Stack a) +pop (Stack []) = error "Pop: Empty stack." +pop (Stack (h:t)) = (h, Stack t) + +top :: Stack a -> Maybe a +top (Stack []) = Nothing +top (Stack s) = Just $ head s + +emptyStack :: Stack a +emptyStack = Stack [] + +-- count: C(*) map from variable identifiers (v) to a counter telling +-- how many assignments to v have been processed +-- stacks: S(*) map from variable identifiers (v) +-- to stacks of integers representing ... +data RenameState = + RState { count :: !Int + , stacks :: !(Map Var (Stack Int)) + } + +-- Top-level +emptyRState :: Int -> RenameState +emptyRState vuniq = RState vuniq Map.empty + +popM :: Var -> State RenameState () +popM str = modify $ \st -> snd $ pop_a st str + where +-- Local definition + pop_a :: RenameState -> Var -> (Int,RenameState) + pop_a st a = + let stacks_ = stacks st + st_a = Map.findWithDefault emptyStack a stacks_ + (x,st_a') = pop st_a + st' = Map.insert a st_a' stacks_ + in (x,st { stacks = st'}) + +pushM :: Var -> Int -> State RenameState () +pushM str i = modify $ \st -> push_i_a st + where +-- push i onto stack[a] + push_i_a :: RenameState -> RenameState + push_i_a st = + let stacks_ = stacks st + st_a = Map.findWithDefault emptyStack str stacks_ + st_a' = push i st_a + st' = Map.insert str st_a' stacks_ -- Use update in place ??? + in st { stacks = st' } + +countM :: State RenameState Int +countM = do + st <- get + let c = count st + put $ st { count = c + 1 } + return c + + +-- Local definition +-- top stack[a] +top_a :: RenameState -> Var -> Maybe Int +top_a st a = top $ Map.findWithDefault emptyStack a $ stacks st + + +-------------------------------------------------------------------- +updateBlock :: NodeId -> CaoCFG -> [LStmt Var] -> CaoCFG +updateBlock nid cfg nstmts = + cfg { blocks = Map.adjust (mapFst (const nstmts)) nid (blocks cfg) } + +blockById :: NodeId -> CaoCFG -> [LStmt Var] +blockById nid m = fst $ blocks m Map.! nid + + +------------------------------------------------------------------ +-- TODO: FIX -> monadic uniq indentifiers for renaming!!! +renameVars :: CaoMonad m => Map Vertex Vertex -> CaoCFG -> [Var] -> m CaoCFG +renameVars domTree cfg vs = do + u <- uniqId + let initSt = foldl' aux (emptyRState u) vs + (cfg', st') = runState (rename (invertMap domTree) cfg entryNode) initSt + st <- get + put st { lastVar = count st' + 1 } + return cfg' + where + aux :: RenameState -> Var -> RenameState + aux st v = st { stacks = Map.insert v emptyStack (stacks st) } + +-------------------------------------------------------------------- + +rename :: Map Vertex [Vertex] -> CaoCFG -> NodeId -> State RenameState CaoCFG +rename domTree cfg nid = do + (oldLHS, cfg') <- blockAssignments cfg nid + cfg'' <- foldM (phiFunctions nid) cfg' $ successors' nid cfg' + cfg''' <- foldM (rename domTree) cfg'' $ children domTree nid + mapM_ popM oldLHS + return cfg''' + +-- First loop ------------------------------------------------------------------ +blockAssignments :: CaoCFG -> NodeId -> State RenameState ([Var], CaoCFG) +blockAssignments cfg nid = do + let stmtBlock = blockById nid cfg + (oldLHS, stmtBlock') <- renameStatements stmtBlock + let cfg' = updateBlock nid cfg stmtBlock' + return (oldLHS, cfg') + +-- There is a similar function in Simplify module - fuse +--variablesLHS :: [LStmt Var] -> [Var] +--variablesLHS = Set.toList . lvalNames + +---- The CFG has empty lists of statements, thus we do not need recursion +---- The statements must be traversed in order +---- The RHS must be processed before the LHS +renameStatements :: [LStmt Var] -> State RenameState ([Var],[LStmt Var]) +renameStatements = doMap + where + doMap xs = mapM aux xs >>= \lst -> + let (a,b) = unzip lst in return (concat a, b) + aux :: LStmt Var -> State RenameState ([Var], LStmt Var) + aux s = case unLoc s of + Assign lvs f@[unLoc -> unTyp -> FunCall n _] | isPhiFun (unLoc n) -> do + lvs' <- mapM renameLVal lvs + return ([],L (getLoc s) $ Assign lvs' f) + Assign lvs rhs -> do + rhs' <- mapM renameVar rhs + lvs' <- mapM renameLVal lvs + return (map lvname lvs, L (getLoc s) $ Assign lvs' rhs') + FCallS fname exs -> do + exs' <- mapM renameVar exs + return ([],L (getLoc s) $ FCallS fname exs') + Ret exs -> do + exs' <- mapM renameVar exs + return ([],L (getLoc s) $ Ret exs') + Ite i t e -> do + i' <- renameVar i + return ([],L (getLoc s) $ Ite i' t e) + While i ss -> do + i' <- renameVar i + return ([],L (getLoc s) $ While i' ss) + + Seq (SeqIter ivar ilow ihigh Nothing rng) stmts -> do + ilow' <- renameVar' ilow + ihigh' <- renameVar' ihigh + return ([], L (getLoc s) $ + Seq (SeqIter ivar ilow' ihigh' Nothing rng) stmts) + Seq (SeqIter ivar ilow ihigh (Just iby) rng) stmts -> do + ilow' <- renameVar' ilow + ihigh' <- renameVar' ihigh + iby' <- renameVar' iby + return ([], L (getLoc s) $ + Seq (SeqIter ivar ilow' ihigh' (Just iby') rng) stmts) + + Nop t -> return ([], L (getLoc s) $ Nop t) + _ -> error ".:\ + \ FIXME! Add cases VDecl" + -- FIXME: Not expecting sequences + + renameVar :: TLExpr Var -> State RenameState (TLExpr Var) + renameVar (L l (TyE t e)) = get >>= \st -> + return $ L l $ TyE t $ fmap (suffixVar st) e + + renameVar' :: LExpr Var -> State RenameState (LExpr Var) + renameVar' (L l e) = get >>= \st -> + return $ L l $ fmap (suffixVar st) e + + renameLVal :: LVal Var -> State RenameState (LVal Var) + renameLVal lv = case lv of + LVVar v -> do + i <- countM + pushM (unLoc v) i + return $ LVVar $ fmap (setId i) v + _ -> error ".: unexpected case" -- return lv + + +suffixVar :: RenameState -> Var -> Var +suffixVar st x + | Just vid <- top_a st x = setId vid x + | otherwise = x +-- +-- +-- Second loop ----------------------------------------------------------------- +successors' :: NodeId -> CaoCFG -> [NodeId] +successors' nid = snd . (Map.! nid) . blocks + +-- WhichPred(Y, X), Y in Succ(X) +whichPredecessor :: NodeId -> NodeId -> CaoCFG -> Int +whichPredecessor nsucc nid = aux 0 . Map.assocs . blocks + where + aux _ [] = error ".: empty list" + aux n ((k, (_, succs)) : xs) + | k == nid = n + | nsucc `elem` succs = aux (n + 1) xs + | otherwise = aux n xs + +phiFunctions :: NodeId -> CaoCFG -> NodeId -> State RenameState CaoCFG +phiFunctions nid cfg nsucc = do + st <- get + let j = whichPredecessor nsucc nid cfg + return $ updateBlock nsucc cfg $ + renamePhiFunc st j $ + blockById nsucc cfg + +renamePhiFunc :: RenameState -> Int -> [LStmt Var] -> [LStmt Var] +renamePhiFunc st j = map aux + where + aux :: LStmt Var -> LStmt Var + aux s = case unLoc s of + Assign lvs [L loc (TyE t (FunCall fname exps))] + | isPhiFun (unLoc fname) -> + L (getLoc s) $ Assign lvs [L loc (TyE t (FunCall fname $ jElem st j exps))] + _ -> s + jElem :: RenameState -> Int -> [TLExpr Var] -> [TLExpr Var] + jElem st' j' exps = let + L l (TyE t (Var v)) = exps !! j' + v' = suffixVar st' v + in replaceAt j' (L l $ TyE t $ Var v') exps + +children :: Map Vertex [Vertex] -> NodeId -> [NodeId] +children = (Map.!) +-------------------------------------------------------------------------------- +-- Store and Load -------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- A function that takes in each node of the CFG, and removes every store and load into arrays and structures, +-- transforming them into function calls to +-- store(vector/array_name,index/field_name,new value) and +-- load(vector/array_name,index/field_name) + +-------------------------------------------------------------------------------- +-- Replaces writes/reads on global variables with procedure calls. +-- Writes and reads of structured types are replaced by function calls. + +introLoadStore :: CaoCFG -> CaoCFG +introLoadStore cfg = cfg { blocks = blocks' } + where + wvars = getWVars cfg + lb = loadBlock wvars + sb = storeBlock wvars + blocks' = storeOnExit sb $ loadOnEntry lb $ Map.map (renameBlock lb sb) (blocks cfg) + +-------------------------------------------------------------------------------- +-- Written global variables in a CFG + +getWVars :: CaoCFG -> [Var] +getWVars cfg = + case unLoc (definition cfg) of + FunDef (Fun fn _ _ _) -> + case varType (unLoc fn) of + FuncSig _ _ (Proc wvars) -> wvars + _ -> [] + _ -> [] + +-------------------------------------------------------------------------------- +-- Block of global variable load and store statements + +loadBlock :: [Var] -> [LStmt Var] +loadBlock = map aux + where + aux :: Var -> LStmt Var + aux v = genLoc $ Assign [lv] [f] + where + f = genLoc $ annTyE (varType v) $ FunCall lg [] + lg = genLoc $ mkLoadGlobal (varName v) + lv = LVVar $ genLoc v + + +storeBlock :: [Var] -> [LStmt Var] +storeBlock = map $ \ v -> + genLoc $ FCallS (mkStoreGlobal $ varName v) [genLoc $ annTyE (varType v) $ Var v] + +-------------------------------------------------------------------------------- +-- Loads written global variables on entry + +loadOnEntry :: BasicBlock -> LocalGraph -> LocalGraph +loadOnEntry loadBlk blks = let + i = head $ snd $ blks Map.! entryNode + in Map.adjust (mapFst (loadBlk ++)) i blks + +-- Stores written global variables on exit + +storeOnExit :: BasicBlock -> LocalGraph -> LocalGraph +storeOnExit storeBlk = Map.adjust (mapFst (++ storeBlk)) exitNode + +-------------------------------------------------------------------------------- +-- Adds calls to store and retrieve global variables before and after function calls. +-- Replaces write/read to structured types by store/load function calls + +renameBlock :: BasicBlock -> BasicBlock -> (BasicBlock, Connections) -> (BasicBlock, Connections) +renameBlock lb sb = mapFst (concatMap aux) + where + aux :: LStmt Var -> BasicBlock + aux stmt = case unLoc stmt of + -- Function Call + FCallS _ _ -> sb ++ stmt : lb + Assign _ [unLoc -> unTyp -> FunCall _ _] -> sb ++ stmt : lb + -- Store + Assign lv r -> [ storeLoad lv r ] + _ -> [stmt] + +storeLoad :: [LVal Var] -> [TLExpr Var] -> LStmt Var +storeLoad lv exps = case head lv of + LVVar _ -> genLoc $ Assign lv (map load exps) + lv' -> let (lv'', lpath) = extractLVal lv' + in storeCall lv'' lpath exps + +load :: TLExpr Var -> TLExpr Var +load (L l (TyE t e)) = L l $ TyE t $ load_ e + +load_ :: Expr Var -> Expr Var +load_ (StructProj s f) + = FunCall (genLoc loadStruct) [s, genLoc $ annTyE (varType f) $ Var f] +load_ (Access c (VectP (CElem i))) + = FunCall (genLoc loadVar) [c,i] +load_ (Access c (VectP (CRange i j))) + = FunCall (genLoc loadVarRng) [c,i,j] +load_ (Access c (MatP (CElem i) (CElem j))) + = FunCall (genLoc loadMatrix) [c,i,j] +load_ (Access c (MatP (CRange i j) (CRange k l))) + = FunCall (genLoc loadMatrixRng) [c,i,j,k,l] +load_ (Access c (MatP (CRange i j) (CElem k))) + = FunCall (genLoc loadMatrixRowRng) [c,i,j,k] +load_ (Access c (MatP (CElem i) (CRange j k))) + = FunCall (genLoc loadMatrixColRng) [c,i,j,k] +load_ e + = e + +storeCall :: Var -> [TLExpr Var] -> [TLExpr Var] -> LStmt Var +storeCall lv index values = let + lv' = LVVar $ genLoc lv + dest = genLoc $ annTyE (varType lv) $ Var lv + funC = genLoc $ annTyE (varType lv) $ FunCall (genLoc storeVar) (dest : index ++ values) + in genLoc $ Assign [lv'] [funC] + +extractLVal :: LVal Var -> (Var, [TLExpr Var]) +extractLVal lv = case lv of + LVVar lvar -> (unLoc lvar, []) + LVStruct lv' fld -> + mapSnd (structAccess Bullet fld :) (extractLVal lv') + LVCont ty lv' apat -> + mapSnd (extractAPat ty apat :) (extractLVal lv') + where + extractAPat :: Type Var -> APat Var -> TLExpr Var + extractAPat ty (VectP (CElem i)) = vectorAccess ty i + extractAPat ty (VectP (CRange i j)) = vectorRange ty i j + extractAPat ty (MatP (CElem i) (CElem j)) = matrixAccess ty i j + extractAPat ty (MatP (CRange i j) (CRange k l)) = matrixRange ty i j k l + extractAPat ty (MatP (CRange i j) (CElem k)) = matrixRowRange ty i j k + extractAPat ty (MatP (CElem i) (CRange j k)) = matrixColRange ty i j k + + -- TODO: Are these type annotations correct? + structAccess ty v = genLoc $ annTyE ty $ FunCall (genLoc $ sfield ty) [ genLoc $ annTyE (varType v) $ Var v ] + vectorAccess ty v = genLoc $ annTyE ty $ FunCall (genLoc $ vind ty) [v] + vectorRange ty v1 v2 = genLoc $ annTyE ty $ FunCall (genLoc $ vrange ty) [v1, v2] + matrixAccess ty v1 v2 = genLoc $ annTyE ty $ FunCall (genLoc $ mind ty) [v1, v2] + matrixRange ty v1 v2 v3 v4 = genLoc $ annTyE ty $ FunCall (genLoc $ mrange ty) + [v1, v2, v3, v4] + matrixColRange ty v1 v2 v3 = genLoc $ annTyE ty $ FunCall (genLoc $ mcolrange ty) + [v1, v2, v3] + matrixRowRange ty v1 v2 v3 = genLoc $ annTyE ty $ FunCall (genLoc $ mrowrange ty) + [v1, v2, v3] +-- +-- +-------------------------------------------------------------------------------- +-- Removes all function and procedure calls due to global variables or +-- structured type accesses. + +variableId :: LExpr Var -> Var +variableId (unLoc -> Var v) = v +variableId _ = error ".: unexpected expr" + +removeLoadStore :: CaoCFG -> CaoCFG +removeLoadStore cfg = cfg { blocks = blks } + where + blks = Map.map (mapFst (concatMap (renameGVars (getWVars cfg) . aux))) (blocks cfg) + aux :: LStmt Var -> [LStmt Var] + aux ss@(unLoc -> FCallS fn _) + | isStoreGlobal fn = [] -- Global variable store + | otherwise = [ss] + aux ss@(unLoc -> Assign lv [unLoc -> TyE tyann (FunCall (unLoc -> fn) args)]) + | isStoreInit fn + = let lvv = lvname $ head lv + ty = varType lvv + in [L (getLoc ss) $ VDecl $ ContD (genLoc lvv) (type2TyDecl ty) args] + | isLoadGlobal fn = [] + | isStoreVar fn + = let fstElem = head args + lastElem = last args + lVal = init $ tail args + in [ L (getLoc ss) $ Assign [restoreLVal fstElem lVal] [lastElem] + , L (getLoc ss) $ Assign lv [fstElem] + ] + | isLoadStruct fn + = [ L (getLoc ss) $ + Assign lv [genLoc $ TyE tyann $ StructProj (head args) + (variableId (unTypL (args!!1)))] ] + | isLoadVar fn + = [ L (getLoc ss) $ + Assign lv [ genLoc $ TyE tyann $ -- TODO: Verify TyE annotations + -- before: (annTy $ queryLVTy $ head lv) + Access (head args) + (VectP (CElem (args!!1))) ] ] + | isLoadVarRange fn + = [ L (getLoc ss) $ + Assign lv [ genLoc $ TyE tyann $ + Access (head args) + (VectP (CRange (args!!1) (args!!2))) ] ] + | isLoadMat fn + = [ L (getLoc ss) $ + Assign lv [ genLoc $ TyE tyann $ + Access (head args) + (MatP (CElem (args!!1)) + (CElem (args!!2))) ] ] + | isLoadMatRange fn + = [ L (getLoc ss) $ + Assign lv [ genLoc $ TyE tyann $ + Access (head args) + (MatP (CRange (args!!1) (args!!2)) + (CRange (args!!3) (args!!4))) ] ] + | isLoadMatRowR fn + = [ L (getLoc ss) $ + Assign lv [ genLoc $ TyE tyann $ + Access (head args) + (MatP (CRange (args!!1) (args!!2)) + (CElem (args!!3))) ] ] + | isLoadMatColR fn + = [ L (getLoc ss) $ + Assign lv [ genLoc $ TyE tyann $ + Access (head args) + (MatP (CElem (args!!1)) + (CRange (args!!2) (args!!3))) ] ] + aux ss + = [ ss ] + + renameGVars :: [Var] -> BasicBlock -> BasicBlock + renameGVars wvars = map (rnGVars wvars) + + rnGVars :: [Var] -> LStmt Var -> LStmt Var + rnGVars wvs (L l s) = L l $ fmap (rnGVars_ wvs) s + + rnGVars_ :: [Var] -> Var -> Var + rnGVars_ wvs v +-- | Just v' <- find ((== varName v) . varName) wvs, Global <- varScope v +-- TODO: Check this function!!! Hack: rename variables except phi functions. + | Just v' <- find ((== varName v) . varName) wvs, Global <- varScope v, not (isPhiFun v) + = v' + | otherwise + = v + +-------------------------------------------------------------------------------- + +restoreLVal :: TLExpr Var -> [TLExpr Var] -> LVal Var +restoreLVal lvar [] = LVVar (L (getLoc lvar) $ variableId $ unTypL lvar) +restoreLVal lvar (x:xs) = aux x + where + lv = restoreLVal lvar xs + aux :: TLExpr Var -> LVal Var + aux (unLoc -> unTyp -> FunCall (unLoc -> n) args) + | isLValSField n = LVStruct lv $ variableId $ unTypL $ head args + | isLValVInd n = LVCont (varType n) lv $ VectP $ CElem $ head args + | isLValVRng n = LVCont (varType n) lv $ VectP $ CRange (head args) + (args!!1) + | isLValMInd n = LVCont (varType n) lv $ MatP (CElem (head args)) + (CElem (args!!1)) + | isLValMRng n = LVCont (varType n) lv $ + MatP (CRange (head args) (args!!1)) + (CRange (args!!2) (args!!3)) + | isLValMColRng n = LVCont (varType n) lv $ + MatP (CElem (head args)) + (CRange (args!!1) (args!!2)) + | isLValMRowRng n = LVCont (varType n) lv $ + MatP (CRange (head args) (args!!1)) + (CElem (args!!2)) + aux _ + = error ".: unexpected case" + + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + + +toSSA :: CaoMonad m => CaoCFG -> m CaoCFG +-- Ignore empty blocks (type and variable definitions) +toSSA cfg | Map.null (blocks cfg) = return cfg + | otherwise = renameVars dt blocks' vars + where + g = graphFromEdges_ $ blocks cfg + dt = genDomTree g + cfg' = introLoadStore cfg + (blocks', vars) = insertPhiFuncs g cfg' + +fromSSA :: CaoCFG -> CaoCFG +fromSSA cfg + | Map.null (blocks cfg) = cfg + | otherwise = BT.fromSSA $ removeSsaDecl $ removeLoadStore cfg diff --git a/src/Language/CAO/Analysis/SsaBack.hs b/src/Language/CAO/Analysis/SsaBack.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Analysis/SsaBack.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} +{- +Module : $Header$ +Description : Translating back from SSA form. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Analysis.SsaBack + ( fromSSA + , introduceDefs + , rmVars + ) where + +import Data.List ( foldl', partition, nubBy, insertBy, minimumBy ) +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Set ( Set ) +import qualified Data.Set as Set + +import Language.CAO.Analysis.CFG +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils +import Language.CAO.Type.Utils + +import Language.CAO.Common.Utils +import Language.CAO.Common.Var +import Language.CAO.Common.SrcLoc + +fromSSA :: CaoCFG -> CaoCFG +fromSSA = introduceDefs . rmVars . coalescePhiFuncs +-- . eliminateInterference +-- +--eliminateInterference :: CaoCFG -> CaoCFG +--eliminateInterference cfg = cfg +-- where liveRanges = undefined +-- +-- interVars :: [Set String] +-- interVars = undefined +-- +-- insertCopies :: Set String -> CaoCFG -> CaoCFG +-- insertCopies = undefined + +-- type Location = (NodeId, Int) +-- type RLoc = Map String Location +-- +-- type LiveIn = Map NodeId (Set String) +-- type LiveOut = Map NodeId (Set String) +-- +-- type PhiCong = Map String (Set String) + + +coalescePhiFuncs :: CaoCFG -> CaoCFG +coalescePhiFuncs cfg = cfg { blocks = coalesceVars phiCong stmtMap } + where + stmtMap :: LocalGraph + stmtMap = blocks cfg + + phiCong :: Map Var (Var, Set Var) + phiCong = Map.fold (\(stmts, _) m -> + foldl' getPhis m stmts) + Map.empty stmtMap + +getPhis :: Map Var (Var, Set Var) + -> LStmt Var + -> Map Var (Var, Set Var) +getPhis m (unLoc -> Assign [LVVar (unLoc -> str)] + [unLoc -> unTyp -> FunCall (unLoc -> fId) args]) + | isPhiFun fId + = fixPhiC m $ str : (Set.toList $ fvs args) +getPhis m _ = m + +fixPhiC :: Map Var (Var, Set Var) + -> [Var] + -> Map Var (Var, Set Var) +fixPhiC m vs = Set.fold (\v -> Map.insert v congr) m congs + where + congs = Set.unions $ map fGetPhiCong vs + congr = (Set.findMin congs, congs) + fGetPhiCong v = maybe (Set.singleton v) snd (Map.lookup v m) + +coalesceVars :: Map Var (Var, Set Var) + -> LocalGraph + -> LocalGraph +coalesceVars cong = Map.map (coalesceVarsStmts rnEnv) + where + rnEnv :: SEnv Var Var + rnEnv = Map.foldWithKey renameF emptyRN cong + + -- All variables in a phi congruence class are renamed to + -- one "representative" element (this case, the head of the list) + renameF :: Var -> (Var, Set Var) -> SEnv Var Var -> SEnv Var Var + renameF v1 (v2, _) b = b +> v1 ~> v2 + +-- XXX: can the order of composition be changed, ie., the filter can be +-- performed before the map? +coalesceVarsStmts :: (SEnv Var Var) + -> (BasicBlock, Connections) + -> (BasicBlock, Connections) +coalesceVarsStmts cong = mapFst (filter (not . isPhi . unLoc) . map (<|> cong)) + where + isPhi :: Stmt Var -> Bool + isPhi (Assign [LVVar _] [unLoc -> unTyp -> FunCall fId _]) + = isPhiFun (unLoc fId) + isPhi _ = False + + +--------------------------------------------------------- +-- TODO: REFACTOR vars <---> except (almost the same def) +--------------------------------------------------------- + +introduceDefs :: CaoCFG -> CaoCFG +introduceDefs cfg = cfg { blocks = addDecls (map mkDecl $ sortDeps neededDefs) blk } +--introduceDefs cfg = addDecls (map mkDecl $ sortDeps neededDefs) cfg + where + blk :: LocalGraph + blk = blocks cfg + + neededDefs :: [Var] + neededDefs = filter isLocal $ Set.toList $ + vars `Set.difference` except + + vars, except, alreadyDef, args :: Set Var + vars = Map.fold foldVars Set.empty blk + except = alreadyDef `Set.union` args + alreadyDef = Map.fold foldDecls Set.empty blk + args = bvs $ definition cfg + + foldDecls :: (BasicBlock, Connections) -> Set Var -> Set Var + foldDecls (stmts, _) s0 = s0 `Set.union` bvs stmts + + foldVars :: (BasicBlock, Connections) -> Set Var -> Set Var + foldVars (stmts, _) s0 = s0 `Set.union` fvs stmts + +--addDecls :: [LStmt Var] -> CaoCFG -> CaoCFG +addDecls :: [LStmt Var] -> LocalGraph -> LocalGraph +addDecls lst = Map.alter fAddDecl (entryNode + 1) + where + fAddDecl :: Maybe (BasicBlock, Connections) + -> Maybe (BasicBlock, Connections) + fAddDecl = fmap (mapFst (lst ++)) + +mkDecl :: Var -> LStmt Var +mkDecl v = genLoc $ VDecl $ VarD (genLoc v) (type2TyDecl $ varType v) Nothing + +sortDeps :: [Var] -> [Var] +sortDeps = sortDeps' Set.empty + where sortDeps' _ [] = [] + sortDeps' ds vs = vs1 ++ sortDeps' (ds `Set.union` Set.fromList vs1) vs2 + where (vs1, vs2) = partition noDeps vs + noDeps v = Set.filter isLocal (fvs $ varType v) + `Set.isSubsetOf` ds + +-------------------------------------------------------------------------------- + +rmVars :: CaoCFG -> CaoCFG +rmVars cfg = CaoCFG { definition = d0, blocks = b0 } + where + rnMap :: SEnv Var Var + rnMap = mkRenameMap $ varRange cfg + + b0 :: LocalGraph + b0 = filterDecls $ Map.map rmAndFilter $ blocks cfg + + rmAndFilter :: (BasicBlock, Connections) -> (BasicBlock, Connections) + rmAndFilter = mapFst (\ stmts -> filter filterAssigns $ stmts <|> rnMap) + + d0 :: LDef Var + d0 = fmap (fmap (<|> rnMap)) (definition cfg) + + filterAssigns :: LStmt Var -> Bool + filterAssigns (unLoc -> Assign [LVVar v] [unLoc -> unTyp -> Var v']) + = unLoc v /= v' + filterAssigns _ + = True + +filterDecls :: LocalGraph -> LocalGraph +filterDecls = Map.map (mapFst nubDecls) + where + nubDecls :: [LStmt Var] -> [LStmt Var] + nubDecls = nubBy eqDecls + + eqDecls :: LStmt Var -> LStmt Var -> Bool + eqDecls (L _ (VDecl v0)) (L _ (VDecl v1)) + = eqVarDecls v0 v1 + eqDecls _ _ + = False + + -- TODO: INCOMPLETE DEFINITION (MAY CAUSE BUGS?) + eqVarDecls :: VarDecl Var -> VarDecl Var -> Bool + eqVarDecls (VarD v0 _ _) (VarD v1 _ _ ) = v0 == v1 + eqVarDecls (MultiD v0 _ ) (MultiD v1 _ ) = v0 == v1 + eqVarDecls (ContD v0 _ _) (ContD v1 _ _) = v0 == v1 + eqVarDecls _ _ = False + +mkRenameMap :: VarRange -> SEnv Var Var +mkRenameMap rng = foldl' (+>) emptyRN $ map mkM gRanges + + where + rnglst :: [(Var, Range)] + rnglst = Map.toList rng + + -- vars grouped same type + gTypes :: [[(Var, Range)]] + gTypes = groupType rnglst + + gRanges :: [[(Var, Range)]] + gRanges = concatMap (accumRanges [] []) gTypes + + mkM :: [(Var, Range)] -> SEnv Var Var + mkM [] = emptyRN + mkM [_] = emptyRN + mkM xs = let (x, _) = minimumBy cmpRng xs + in foldl' (\a (b, _) -> a +> b ~> x) emptyRN (init xs) + + accumRanges :: [(Var, Range)] + -> [(Var, Range)] + -> [(Var, Range)] + -> [[(Var, Range)]] + accumRanges [] acc [] = [acc] + accumRanges orig acc [] = acc:accumRanges [] [] orig + accumRanges orig acc (x:xs) = case mutuallyDisj x acc of + Just lst -> accumRanges orig lst xs + Nothing -> accumRanges (x:orig) acc xs + + mutuallyDisj :: (Var, Range) + -> [(Var, Range)] + -> Maybe [(Var, Range)] + mutuallyDisj l@(v, r0) rg + | not (isContainer (varType v)) && all (disjoint r0 . snd) rg + = Just (l:rg) + | lst <- insertBy cmpRng l rg, chainsSafely lst + = Just lst + | otherwise + = Nothing + + cmpRng :: (Var, Range) -> (Var, Range) -> Ordering + cmpRng (_, FromTo l00 l01 _ _) (_,FromTo l10 l11 _ _) + | l10 `gtLoc` l01 = LT + | l00 `gtLoc` l11 = GT + | otherwise = compare l00 l10 + + chainsSafely :: [(Var, Range)] -> Bool + chainsSafely [] + = True + chainsSafely [_] + = True + chainsSafely ((_, FromTo _ l0 _ _):rest@((_, FromTo l1 _ ab1 _):_)) + = l1 `gtLoc` l0 && ab1 && chainsSafely rest + + groupType :: [(Var, Range)] + -> [[(Var, Range)]] + groupType [] = [] + groupType (x:rest) + = let (st, r) = partition (sameType x) rest + in (x:st):groupType r + + sameType :: (Var, Range) + -> (Var, Range) + -> Bool + sameType (t0, _) (t1, _) + = varType t0 == varType t1 + + disjoint :: Range -> Range -> Bool + disjoint (FromTo l00 l01 _ _) (FromTo l10 l11 _ _) = + l11 `gtLoc` l10 && l01 `gtLoc` l00 && + (l10 `gtLoc` l01 || l00 `gtLoc` l11) + + gtLoc :: Location -> Location -> Bool + gtLoc (n0, loc0) (n1, loc1) + -- Special case when 0 + | n1 == 0 = False + | n0 == 0 = True + -- Lexicographic order + | n0 > n1 = True + | n0 < n1 = False + -- When n1 == n2 + | otherwise = loc0 >= loc1 + +type Location = (NodeId, Int) +data Range = FromTo { _fromL :: Location + , _toL :: Location + , _safeA :: Bool -- safeA is True when the variable is + -- initialized completely in its + -- first assignment + , _safeL :: Bool -- if safeL = True, it is safe to + -- consider >= instead of > to check + -- disjoint live ranges, + } deriving Show +type VarRange = Map Var Range + +-- NOTE: USED ONLY FOR TESTING PURPOSES! +--showVR m = Map.foldWithKey (\k a acc -> showPpr k ++ "\\\\\\" ++ show a ++ "\n" ++ acc) "" m + +varRange :: CaoCFG -> VarRange +varRange cfg = vRange + where + vRange :: VarRange + vRange = Map.filterWithKey (\k _ -> isLocal k && not (k `elem` seqVars)) + gvRange + + gvRange :: VarRange + gvRange = traverseCFG [entryNode + 1] [] argsRange (blocks cfg) + + seqVars :: [Var] + seqVars = getSeqVars cfg + + argsRange :: VarRange + argsRange = Set.fold fArgs Map.empty $ bvs $ definition cfg + + fArgs :: Var -> VarRange -> VarRange + fArgs v m + | nsVar v = Map.insert v (FromTo (entryNode, 0) + (exitNode, 0) + False + False) m + | otherwise = m + +getSeqVars :: CaoCFG -> [Var] +getSeqVars = concatMap doGetSV . concatMap fst . Map.elems . blocks + where + doGetSV (unLoc -> Seq i _) = [seqVar i] + doGetSV _ = [] + +-- NOTE: if a variable is first assigned in node 3, loc 5, but +-- there is a loop back to node 2, its range should be fixed to be from node 2, +-- loc 0: +-- while .. +-- ... x1 +-- ... +-- x1 := ... +-- This should not be a problem, as the first x1 will never be renamed. But +-- we should be careful about this. +traverseCFG :: [NodeId] + -> [NodeId] + -> VarRange + -> LocalGraph + -> VarRange +traverseCFG [] _ m _ + = m +traverseCFG (n:ns) seen m cfg + | n `elem` seen = traverseCFG ns seen m cfg + | otherwise = traverseCFG (ns ++ next) (n:seen) m' cfg + where + blk :: BasicBlock + next :: Connections + (blk, next) = cfg Map.! n + + m' :: VarRange + m' = foldl' updateRanges m nStmts + + nStmts :: [(Location, LStmt Var)] + nStmts = zip [ (n, i) | i <- [1..] ] blk + +updateRanges :: VarRange -> (Location, LStmt Var) -> VarRange +updateRanges rng (lloc,ss@(unLoc -> Assign lvs _)) + | all isSimpleLVal lvs + = fixAssignRng True lvns rvns + | otherwise + = fixAssignRng False lvns rvns + where + fixAssignRng :: Bool -> [Var] -> [Var] -> VarRange + fixAssignRng safe lVars rVars + = let rng' = foldl' (fixLRanges safe lloc) rng lVars + in foldl' (fixRanges safe lloc) rng' rVars + lvns = lvnames ss + rvns = lvns ++ rvnames ss +updateRanges rng (lloc, ss) + = foldl' (fixRanges False lloc) rng (rvnames ss) + +fixLRanges :: Bool -> Location -> VarRange -> Var -> VarRange +fixLRanges b l = flip (Map.alter (updateDefRange b l)) + +fixRanges :: Bool -> Location -> VarRange -> Var -> VarRange +fixRanges b l = flip (Map.alter (updateLastRange b l)) + +updateDefRange :: Bool -> Location -> Maybe Range -> Maybe Range +updateDefRange b loc Nothing = Just (FromTo loc (exitNode, 0) b False) +updateDefRange ab l@(n, loc) mr@(Just (FromTo (n0,l0) loc1 _ b)) + | n0 < n || (n0 == n && l0 < loc) = mr + | otherwise = Just $ FromTo l loc1 ab b + +updateLastRange :: Bool -> Location -> Maybe Range -> Maybe Range +-- If it was not previously used as a lvalue, it should be considered +-- alive along the whole CFG +updateLastRange _ _ Nothing = Just (FromTo (entryNode, 0) + (exitNode , 0) + False + False) +updateLastRange b l@(n,loc) mr@(Just (FromTo loc1 (n0,l0) ab _)) + | n0 > n || (n0 == n && l0 > loc) = mr + | otherwise = Just $ FromTo loc1 l ab b + +-- TODO: REFACTOR IN Language.CAO.Syntax.Utils +lvnames :: LStmt Var -> [Var] +lvnames (unLoc -> Assign lvs _) = map lvname lvs +lvnames _ = [] + +rvnames :: LStmt Var -> [Var] +rvnames (unLoc -> ss@(Assign lvs _)) + = Set.toList rvs + where + vs = fvs ss + vlvs = Set.fromList $ map lvname lvs + rvs = vs Set.\\ vlvs + +rvnames stmt + = Set.toList $ fvs stmt diff --git a/src/Language/CAO/Common/Error.hs b/src/Language/CAO/Common/Error.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/Error.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Module : $Header$ +Description : Functions to handle errors and warnings. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +This module provides error and warning messages, as well as functions to +throw errors. + +-} + +module Language.CAO.Common.Error + ( mkCaoWarningInfo + , WarningCode(..) + , CaoWarning + , mkCaoWarning + , CaoError + , mkCaoError + , ParserException(..) + , ErrorCode(..) + , TypeMismatchException(..) + , DeclException(..) + , CardinalityException(..) + , AssignmentKind(..) + , ScopeKind(..) + , TypeKind(..) + , showCaoError + , showCaoWarnings + , noWarning + , mkUnknownErr + ) where + +import Text.Read +import Control.Monad.Error +import Control.Monad.Writer + +import Language.CAO.Index +import Language.CAO.Type + +import Language.CAO.Common.Outputable ( PP, showPpr ) +import Language.CAO.Common.Polynomial +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +-- CaoWarning ------------------------------------------------------------------ + +data WarningInfo = forall id . PP id + => WarningInfo !SrcLoc !String !(WarningCode id) + +mkCaoWarningInfo :: PP id => SrcLoc -> String -> WarningCode id -> WarningInfo +mkCaoWarningInfo = WarningInfo + +data WarningCode id = + BaseExtensionWarn !(Pol id) + | PolExtensionWarn !(Pol id) + -- | Warnings for transformations/optimizations + | IndistFail id id + | DeadCodeReturn + | NoProverWarning (ICond id) + +showWarningCode :: PP id => WarningCode id -> String +showWarningCode warn = case warn of + BaseExtensionWarn b -> + "Base `" ++ showPpr b ++ "' must be a prime number" + PolExtensionWarn p -> + "Polynomial `" ++ showPpr p ++ "' must be irreducible" + IndistFail i1 i2 -> + "Could not apply side-channel countermeasures: `" + ++ showPpr i1 ++ ", " ++ showPpr i2 + DeadCodeReturn -> + "Removing dead code after return" + NoProverWarning c -> + "Yices prover not available. The following restriction was admitted without proof:\n" ++ showPpr c + +newtype CaoWarning = CaoWarning [WarningInfo] + +mkCaoWarning :: WarningInfo -> CaoWarning +mkCaoWarning i = CaoWarning [i] + +instance Monoid CaoWarning where + mempty = CaoWarning [] + (CaoWarning l) `mappend` (CaoWarning l') = CaoWarning $! l `mappend` l' + +showWarningInfo :: WarningInfo -> String +showWarningInfo (WarningInfo sl fln w) = + fln ++ ":" ++ showPpr sl ++ ":\n" ++ + nestStr 4 ("[Warning] " ++ showWarningCode w) + +showCaoWarnings :: CaoWarning -> String +showCaoWarnings (CaoWarning l) = unlines $ map showWarningInfo l + +noWarning :: CaoWarning -> Bool +noWarning (CaoWarning w) = null w + +-- CaoError -------------------------------------------------------------------- + +data CaoError = forall id . (Show id, Read id, PP id) + => CaoError SrcLoc String (ErrorCode id) + +instance Show CaoError where + show (CaoError loc s e) = + "CaoError " ++ '(': show loc ++ ") " ++ show s ++ " (" ++ show e ++ ")" + +instance Read CaoError where + readsPrec i s = case [ x | (x,"") <- readPrec_to_S (readAsT errcds) i s ] of + [] -> [] + (x:_) -> [(x, "")] + +errcds :: (String, (Name, (Var, ()))) +errcds = undefined + +class ReadAsT t e where + readAsT :: t -> ReadPrec e + +instance ReadAsT () e where + readAsT ~() = mzero + +instance (Read t, Show t, PP t, ReadAsT ts CaoError) + => ReadAsT (t,ts) CaoError where + readAsT ~(t,ts) + = goR t `mplus` readAsT ts + where + goR :: t -> ReadPrec CaoError + goR _ = prec 5 $ do + Ident "CaoError" <- lexP + l <- parens $ step readPrec + s <- step readPrec + cd <- parens $ step readPrec + return $ CaoError l s (cd :: ErrorCode t) + +mkCaoError + :: (Show id, Read id, PP id) + => SrcLoc -> String -> ErrorCode id + -> CaoError +mkCaoError = CaoError + +instance Error CaoError where + noMsg = CaoError defSrcLoc "" + ((UnknownErr "noMsg")::ErrorCode String) + strMsg mstr = CaoError defSrcLoc "" + ((UnknownErr mstr)::ErrorCode String) + +showCaoError :: CaoError -> String +showCaoError (CaoError sl fln e) = + fln ++ ":" ++ showPpr sl ++ ":\n" ++ nestStr 4 (showErrorCode e) + +-- Error Messages -------------------------------------------------------------- + +data ErrorCode id + = IntEvalErr + | TimesMatrixErr + | PowerMatrixErr + | FuncReturnErr + | SeqRangeErr + | LiteralModErr (Mon id) (Type id) + | UnknownLiteralErr (Mon id) + | PolynomialErr (Pol id) + | ExpressionErr id + | NotDefinedCodeErr + | UnknownErr String + | MultipleErr [CaoError] + | StrictModeErr + + | ContainerInitErr + + | NestedModpolErr (Type id) + | NotSupportedTypeErr (Type id) + | NotSupportedOp String (Type id) + | NotSupportedVar String (Type id) + + -- XXX: Not supported is not the best name.... + | NotSupportedIndexTyp + | NotSupportedIndexOp + | NotSupportedIndexLit + + | ParserException ParserException + | ScopeException id ScopeKind + | BadUseException id ScopeKind + | TypeMismatchException (Type id) (Type id) TypeMismatchException + | WrongTypeException (Type id) TypeKind + | SemanticException SemanticException + | DeclException (DeclException id) + | RangeException TypeKind + | CardinalityException CardinalityException + deriving (Show, Read) + +data TypeMismatchException + = CastException + | MatchException + | UnificationException + deriving (Show, Read) + +data ScopeKind + = GenericScope + | IndScope + | VarScope + | TypeScope + | ProcScope + | FuncScope + | IndetScope + | SFieldScope Name + deriving (Show, Read) + +data TypeKind + = AlgebraicType + | ModType + | IntOrModType + | BitsType + | BitsOrVectorType + | VectorType + | MatrixType + | StructType + deriving (Show, Read) + +data SemanticException + = DivByZeroException + | ModDivException + | RemByZeroException + | NegativeExponentException + | VectorAccessException + | MatrixRowAccessException + | MatrixColAccessException + deriving (Show, Read) + +data ParserException + = LexicalException String + | ParsingException String + | EOFException + deriving (Show, Read) + +data DeclException id + = SizeDeclException (IExpr id) (Maybe (IExpr id)) TypeKind + | BaseDeclException (IExpr id) + | MultipleDeclException id + deriving (Show, Read) + +data CardinalityException + = AssignCardinalityException AssignmentKind + | ParamsCardinalityException + | InitCardinalityException TypeKind + deriving (Show, Read) + +data AssignmentKind + = MultipleAssign + | TupleAssign + deriving (Show, Read) + +mkUnknownErr :: String -> ErrorCode String +mkUnknownErr = UnknownErr + +showErrorCode :: PP id => ErrorCode id -> String +showErrorCode err = case err of + IntEvalErr -> + "Expression could not be evaluated during compilation" + TimesMatrixErr -> + "Multiplication only is possible if the number of columns of left matrix\n" ++ + " is the same as the number of rows of right matrix" + PowerMatrixErr -> + "Exponentiation only is possible on square matrices" + FuncReturnErr -> + "Function must return a value" + SeqRangeErr -> + "Invalid bounds or stepping distance in seq statement" + LiteralModErr lit t -> + "Literal `[" ++ showPpr lit ++ "]' is not a valid literal of type `" ++ + showPpr t ++ "'" + UnknownLiteralErr lit -> + "Literal `[" ++ showPpr lit ++ "]' has unknown type" + PolynomialErr pol -> + "Polynomial literal `[" ++ showPpr pol ++ "]' is not in canonical form" + ExpressionErr cmd -> + "Not an expression: `" ++ showPpr cmd ++ "'" + NotDefinedCodeErr -> + "The specification of the current platform does not define type codes" + UnknownErr str -> + "Unexpected error occurred:\n" ++ str + MultipleErr lst -> + unlines $ map showCaoError lst + StrictModeErr -> + "Unexpected declaration on non dependent type checking mode" + + NotSupportedIndexTyp -> + "Not valid index type" + NotSupportedIndexOp -> + "Not supported operations on indexes" + NotSupportedIndexLit -> + "Not supported index literal" + + ContainerInitErr -> + "Initialization with multiple values only is possible for container types" + + NestedModpolErr t -> + "Translation does not support nested polynomial extensions:\n\t`" ++ + showPpr t ++ "'" + NotSupportedTypeErr t -> + "Translation for the current platform does not support the type:\n\t`" ++ + showPpr t ++ "'" + NotSupportedOp op t -> + "Translation for the current platform does not support the operation `" + ++ op ++ "' for type:\n\t`" ++ showPpr t ++ "'" + NotSupportedVar op t -> + "Translation for the current platform does not support variables of type `" + ++ showPpr t ++ "' in operation `" ++ op + ++ "'. Only constants are allowed." + + + ParserException k -> showParserException k + ScopeException a k -> showScopeException a k + BadUseException a k -> showBadUseException a k + TypeMismatchException t1 t2 k -> showTypeMismatchException t1 t2 k + WrongTypeException t k -> showWrongTypeException t k + SemanticException k -> showSemanticException k + DeclException e -> showDeclException e + RangeException k -> showRangeException k + CardinalityException e -> showCardinalityException e + +showParserException :: ParserException -> String +showParserException k = case k of + LexicalException s -> + "Lexical error at character '" ++ s ++ "'" + ParsingException tok -> + "Parse error on input `" ++ tok ++ "'" + EOFException -> + "Parse error at end of input" + +showScopeKind :: ScopeKind -> String +showScopeKind k = case k of + GenericScope -> "" + VarScope -> "variable" + IndScope -> "index" + FuncScope -> "function" + ProcScope -> "procedure" + TypeScope -> "type or struct" + IndetScope -> "indeterminate" + SFieldScope s -> "field of struct `" ++ showPpr s ++ "'" + +showTypeMismatchException :: PP id => Type id -> Type id -> TypeMismatchException -> String +showTypeMismatchException it et kind = case kind of + CastException -> + "Couldn't cast inferred type `" ++ showPpr it ++ "'\n" ++ + " to casting type `" ++ showPpr et ++ "'" + MatchException -> + "Couldn't match expected type `" ++ showPpr et ++ "'\n" ++ + " against inferred type `" ++ showPpr it ++ "'" + UnificationException -> + "Couldn't unify type `" ++ showPpr it ++ "'\n" ++ + " with type `" ++ showPpr et ++ "'" + +showScopeException :: PP id => id -> ScopeKind -> String +showScopeException v kind = "Symbol not found in current scope: " + ++ showScopeKind kind ++ " `" ++ showPpr v ++ "'" + +showBadUseException :: PP id => id -> ScopeKind -> String +showBadUseException v kind = + "Bad use of " ++ showScopeKind kind ++ " `" ++ showPpr v ++ "'" + +showWrongTypeException :: PP id => Type id -> TypeKind -> String +showWrongTypeException t kind = + "Couldn't match expected " ++ showTypeKind kind ++ " type\n" ++ + " against inferred type `" ++ showPpr t ++ "'" + +showTypeKind :: TypeKind -> String +showTypeKind k = case k of + AlgebraicType -> "algebraic" + ModType -> "mod" + IntOrModType -> "int or mod" + BitsType -> "bits" + BitsOrVectorType -> "bits or vector" + VectorType -> "vector" + MatrixType -> "matrix" + StructType -> "struct" + +showSemanticException :: SemanticException -> String +showSemanticException k = case k of + VectorAccessException -> + "Invalid index in vector selection" + MatrixRowAccessException -> + "Invalid row index in matrix selection" + MatrixColAccessException -> + "Invalid column index in matrix selection" + DivByZeroException -> + "Invalid division by zero" + NegativeExponentException -> + "Negative exponent" + ModDivException -> + "Invalid mod division" + RemByZeroException -> + "Invalid remainder by zero" + +showDeclException :: PP id => DeclException id -> String +showDeclException e = case e of + SizeDeclException i mi k -> + "Invalid size [" ++ + showPpr i ++ maybe "" ((", " ++) . showPpr) mi ++ + "] in " ++ showTypeKind k ++ " type declaration" + BaseDeclException i -> + "Invalid modulus `" ++ showPpr i ++ "' in mod type declaration" + MultipleDeclException v -> + "Multiple declarations of `" ++ showPpr v ++ "'" + +showRangeException :: TypeKind -> String +showRangeException kind = + "Invalid range in " ++ showTypeKind kind ++ " selection" + +showCardinalityException :: CardinalityException -> String +showCardinalityException e = case e of + AssignCardinalityException k -> + "The number of left values does not match the number of right " ++ showAssignmentKind k + ParamsCardinalityException -> + "Invalid number of parameters" + InitCardinalityException k -> + "Initialization doesn't match " ++ showTypeKind k ++ "dimension" + where + showAssignmentKind k = case k of + MultipleAssign -> "expresions" + TupleAssign -> " values returned by the function" diff --git a/src/Language/CAO/Common/Fresh.hs b/src/Language/CAO/Common/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/Fresh.hs @@ -0,0 +1,70 @@ + +{-# LANGUAGE FlexibleContexts #-} +{- +Module : $Header$ +Description : Generation of new simbols. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Common.Fresh + ( freshVar -- Indist, Simplify, Target + , freshVar' -- PreC + , freshSFld -- PreC + , freshTmpVar -- Target, PreC, C + , freshIndex -- Simplify + , freshSmb -- C, PreC + ) where + +import Language.CAO.Common.Monad +import Language.CAO.Common.State +import Language.CAO.Common.Var + +import Language.CAO.Type + +freshSmb :: CaoM e w s m => m (Int, String) +freshSmb = do + i <- uniqId + return (i, 't' : show i) + +freshVar :: CaoM e w s m => Scope -> Type Var -> m Var +freshVar s t = do + (i, n) <- freshSmb + return $ mkVar s (mkVarName n) i t + where + mkVar Global = mkGId + mkVar Local = mkLId + +freshVar' :: CaoM e w s m => Scope -> String -> Type Var -> m Var +freshVar' s n t = do + i <- uniqId + return $ mkVar s (mkVarName n) i t + where + mkVar Global = mkGId + mkVar Local = mkLId + +freshSFld :: CaoM e w s m => String -> Type Var -> m Var +freshSFld n t = do + i <- uniqId + return $ mkGId (mkVarName n) i t + +freshIndex :: CaoM e w s m => Scope -> Type Var -> m Var +freshIndex s t = do + (i, n) <- freshSmb + return $ mkVar s (mkVarName n) i t Nothing + where + mkVar Global = mkGConst + mkVar Local = mkLConst + +-- Temporary variables obtained using this function, +-- should be stored in the temporary variable pool after +-- being used. +freshTmpVar :: CaoM e w CaoState m => Type Var -> m Var +freshTmpVar typ = tmpFromPool typ >>= + maybe (freshVar Local typ) return + diff --git a/src/Language/CAO/Common/Literal.hs b/src/Language/CAO/Common/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/Literal.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} + +{- +Module : $Header$ +Description : CAO language literals +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Common.Literal where + +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) + +import Language.CAO.Common.Outputable +import Language.CAO.Common.Representation +import Language.CAO.Common.Polynomial + +import Language.CAO.Semantics.Bits (bitsToString) + +-- | Bit strings are stored in the reversed order. +data Literal id + -- | Boolean literals + = BLit !Bool + -- | Integer literals + | ILit !Integer + -- | Bit strings + | BSLit !Sign ![Bool] + -- | Polynomial literals + | PLit !(Pol id) + deriving (Show, Read, Functor, Foldable, Traversable, Eq, Ord) + +instance PP id => PP (Literal id) where + ppr = pprLit + +pprLit :: PP id => Literal id -> CDoc +pprLit (BLit True) = text "true" +pprLit (BLit False) = text "false" +pprLit (ILit i) = integer i +pprLit (BSLit sig s) = text (signPrefix sig) <> text (bitsToString s) +pprLit (PLit p) = brackets $ ppr p + +instance PP id => StringRepresentation (Literal id) where + toString (ILit i) = intString i + toString (PLit p) = toString p + toString l = showPpr l + +-------------------------------------------------------------------------------- +-- | Signal of a bit string +data Sign + = U -- ^ Unsigned + | S -- ^ Signed + deriving (Show, Read, Eq, Ord) + +instance PP Sign where + ppr U = text "unsigned" + ppr S = text "signed" + +signPrefix :: Sign -> String +signPrefix s = case s of + U -> "0b" + S -> "1b" diff --git a/src/Language/CAO/Common/Monad.hs b/src/Language/CAO/Common/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/Monad.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} + +{- | +Module : $Header$ +Description : General application monad. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +General application monad. + +-} + +module Language.CAO.Common.Monad + ( CaoMonad + , CaoM(..) + , CaoResult + , CaoState + , getFileName + , setFileName + , runCaoResultWarn + , tcError + , tcWarn + , ensureDepMode + , caoOrCalf + , withStrictMode + ) where + +import Control.Applicative ( (<$>) ) + +import Control.Arrow ( first ) + +import Control.Monad.Error +import Control.Monad.State.Strict +import Control.Monad.Writer.Strict + +import Language.CAO.Common.Error +import Language.CAO.Common.Outputable +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.State +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Main.Flags (RunMode(..)) + +class CaoM CaoError CaoWarning CaoState m => CaoMonad m where +instance CaoM CaoError CaoWarning CaoState m => CaoMonad m where + +class (Functor m, Monad m, MonadIO m, MonadError e m, MonadWriter w m, MonadState s m) => + CaoM e w s m where + uniqId :: m Int + injectResult :: Either String a -> m a + caoError :: (Show id, Read id, PP id) + => SrcLoc -> ErrorCode id -> m a + caoWarning :: PP id => SrcLoc -> WarningCode id -> m () + +-------------------------------------------------------------------------------- + +newtype CaoResult a + = CaoResult { runCaoResult :: + CaoState -> IO ( Either CaoError + (a, CaoWarning) + , CaoState) } + +instance CaoM CaoError CaoWarning CaoState CaoResult where + injectResult = either (throwError . read) return + uniqId = getLastVar + caoError info code = do + fnm <- getFileName + throwError $ mkCaoError info fnm code + caoWarning info msg = do + fnm <- getFileName + tell $ mkCaoWarning $ mkCaoWarningInfo info fnm msg + +instance Functor CaoResult where + fmap f (CaoResult m) = CaoResult $! \ st -> first (either Left (Right . first f)) <$> m st + +instance Monad CaoResult where + return !x = CaoResult $! \ st -> return (Right (x, mempty), st) + (>>=) = bindTcMonad + +{-# INLINE bindTcMonad #-} +{-# INLINE bindTcMonad2 #-} +bindTcMonad :: CaoResult a + -> (a -> CaoResult b) + -> CaoResult b +bindTcMonad m f = CaoResult $! \ st -> do + (x', st') <- runCaoResult m st + bindTcMonad2 x' (st', f) + +bindTcMonad2 :: Either CaoError (a, CaoWarning) + -> (CaoState, a -> CaoResult b) + -> IO (Either CaoError (b, CaoWarning), CaoState) +bindTcMonad2 (Left !e) (!st',_) = + return (Left e, st') +bindTcMonad2 (Right (!r, !w)) (!st', f) = do + liftM (mapFst (fixR w)) $ runCaoResult (f r) st' + where + fixR _ !l@(Left _) = l + fixR !w' (Right (!x, !w'')) = Right (x, w' `mappend` w'') + +instance MonadIO CaoResult where + liftIO m = CaoResult $! \ st -> do + r <- m + return (Right (r, mempty), st) + +instance MonadState CaoState CaoResult where + get = CaoResult $! \ st -> return (Right (st, mempty), st) + put !st = CaoResult $! \ _ -> return (Right ((), mempty), st) + +instance MonadWriter CaoWarning CaoResult where + tell !w = CaoResult $! \ st -> return (Right ((), w), st) + listen m = CaoResult $! liftM (mapFst fixW) . runCaoResult m + where + fixW :: Either CaoError (a, CaoWarning) + -> Either CaoError ((a,CaoWarning), CaoWarning) + fixW (Left !e) = Left e + fixW (Right (!a, !w)) = Right ((a, w), w) + + pass m = CaoResult $! liftM (mapFst fixW) . runCaoResult m + where + fixW :: Either CaoError ((a, CaoWarning -> CaoWarning), CaoWarning) + -> Either CaoError (a, CaoWarning) + fixW (Left !e) = Left e + fixW (Right ((!a, f), !w)) = Right (a, f w) + +instance MonadError CaoError CaoResult where + throwError !e = CaoResult $! \ st -> return (Left e, st) + catchError m f = CaoResult $! go f <=< runCaoResult m + where + go :: (CaoError -> CaoResult a) + -> (Either CaoError (a, CaoWarning), CaoState) + -> IO (Either CaoError (a, CaoWarning), CaoState) + go c (Left e, st) = runCaoResult (c e) st + go _ x = return x + +runCaoResultT :: CaoResult a -> IO (Either CaoError (a, CaoWarning)) +runCaoResultT m = liftM fst $ runCaoResult m initialState + +runCaoResultWarn :: CaoResult a -> IO (a, CaoWarning) +runCaoResultWarn = either (fail . showCaoError) return <=< runCaoResultT + +-------------------------------------------------------------------------------- + +tcError :: (CaoMonad m, PP id, Show id, Read id) => ErrorCode id -> m a +tcError err = do + loc <- getSrcLoc + caoError loc err + +tcWarn :: (CaoMonad m, PP id) => WarningCode id -> m () +tcWarn msg = do + loc <- getSrcLoc + caoWarning loc msg + +ensureDepMode :: CaoMonad m => m a -> m a +ensureDepMode t = do + m <- getMode + case m of + CAO -> tcError (StrictModeErr :: ErrorCode Var) + CAO_Strict -> tcError (StrictModeErr :: ErrorCode Var) + _ -> t + +caoOrCalf :: CaoMonad m => m a -> m a -> m a +caoOrCalf cao calf = do + m <- getMode + case m of + CAO -> cao + CAO_Strict -> cao + _ -> calf + +withStrictMode :: CaoMonad m => m a -> m a -> m a +withStrictMode tstrict tnstrict = do + m <- getMode + case m of + CAO_Strict -> tstrict + CALF_Strict -> tstrict + _ -> tnstrict + diff --git a/src/Language/CAO/Common/Name.hs b/src/Language/CAO/Common/Name.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/Name.hs @@ -0,0 +1,118 @@ +{- +Module : $Header$ +Description : Variable names +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable () + +Variables +-} + +module Language.CAO.Common.Name + ( + -- * Names + Name + , NameSpace + , IsName (..) + + --, hashName + , nameStr + , setNameStr + , getNS + + , mkName + , prefix + + -- * Constructing Names + , mkVarName, mkFunName, mkTvName + , mkPolIndName, mkStructFldName + + , isVarName, isFunName, isTvName + , isPolIndName, isStructFldName + + ) where + +import Language.CAO.Common.Outputable + +-- | A Name appearing in CAO code +-- +data Name = Name !NameSpace + !String + deriving (Show, Read) + +class IsName a where + varName :: a -> Name + +instance IsName Name where + varName = id + +mkName :: NameSpace -> String -> Name +mkName = Name + +nameStr :: Name -> String +nameStr (Name _ s) = s + +setNameStr :: String -> Name -> Name +setNameStr s (Name ns _) = Name ns s + +prefix :: String -> Name -> Name +prefix s (Name ns s1) = Name ns (s ++ s1) + +getNS :: Name -> NameSpace +getNS (Name ns _) = ns + +instance Eq Name where + Name _ s1 == Name _ s2 = s1 == s2 + +instance Ord Name where + compare (Name _ s1) (Name _ s2) = s1 `compare` s2 + +instance PP Name where + ppr (Name sp n) = text n + <> ifPprDebug (text "##Kind=" <> text (show sp)) + +-- | NameSpace for different kinds of 'Name' +-- +data NameSpace + = Variable -- ^ CAO variable names + | StructFld -- ^ Struct fields + | FunName -- ^ Function names + | PolInd -- ^ Polynomial ind + | TvName -- ^ Type synonyms or structs + deriving (Eq, Ord, Show, Read) + +mkVarName :: String -> Name +mkVarName = Name Variable + +mkFunName :: String -> Name +mkFunName = Name FunName + +mkTvName :: String -> Name +mkTvName = Name TvName + +mkPolIndName :: String -> Name +mkPolIndName = Name PolInd + +mkStructFldName :: String -> Name +mkStructFldName = Name StructFld + +isVarName, isStructFldName, isPolIndName + , isTvName , isFunName :: Name -> Bool + +isVarName (Name Variable _) = True +isVarName _ = False + +isFunName (Name FunName _) = True +isFunName _ = False + +isTvName (Name TvName _) = True +isTvName _ = False + +isPolIndName (Name PolInd _) = True +isPolIndName _ = False + +isStructFldName (Name StructFld _) = True +isStructFldName _ = False diff --git a/src/Language/CAO/Common/Operator.hs b/src/Language/CAO/Common/Operator.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/Operator.hs @@ -0,0 +1,98 @@ + +{- +Module : $Header$ +Description : Operatators +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable () + +-} + +module Language.CAO.Common.Operator + ( Operator(..) + , Fixity(..) + , Assoc(..) + , pprParens_ + , pprParensR_ + , pprParensL_ + , wrapIfPrec + ) where + +import Language.CAO.Common.Outputable + +data Fixity = Infix | Prefix | Nofix | Postfix +data Assoc = ALeft | ARight | NoAssoc + +class Operator o where + isSimple :: o -> Bool + assoc :: o -> Assoc + fixity :: o -> Fixity + prec :: o -> Int + +pprParens_ :: (PP o, Operator o, Operator o') => o -> o' -> CDoc +pprParens_ e ctx + | sameAssoc e ctx = ppr e + | otherwise = wrapIfPrec (prec ctx) e + +pprParensR_ :: (PP o, Operator o, Operator o') => o -> o' -> CDoc +pprParensR_ e ctx + | isPostfix e = ppr e + | isInfixR e + && isInfixR ctx + && prec e == prec ctx = ppr e + | otherwise = wrapIfPrec (prec ctx) e + +pprParensL_ :: (PP o, Operator o, Operator o') => o -> o' -> CDoc +pprParensL_ e ctx + | isPostfix e = ppr e + | isInfixL e + && isInfixL ctx + && prec e == prec ctx = ppr e + | otherwise = wrapIfPrec (prec ctx) e + +wrapIfPrec :: (PP o, Operator o) => Int -> o -> CDoc +wrapIfPrec oprec e + | prec e > oprec = ppr e + | otherwise = parens (ppr e) + +sameAssoc :: (Operator o, Operator o') => o -> o' -> Bool +sameAssoc e0 e1 + | isSimple e0 = isSimple e1 + | isPrefix e0 = isPrefix e1 + | isPostfix e0 = isPostfix e1 + | isInfixL e0 = isInfixL e1 + | isInfixR e0 = isInfixR e1 + | otherwise = False + +isInfix :: Operator o => o -> Bool +isInfix o = case fixity o of + Infix -> True + _ -> False + +isInfixL :: Operator o => o -> Bool +isInfixL o = isInfix o && isAssocL + where + isAssocL = case assoc o of + ALeft -> True + _ -> False + +isInfixR :: Operator o => o -> Bool +isInfixR o = isInfix o && isAssocR + where + isAssocR = case assoc o of + ARight -> True + _ -> False + +isPrefix :: Operator o => o -> Bool +isPrefix o = case fixity o of + Prefix -> True + _ -> False + +isPostfix :: Operator o => o -> Bool +isPostfix o = case fixity o of + Postfix -> True + _ -> False + diff --git a/src/Language/CAO/Common/Outputable.hs b/src/Language/CAO/Common/Outputable.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/Outputable.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{- +Module : $Header$ +Description : Typeclass for pretty printing +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +CAO 'PP' class based on the GHC Outputable typeclass +-} + +module Language.CAO.Common.Outputable + ( + -- * PP Class + PP(..) + + , mppr + , pprElems + + -- * Configurable Doc Type + , CDoc + , docToCDoc + + -- * Show CDoc + , showCDoc, showCDocDebug, showCDocIds + , showPpr, showPprDebug, showPprIds + + -- * Conditional pretty printing + , ifPprDebug, ifPprIds + , noPprDebug + + -- * Values to CDoc + , char, text, int, integer, float, double, rational + + -- * Simple derived CDocs + , semi, comma, colon, space, equals + , lparen, rparen, lbrack, rbrack, lbrace, rbrace + + -- * Wrapping CDocs in delimiters + , parens, brackets, braces, quotes, doubleQuotes + + -- * Combining CDocs + , empty, (<>), (<+>), ($$), ($+$) + , sep, cat, hsep, hcat, vsep, vcat, fsep, fcat + , nest, hang, punctuate + + -- * Predicates on CDocs + , isEmpty + ) where + +import Text.PrettyPrint ( Doc ) +import qualified Text.PrettyPrint as Pretty + +type CDoc = PprCfg -> Doc + +showCDoc :: CDoc -> String +showCDoc d = show (d PprCode) + +showCDocDebug :: CDoc -> String +showCDocDebug d = show (d PprDebug) + +showCDocIds :: CDoc -> String +showCDocIds d = show (d PprIds) + +data PprCfg + = PprCode -- Pretty printing code + | PprIds -- Pretty print variable ids + | PprDebug -- Full verbose pretty printing + +ifPprDebug :: CDoc -> CDoc +ifPprDebug d sty@PprDebug = d sty +ifPprDebug _ _ = Pretty.empty + +ifPprIds :: CDoc -> CDoc +ifPprIds d sty@PprIds = d sty +ifPprIds _ _ = Pretty.empty + +noPprDebug :: CDoc -> CDoc +noPprDebug d0 PprDebug = d0 PprCode +noPprDebug d0 sty = d0 sty + +class PP a where + ppr :: a -> CDoc + +showPpr :: PP a => a -> String +showPpr = showCDoc . ppr + +showPprDebug :: PP a => a -> String +showPprDebug = showCDocDebug . ppr + +showPprIds :: PP a => a -> String +showPprIds = showCDocIds . ppr + +instance PP Doc where + ppr a _sty = a + +instance PP Integer where + ppr i = integer i + +instance PP Int where + ppr i = int i + +instance PP Char where + ppr i = char i + +instance PP a => PP (Maybe a) where + ppr Nothing = text "Nothing" + ppr (Just a) = text "Just" <+> ppr a + +mppr :: PP a => Maybe a -> CDoc +mppr Nothing = empty +mppr (Just a) = ppr a + +instance PP String where + ppr xs = text xs + +instance PP a => PP [a] where + ppr xs = brackets (pprElems xs) + +pprElems :: PP a => [a] -> CDoc +pprElems xs = fsep (punctuate comma (map ppr xs)) + +instance (PP a, PP b) => PP (a, b) where + ppr (a, b) = parens (ppr a <> comma <+> ppr b) + +instance (PP a, PP b, PP c) => PP (a, b, c) where + ppr (a, b, c) = parens $ ppr a <> comma <+> ppr b <> comma <+> ppr c + +docToCDoc :: Doc -> CDoc +docToCDoc d = \_ -> d + +char :: Char -> CDoc +char c _sty = Pretty.char c + +text :: String -> CDoc +text s _sty = Pretty.text s + +int :: Int -> CDoc +int n _sty = Pretty.int n + +integer :: Integer -> CDoc +integer n _sty = Pretty.integer n + +float :: Float -> CDoc +float n _sty = Pretty.float n + +double :: Double -> CDoc +double n _sty = Pretty.double n + +rational :: Rational -> CDoc +rational n _sty = Pretty.rational n + + +semi :: CDoc +semi _sty = Pretty.semi + +comma :: CDoc +comma _sty = Pretty.comma + +colon :: CDoc +colon _sty = Pretty.colon + +space :: CDoc +space _sty = Pretty.space + +equals :: CDoc +equals _sty = Pretty.equals + +lparen :: CDoc +lparen _sty = Pretty.lparen + +rparen :: CDoc +rparen _sty = Pretty.rparen + +lbrack :: CDoc +lbrack _sty = Pretty.lbrack + +rbrack :: CDoc +rbrack _sty = Pretty.rbrack + +lbrace :: CDoc +lbrace _sty = Pretty.lbrace + +rbrace :: CDoc +rbrace _sty = Pretty.rbrace + +parens :: CDoc -> CDoc +parens p sty = Pretty.parens (p sty) + +brackets :: CDoc -> CDoc +brackets p sty = Pretty.brackets (p sty) + +braces :: CDoc -> CDoc +braces p sty = Pretty.braces (p sty) + +quotes :: CDoc -> CDoc +quotes p sty = Pretty.quotes (p sty) + +doubleQuotes :: CDoc -> CDoc +doubleQuotes p sty = Pretty.doubleQuotes (p sty) + +empty :: CDoc +empty _sty = Pretty.empty + +(<>) :: CDoc -> CDoc -> CDoc +d1 <> d2 = \sty -> d1 sty Pretty.<> d2 sty + +(<+>) :: CDoc -> CDoc -> CDoc +d1 <+> d2 = \sty -> d1 sty Pretty.<+> d2 sty + +hcat :: [CDoc] -> CDoc +hcat ds sty = Pretty.hcat [d sty | d <- ds] + +hsep :: [CDoc] -> CDoc +hsep ds sty = Pretty.hsep [d sty | d <- ds] + +($$) :: CDoc -> CDoc -> CDoc +d1 $$ d2 = \sty -> d1 sty Pretty.$$ d2 sty + +($+$) :: CDoc -> CDoc -> CDoc +d1 $+$ d2 = \sty -> d1 sty Pretty.$+$ d2 sty + +vcat :: [CDoc] -> CDoc +vcat ds sty = Pretty.vcat [d sty | d <- ds] + +vsep :: [CDoc] -> CDoc +vsep ds = foldr ($+$) empty ds + +sep :: [CDoc] -> CDoc +sep ds sty = Pretty.sep [d sty | d <- ds] + +cat :: [CDoc] -> CDoc +cat ds sty = Pretty.cat [d sty | d <- ds] + +fsep :: [CDoc] -> CDoc +fsep ds sty = Pretty.fsep [d sty | d <- ds] + +fcat :: [CDoc] -> CDoc +fcat ds sty = Pretty.fcat [d sty | d <- ds] + +nest :: Int -> CDoc -> CDoc +nest n d sty = Pretty.nest n (d sty) + +hang :: CDoc -> Int -> CDoc -> CDoc +hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty) + +punctuate :: CDoc -> [CDoc] -> [CDoc] +punctuate _ [] = [] +punctuate p (doc:docs) = go doc docs + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es + +isEmpty :: CDoc -> Bool +isEmpty d = Pretty.isEmpty (d PprCode) + diff --git a/src/Language/CAO/Common/Polynomial.hs b/src/Language/CAO/Common/Polynomial.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/Polynomial.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{- +Module : $Header$ +Description : CAO Polynomials +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable () + +CAO Polynomials +-} +module Language.CAO.Common.Polynomial where + +import Data.Foldable (Foldable) +import Data.List (intersperse, intercalate) +import Data.Maybe (catMaybes) +import Data.Traversable (Traversable) + +import Language.CAO.Common.Outputable +import Language.CAO.Common.Representation +import Language.CAO.Common.Utils + +import Language.CAO.Index + + +newtype Pol id = Pol { monomials :: [Mon id] } + deriving (Show, Read, Functor, Foldable, Traversable, Eq, Ord) + +instance PP id => PP (Pol id) where + ppr = hsep . intersperse (char '+') . map ppr . monomials + +instance PP id => StringRepresentation (Pol id) where + toString = intercalate "_" . map toString . monomials + +------------------------- +-- Building polynomials +------------------------- + +infixl 6 .+. +infixl 7 .*. +infixl 8 .^. + +mon :: Mon id -> Pol id +mon (Mon (CoefP p) EZero) = p +mon m = Pol [m] + +intC :: Integer -> MCoef id +intC i = CoefI (IInt i) + +polC :: Pol id -> MCoef id +polC = CoefP + +(.+.) :: Mon id -> Pol id -> Pol id +m .+. (Pol ms) = Pol (ms ++ [m]) + +(.*.) :: MCoef id -> MBase id -> Mon id +c .*. b = Mon c b + +(.^.) :: id -> Integer -> MBase id +_ .^. 0 = EZero +n .^. i = MExpI n i + +data Mon id = Mon !(MCoef id) !(MBase id) + deriving (Show, Read, Functor, Foldable, Traversable, Eq, Ord) + +instance PP id => PP (Mon id) where + ppr = pprMon + +pprMon :: PP id => Mon id -> CDoc +pprMon (Mon c EZero) + = ppr c +pprMon (Mon (CoefI (IInt 1)) b) + = ppr b +pprMon (Mon c b) + = ppr c <> char '*' <> ppr b + +instance PP id => StringRepresentation (Mon id) where + toString = monStrRepresentation + +monStrRepresentation :: PP id => Mon id -> String +monStrRepresentation m = + case m of + Mon (CoefI (IInt 1)) (MExpI i 1) -> showPpr i + Mon (CoefI (IInt c)) EZero -> intString c + Mon (CoefI c) EZero -> showPpr c + Mon (CoefI (IInt 1)) (MExpI i e) -> showPpr i ++ "_" ++ intString e + Mon (CoefI (IInt c)) (MExpI i 1) -> intString c ++ "_" ++ showPpr i + Mon (CoefI c) (MExpI i 1) -> showPpr c ++ "_" ++ showPpr i + Mon (CoefI (IInt c)) (MExpI i e) -> intString c ++ "_" ++ showPpr i ++ "_" ++ intString e + Mon (CoefI c) (MExpI i e) -> showPpr c ++ "_" ++ showPpr i ++ "_" ++ intString e + Mon (CoefP p) EZero -> "_" ++ toString p ++ "_" + Mon (CoefP p) (MExpI i 1) -> "_" ++ toString p ++ "_" ++ showPpr i + Mon (CoefP p) (MExpI i e) -> "_" ++ toString p ++ "_" ++ showPpr i ++ "_" ++ intString e + +data MCoef id + = CoefI !(IExpr id) + | CoefP !(Pol id) + deriving (Show, Read, Functor, Foldable, Traversable, Eq) + +instance Ord id => Ord (MCoef id) where + CoefI (IInt i) <= CoefI (IInt i') = i <= i' + CoefI _ <= CoefI _ = error "<>: non literal" + CoefP p <= CoefP p' = p <= p' + CoefI _ <= CoefP _ = True + _ <= _ = False + +instance PP id => PP (MCoef id) where + ppr = pprMCoef + +pprMCoef :: PP id => MCoef id -> CDoc +pprMCoef (CoefI i) + = ppr i +pprMCoef (CoefP pol) + = parens (ppr pol) + +data MBase id + = EZero + | MExpI id Integer -- XXX: Symbolic exponent?? + deriving (Show, Read, Functor, Foldable, Traversable, Eq, Ord) + +instance PP id => PP (MBase id) where + ppr = pprMBase + +pprMBase :: PP id => MBase id -> CDoc +pprMBase EZero = empty +pprMBase (MExpI n 1) = ppr n +pprMBase (MExpI n e) = ppr n <> text "**" <> integer e + +-- * Auxiliary functions +-- XXX: Consider moving this to another module +degree :: Pol id -> Integer +degree (Pol []) = 0 +degree (Pol ms) = maximum $ map polExp ms + where + polExp (Mon _ EZero) = 0 + polExp (Mon _ (MExpI _ e)) = e + +neg :: Mon id -> Mon id +neg (Mon (CoefI (IInt i)) e) = Mon (CoefI (IInt (-i))) e +neg (Mon (CoefI i) e) = Mon (CoefI (ISym i)) e +neg (Mon (CoefP (Pol p)) e) = Mon (CoefP $ Pol $ map neg p) e + +coeficiente :: Mon id -> Pol id +coeficiente (Mon (CoefI c) _) = Pol [Mon (CoefI c) EZero] +coeficiente (Mon (CoefP p) _) = p + +getMonVar :: Mon id -> Maybe id +getMonVar (Mon _ EZero) = Nothing +getMonVar (Mon _ (MExpI n _)) = Just n + +getMonExp :: Mon id -> Integer +getMonExp (Mon _ EZero) = 0 +getMonExp (Mon _ (MExpI _ e)) = e + +polyToMono :: Maybe id -> Pol id -> Integer -> Maybe (Mon id) +polyToMono _ (Pol [Mon (CoefI (IInt 0)) EZero]) _ = Nothing +polyToMono (Just i) (Pol [Mon (CoefI c) EZero]) e = + Just $ Mon (CoefI c) (MExpI i e) +polyToMono (Just i) p e = + Just $ Mon (CoefP p) (MExpI i e) +polyToMono _ _ _ = error "::\ + \ unexpected input" + +normMonos :: [Maybe (Mon id)] -> [Mon id] +normMonos = ifM null (const [Mon (CoefI (IInt 0)) EZero]) reverse . catMaybes + +isValid :: Eq id => [Mon id] -> Bool +isValid (m:ms) = checkPol_ (getMonVar m) (m:ms) +isValid _ = False + +checkPol_ :: Eq id => Maybe id -> [Mon id] -> Bool +checkPol_ ind [m] + = (getMonVar m == Nothing && getMonExp m == 0) || getMonVar m == ind +checkPol_ ind (m1:m0:ms) + = (getMonExp m1 > getMonExp m0) + && (getMonVar m1 == ind) + && checkMon_ m1 + && checkPol_ ind (m0:ms) +checkPol_ _ _ = error ":: \ + \ unexpected empty list of monomials" + +checkMon_ :: Eq id => Mon id -> Bool +checkMon_ (Mon (CoefI _) _) = True +checkMon_ (Mon (CoefP p) _) = isValid (monomials p) + diff --git a/src/Language/CAO/Common/Representation.hs b/src/Language/CAO/Common/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/Representation.hs @@ -0,0 +1,24 @@ + +{- +Module : $Header$ +Description : String representations. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} +module Language.CAO.Common.Representation where + +import Language.CAO.Common.Utils + +class StringRepresentation a where + toString :: a -> String + +intString :: Integer -> String +intString = ifM (>= 0) show (("neg_" ++) . show . negate) + +sep :: Char +sep = '_' diff --git a/src/Language/CAO/Common/SrcLoc.hs b/src/Language/CAO/Common/SrcLoc.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/SrcLoc.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{- +Module : $Header$ +Description : Source Location +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable () + +Source location +-} + +module Language.CAO.Common.SrcLoc + ( -- * Source Location (point) + SrcLoc + -- * SrcLoc construction + , srcLoc + , defSrcLoc + , unkSrcLoc + , genSrcLoc + -- * Located Type + , Located(..) + -- * Located Construction + , noLoc + , genLoc + -- * Located Destruction + , getLoc + , unLoc + , mapML + ) where + +import Control.Monad + +import Data.Foldable +import Data.Traversable + +import Language.CAO.Common.Outputable + +-- | Source location +-- +data SrcLoc + -- | Normal Source location line:col - offset + = SrcLoc !Int -- line number + !Int -- column number + !Int -- offset + -- | General information + | UnhelpfulLoc String + deriving (Show, Read, Eq) + +instance PP SrcLoc where + ppr (SrcLoc ln cn _o) = int ln <> char ':' <> int cn + ppr (UnhelpfulLoc txt) = text txt + +-- | Create a 'SrcLoc' +-- +{-# INLINE srcLoc #-} +srcLoc :: Int -> Int -> Int -> SrcLoc +srcLoc = SrcLoc + +-- | Create default 'SrcLoc' +-- +defSrcLoc :: SrcLoc +defSrcLoc = UnhelpfulLoc "" + +-- | Create unknown 'SrcLoc' +-- +{-# INLINE unkSrcLoc #-} +unkSrcLoc :: SrcLoc +unkSrcLoc = defSrcLoc + +-- | Create generated 'SrcLoc' +-- +genSrcLoc :: SrcLoc +genSrcLoc = UnhelpfulLoc "" + + +-- | Located element +-- +data Located e = L SrcLoc e + deriving (Show, Read, Eq, Foldable, Traversable) + +instance Functor Located where + fmap f (L l a) = L l (f a) + +instance PP e => PP (Located e) where + ppr (L _ e) = ppr e + +-- | "Unlocated" element +-- +{-# INLINE noLoc #-} +noLoc :: e -> Located e +noLoc = L unkSrcLoc + +-- | "Unlocated" element +-- +{-# INLINE genLoc #-} +genLoc :: e -> Located e +genLoc = L genSrcLoc + +-- | Get 'SrcLoc' from 'Located' +-- +{-# INLINE getLoc #-} +getLoc :: Located e -> SrcLoc +getLoc (L loc _) = loc + +-- | Get element in 'Located' +-- +{-# INLINE unLoc #-} +unLoc :: Located e -> e +unLoc (L _ e) = e + +{-# INLINE mapML #-} +mapML :: Monad m => (a -> m b) -> Located a -> m (Located b) +mapML f (L loc e) = liftM (L loc) $ f e + diff --git a/src/Language/CAO/Common/State.hs b/src/Language/CAO/Common/State.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/State.hs @@ -0,0 +1,455 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +{- +Module : $Header$ +Description : Compiler global state. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +Compiler global state. +-} + +module Language.CAO.Common.State + ( CaoState + + , getLastVar + + , tmpFromPool + + , fileName + + , withTcST + , keepScope + , keepState + , keepGScope + , withSrcLoc + , setSrcLoc + , getSrcLoc + , getHeap + , putHeap + , updateHeap + , addHypothesis + , getHypothesis + , getsTcS + , getMode + , setMode + , setYices + , getYices + , newUniq + , nextTyVarId + + , reTypVar -- Simplify + , lookupReTypVar -- Simplify + , withSimplifyST + , resetSimplifyST + + , allConsts -- Target + , getConst -- Target + , withTargetST + , resetTargetST + + , putFieldProj -- PreC + , putFunType -- PreC + , getFunType -- PreC + , putRetStruct -- PreC + , getRetStruct -- PreC + , setRefVar -- PreC + , getRefVar -- PreC + , lookupFieldProj -- PreC + , withPreCST + , resetPreCST + + , getAllocVars -- C + , getAllAllocVars -- C + , storeAllocVar -- C + , withCST + , resetCST + , allocScope + + , initialState -- Monad, Main/CAO + , lastVar -- SSA, Monad, MonadState CaoState m => + , getFileName -- Monad, Parser, C + , setFileName -- Monad, Interpreter, MonadState CaoState m => , Main/CAO + , getTmpVars -- Monad, Target, C, PreC + , storeTmpVar -- Indist, Target, C, PreC + ) where + +import Control.Monad.State.Strict + +import qualified Data.List as List +import Data.IntMap (IntMap) +import qualified Data.IntMap as IMap +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Maybe (fromJust) + +import Language.CAO.Common.Literal +import Language.CAO.Common.Outputable +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.Representation +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Language.CAO.Index +import Language.CAO.Index.Eval + +import Language.CAO.Type + +import Language.CAO.Typechecker.Heap + +import Main.Flags (RunMode(..)) + +data CaoState = CaoState + { fileName :: !String + , lastVar :: {-# UNPACK #-} !Int -- Last generated variable identifier + , mode :: !RunMode + , yicesSMT :: Maybe FilePath + + , tmpVars :: [Var] + , tcst :: (Maybe TcS) + , simplifyST :: (Maybe SimplifyST) + , targetST :: (Maybe TargetST) + , precST :: (Maybe PreCST) + , cst :: (Maybe CST) + } + +initialState :: CaoState +initialState = CaoState + { fileName = "" + , lastVar = iNIT_VAR_ID + , mode = CAO + , yicesSMT = Nothing + , tmpVars = [] + , tcst = Nothing + , simplifyST = Nothing + , targetST = Nothing + , precST = Nothing + , cst = Nothing + } + +setFileName :: MonadState CaoState m => String -> m () +setFileName fn = modify $! \s -> s { fileName = fn } + +getFileName :: MonadState CaoState m => m String +getFileName = gets fileName + +getLastVar :: MonadState CaoState m => m Int +getLastVar = do + s <- get + let i = lastVar s + put $! s { lastVar = i + 1 } + return i + +setMode :: MonadState CaoState m => RunMode -> m () +setMode m = modify $! \ st -> st { mode = m } + +getMode :: MonadState CaoState m => m RunMode +getMode = gets mode + +setYices :: MonadState CaoState m => Maybe FilePath -> m () +setYices y = modify $ \st -> st { yicesSMT = y } + +getYices :: MonadState CaoState m => m (Maybe FilePath) +getYices = gets yicesSMT + +-------------------------------------------------------------------------------- + +storeTmpVar :: MonadState CaoState m => Var -> m () +storeTmpVar lvar = modify (\ s -> s { tmpVars = lvar : tmpVars s } ) + +tmpFromPool :: MonadState CaoState m => Type Var -> m (Maybe Var) +tmpFromPool typ = do + s <- get + let pool = tmpVars s + (v, pool') = findAndDelete ((== typ) . varType) pool + put $ s { tmpVars = pool' } + return v + +getTmpVars :: MonadState CaoState m => m [Var] +getTmpVars = gets tmpVars + +-------------------------------------------------------------------------------- +data TcS + = TcS { curLoc :: !SrcLoc + , heap :: {-# UNPACK #-} !Heap + } + +emptyTcS :: TcS +emptyTcS + = TcS { curLoc = unkSrcLoc + , heap = emptyHeap + } + +withTcST :: MonadState CaoState m => m a -> m a +withTcST m = do + modify ( \ s -> s { tcst = Just emptyTcS } ) + r <- m + modify ( \ s -> s { tcst = Nothing } ) + return r + +getsTcS :: MonadState CaoState m => (TcS -> a) -> m a +getsTcS f = liftM (f . fromJust) (gets tcst) + +modifyTcS :: MonadState CaoState m => (TcS -> TcS) -> m () +modifyTcS f = modify (\ st -> st { tcst = fmap f (tcst st) } ) + +withSrcLoc :: MonadState CaoState m => SrcLoc -> m a -> m a +withSrcLoc loc m = do + st0 <- get + let tc0 = fromJust $ tcst st0 + oldLoc = curLoc tc0 + put $! st0 { tcst = Just $ tc0 { curLoc = loc } } + r <- m + st1 <- get + let tc1 = fromJust $ tcst st1 + put $! st1 { tcst = Just $ tc1 { curLoc = oldLoc } } + return r + +{-# INLINE getSrcLoc #-} +getSrcLoc :: MonadState CaoState m => m SrcLoc +getSrcLoc = getsTcS curLoc + +setSrcLoc :: MonadState CaoState m => SrcLoc -> m () +setSrcLoc loc = modifyTcS (\ st -> st { curLoc = loc }) + +{-# INLINE nextTyVarId #-} +nextTyVarId :: MonadState CaoState m => m TyVarId +nextTyVarId = getLastVar + +{-# INLINE newUniq #-} +newUniq :: MonadState CaoState m => m Int +newUniq = getLastVar + +keepScope :: MonadState CaoState m => m a -> m a +keepScope m = do + h <- getHeap + r <- m + putHeap h + return r + +keepState :: MonadState CaoState m => m a -> m a +keepState m = do + st <- get + r <- m + put $! st + return r + +keepGScope :: MonadState CaoState m => m a -> m a +keepGScope m = do + h <- getHeap + r <- m + updateHeap ( replaceGlobalHeap h ) + return r + +-------------------------------------------------------------------------------- +-- Heap +-------------------------------------------------------------------------------- + +{-# INLINE getHeap #-} +getHeap :: MonadState CaoState m => m Heap +getHeap = getsTcS heap + +putHeap :: MonadState CaoState m => Heap -> m () +putHeap h = modifyTcS (\ st -> st { heap = h }) + +updateHeap :: MonadState CaoState m => (Heap -> Heap) -> m () +updateHeap f = modifyTcS ( \ st -> st { heap = f (heap st) } ) + +-------------------------------------------------------------------------------- +-- XXX: What if introducing false hypothesis? +-- XXX: consider removing evalCond. Add it as pre-condition? +addHypothesis :: MonadState CaoState m => [ICond Var] -> m () +addHypothesis i = modifyTcS (\ st -> st { heap = addHyp (heap st) (map evalCond i) } ) + +getHypothesis :: MonadState CaoState m => m [ICond Var] +getHypothesis = liftM getHyp getHeap + +-------------------------------------------------------------------------------- +-- Simplify + +newtype SimplifyST = SimplifyST { reTypVars :: IntMap Var } + +emptySimplifyST :: SimplifyST +emptySimplifyST = SimplifyST IMap.empty + +withSimplifyST :: MonadState CaoState m => m a -> m a +withSimplifyST m = do + modify ( \ s -> s { simplifyST = Just emptySimplifyST } ) + r <- m + modify ( \ s -> s { simplifyST = Nothing } ) + return r + +resetSimplifyST :: MonadState CaoState m => m () +resetSimplifyST = modify (\ s -> s { simplifyST = Just emptySimplifyST } ) + +reTypVar :: MonadState CaoState m => Var -> m () +reTypVar v = modify (\ s -> s { simplifyST = fmap aux (simplifyST s) } ) + where + aux sst = sst { reTypVars = IMap.insert (varId v) v (reTypVars sst) } + +lookupReTypVar :: MonadState CaoState m => Var -> m (Maybe Var) +lookupReTypVar v = liftM (IMap.lookup (varId v) . reTypVars . fromJust) (gets simplifyST) + +-------------------------------------------------------------------------------- +-- Target + +newtype TargetST = TargetST + -- Constants to allow for global declaration and reuse of constants + { consts :: Map (Literal Var) [Var] } + +emptyTargetST :: TargetST +emptyTargetST = TargetST Map.empty + +withTargetST :: MonadState CaoState m => m a -> m a +withTargetST m = do + modify ( \ s -> s { targetST = Just emptyTargetST } ) + r <- m + modify ( \ s -> s { targetST = Nothing } ) + return r + +resetTargetST :: MonadState CaoState m => m () +resetTargetST = modify ( \ s -> s { tmpVars = [] } ) + +getsConst :: MonadState CaoState m => m (Map (Literal Var) [Var]) +getsConst = liftM (consts . fromJust) $ gets targetST + +allConsts :: MonadState CaoState m => m [(Var, Literal Var)] +allConsts = liftM (concat . map (uncurry zip . mapSnd repeat) . map swap . Map.assocs) $ getsConst + +-- Kind of hash function for literals +-- TODO: mods can be dependent types. This means that some unification instead of +-- equality may be needed. +getConst :: MonadState CaoState m => Type Var -> Literal Var -> m Var +getConst ty lit = do + cm <- getsConst + maybe (aux cm) (litExists cm) (Map.lookup lit cm) + where + litExists cm = maybe (aux cm) return . List.find ((ty ==) . varType) + + aux cm = do + u <- getLastVar + let litV = mkGConst (mkVarName $ "const_" ++ showTy ty ++ toString lit) u ty c + modify (\s -> s { targetST = Just $ TargetST $ Map.insertWith (++) lit [litV] cm } ) + return litV + + c = case lit of + ILit n -> Just $ IInt n + _ -> Nothing + +-- TODO: missing cases +showTy :: PP a => Type a -> String +showTy Int = "int_" +showTy RInt = "rint_" +showTy Bool = "bool_" +showTy (Bits U (IInt n)) = "ubits" ++ show n ++ "_" +showTy (Bits S (IInt n)) = "sbits" ++ show n ++ "_" +showTy _ = "" + +-------------------------------------------------------------------------------- +-- PreC + +data PreCST = PreCST + { fieldProj :: [(Var, Integer)] + , refVar :: (Maybe Var) + , funType :: (Map.Map Var (Type Var)) + , retStruct :: (Maybe Var) + } + +emptyPreCST :: PreCST +emptyPreCST = PreCST [] Nothing Map.empty Nothing + +withPreCST :: MonadState CaoState m => m a -> m a +withPreCST m = do + modify ( \ s -> s { precST = Just emptyPreCST } ) + r <- m + modify ( \ s -> s { precST = Nothing } ) + return r + +resetPreCST :: MonadState CaoState m => m () +resetPreCST = do + modify ( \ s -> s { tmpVars = [] } ) + modifyPreCST ( \ p -> p { refVar = Nothing, retStruct = Nothing } ) + +modifyPreCST :: MonadState CaoState m => (PreCST -> PreCST) -> m () +modifyPreCST f = modify ( \ s -> s { precST = fmap f ( precST s ) } ) + +putFieldProj :: MonadState CaoState m => (Var, Integer) -> m () +putFieldProj (v,i) = modifyPreCST (\ s -> s { fieldProj = (v',i) : fieldProj s } ) + where + SField _ ty = varType v + v' = setType ty v + +{-# INLINE getsPreCST #-} +getsPreCST :: MonadState CaoState m => (PreCST -> a) -> m a +getsPreCST f = liftM (f . fromJust) $ gets precST + +lookupFieldProj :: MonadState CaoState m => Var -> m (Maybe Integer) +lookupFieldProj v = liftM (lookup v) $ getsPreCST fieldProj + +getRefVar :: MonadState CaoState m => m (Maybe Var) +getRefVar = getsPreCST refVar + +setRefVar :: MonadState CaoState m => Var -> m () +setRefVar str = modifyPreCST (\ s -> s { refVar = Just str }) + +putFunType :: MonadState CaoState m => Var -> Type Var -> m () +putFunType f tf = modifyPreCST $ \ s -> s { funType = Map.insert f tf (funType s) } + +getFunType :: MonadState CaoState m => Var -> m (Maybe (Type Var)) +getFunType v = liftM (Map.lookup v) $ getsPreCST funType + +putRetStruct :: MonadState CaoState m => Var -> m () +putRetStruct ts = modifyPreCST $ \ s -> s { retStruct = Just ts } + +getRetStruct :: MonadState CaoState m => m (Maybe Var) +getRetStruct = getsPreCST retStruct + + +-------------------------------------------------------------------------------- +-- C + +newtype CST = CST { allocVars :: [[Var]] } + +emptyCST :: CST +emptyCST = CST [[]] + +withCST :: MonadState CaoState m => m a -> m a +withCST m = do + modify ( \ s -> s { cst = Just emptyCST } ) + r <- m + modify ( \ s -> s { cst = Nothing } ) + return r + +resetCST :: MonadState CaoState m => m () +resetCST = modify ( \ s -> s + { tmpVars = [] + , cst = Just emptyCST + } ) + +modifyCST :: MonadState CaoState m => (CST -> CST) -> m () +modifyCST f = modify ( \ s -> s { cst = fmap f ( cst s ) } ) + +storeAllocVar :: MonadState CaoState m => Var -> m () +storeAllocVar v = modifyCST (\ c -> c { allocVars = aux (allocVars c) }) + where + aux (h : t) = (v : h) : t + aux _ = error "" + +getAllocVars :: MonadState CaoState m => m [Var] +getAllocVars = liftM (head . allocVars . fromJust) (gets cst) + +getAllAllocVars :: MonadState CaoState m => m [Var] +getAllAllocVars = liftM (concat . allocVars . fromJust) (gets cst) + +allocScope :: MonadState CaoState m => m a -> m a +allocScope m = do + modifyCST (\ c -> c { allocVars = [] : allocVars c } ) + r <- m + modifyCST (\ c -> c { allocVars = tail (allocVars c) } ) + return r diff --git a/src/Language/CAO/Common/Utils.hs b/src/Language/CAO/Common/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/Utils.hs @@ -0,0 +1,271 @@ + +{- | +Module : $Header$ +Description : Useful functions used in other modules. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : portable + +Useful functions used in other modules. +-} + +module Language.CAO.Common.Utils where + +import Control.Monad +import Data.DList (DList) +import qualified Data.DList as DL + +import Data.List ( + genericIndex, genericTake, genericDrop, genericSplitAt, elemIndex, foldl') +import Data.Maybe (fromMaybe) + +{-# INLINE singleton #-} +singleton :: a -> [a] +singleton = (:[]) + +{-# INLINE split #-} +split :: (a -> b) -> (a -> c) -> a -> (b, c) +split f g a = (f a, g a) + +{-# INLINE mapPair #-} +mapPair :: (a -> b) -> (c -> d) -> (a,c) -> (b, d) +mapPair f g (a, c) = (f a, g c) + +{-# INLINE mapFst #-} +mapFst :: (a -> b) -> (a, c) -> (b, c) +mapFst f = mapPair f id + +{-# INLINE mapSnd #-} +mapSnd :: (c -> d) -> (a, c) -> (a, d) +mapSnd = mapPair id + +{-# INLINE swap #-} +swap :: (a, b) -> (b, a) +swap (a, b) = (b, a) + +swaps :: [(a, (b, c))] -> [(b, a, c)] +swaps = map (\ (a, (b, c)) -> (b, a, c)) + +initLast :: [a] -> ([a], a) +initLast [] = error ": unexpected emtpy case" +initLast [x] = ([], x) +initLast (x:xs) = let + (i, l) = initLast xs + in (x:i, l) + +(.$.) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +(f .$. g) a b = f (g a b) + +apM :: Monad m => m (a -> b) -> a -> m b +apM f a = f >>= \ f' -> return $ f' a + + +{-# INLINE mapAndUnzip3M #-} +mapAndUnzip3M :: (Monad m) => (a -> m (b, c, d)) -> [a] -> m ([b], [c], [d]) +mapAndUnzip3M f xs = fold3M f (:) (:) (:) ([], [], []) xs + +{-# INLINE concatMapM #-} +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f = foldMM f (++) [] + +{-# INLINE concatMapAndUnzipM #-} +concatMapAndUnzipM :: Monad m => (a -> m ([b], [c])) -> [a] -> m ([b], [c]) +concatMapAndUnzipM f = fold2M f (++) (++) ([], []) + +{-# INLINE concatMapAndUnzip3M #-} +concatMapAndUnzip3M :: (Monad m) => (a -> m ([b], [c], [d])) -> [a] -> m ([b], [c], [d]) +concatMapAndUnzip3M f = fold3M f (++) (++) (++) ([], [], []) + +{-# INLINE concatMapAndUnzip4M #-} +concatMapAndUnzip4M :: (Monad m) => (a -> m ([b], [c], [d], [e])) -> [a] -> m ([b], [c], [d], [e]) +concatMapAndUnzip4M f = fold4M f (++) (++) (++) (++) ([], [], [], []) + +{-# INLINE concatMapAndUnzip3MD #-} +concatMapAndUnzip3MD :: (Monad m) => (a -> m (DL.DList b, DL.DList c, DL.DList d)) -> [a] -> m (DL.DList b, DL.DList c, DL.DList d) +concatMapAndUnzip3MD f = fold3M f (DL.append) (DL.append) (DL.append) (DL.empty, DL.empty, DL.empty) + +{-# INLINE concatMapAndUnzip3MD' #-} +concatMapAndUnzip3MD' :: (Monad m) => (a -> m (DL.DList b, DL.DList c, DL.DList d)) -> [a] -> m (DL.DList b, DL.DList c, DL.DList d) +concatMapAndUnzip3MD' f = fold3M' f (DL.append) (DL.append) (DL.append) (DL.empty, DL.empty, DL.empty) + +{-# INLINE concatMapAndUnzip4MD #-} +concatMapAndUnzip4MD :: (Monad m) => (a -> m (DL.DList b, DL.DList c, DL.DList d, DL.DList e)) -> [a] -> m (DL.DList b, DL.DList c, DL.DList d, DL.DList e) +concatMapAndUnzip4MD f = fold4M f (DL.append) (DL.append) (DL.append) (DL.append) (DL.empty, DL.empty, DL.empty, DL.empty) + +{-# INLINE concatMap2M #-} +concatMap2M :: Monad m => (a -> m (b, [c])) -> [a] -> m ([b], [c]) +concatMap2M f = fold2M f (:) (++) ([], []) + +{-# INLINE concatMap3M #-} +concatMap3M :: Monad m => (a -> m (b, [c], [d])) -> [a] -> m ([b], [c], [d]) +concatMap3M f = fold3M f (:) (++) (++) ([], [], []) + +crush3 :: [(a, [b], [c])] -> ([a], [b], [c]) +crush3 lst = let + c1 = map (\ (x, _, _) -> x) lst + c2 = concatMap (\ (_, x, _) -> x) lst + c3 = concatMap (\ (_, _, x) -> x) lst + in (c1, c2, c3) + +crush3D :: [(DList a, DList b, DList c)] -> (DList a, DList b, DList c) +crush3D = foldl' worker (DL.empty, DL.empty, DL.empty) + where + worker (a, b, c) (dla, dlb, dlc) = + (dla `DL.append` a, dlb `DL.append` b, dlc `DL.append` c) + +crush2 :: [(a, [b])] -> ([a], [b]) +crush2 lst = let + c1 = map fst lst + c2 = concatMap snd lst + in (c1, c2) + +zipWithAndUnzipM :: Monad m => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) +zipWithAndUnzipM f l1 l2 = liftM unzip $ zipWithM f l1 l2 + +zipWithAndUnzip3M :: Monad m => (a -> b -> m (c, d, e)) -> [a] -> [b] -> m ([c], [d], [e]) +zipWithAndUnzip3M f l1 l2 = liftM unzip3 $ zipWithM f l1 l2 + +zipWithSeq :: (Integer -> a -> b) -> [a] -> [b] +zipWithSeq f = zipWith f [0..] + +zipWithSeqM :: Monad m => (Integer -> a -> m b) -> [a] -> m [b] +zipWithSeqM f = zipWithM f [0..] + +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a],[a]) +partitionM p = foldr worker (return ([], [])) + where + worker x = liftM2 select (p x) + where + select b ~(ts,fs) = if b + then (x:ts,fs) + else (ts, x:fs) + +foldMM :: Monad m => (a -> m b') -> (b' -> b -> b) -> b -> [a] -> m b +foldMM f op z = worker + where + worker [] = return z + worker (x:xs) = liftM2 op (f x) (worker xs) + +foldMM' :: Monad m => (a -> m b') -> (b' -> b -> b) -> b -> [a] -> m b +foldMM' f op z = foldM worker z + where + worker b a = liftM2 op (f a) (return b) + +fold2M :: Monad m => (a -> m (r1', r2')) + -> (r1' -> r1 -> r1) + -> (r2' -> r2 -> r2) + -> (r1, r2) -> [a] -> m (r1, r2) +fold2M f op1 op2 = foldMM f op + where + op (r1', r2') (r1, r2) = (r1' `op1` r1, r2' `op2` r2) + +fold2M' :: Monad m => (a -> m (r1', r2')) + -> (r1' -> r1 -> r1) + -> (r2' -> r2 -> r2) + -> (r1, r2) -> [a] -> m (r1, r2) +fold2M' f op1 op2 = foldMM' f op + where + op (r1', r2') (r1, r2) = (r1' `op1` r1, r2' `op2` r2) + +fold3M :: Monad m => (a -> m (r1', r2', r3')) + -> (r1' -> r1 -> r1) + -> (r2' -> r2 -> r2) + -> (r3' -> r3 -> r3) + -> (r1, r2, r3) -> [a] -> m (r1, r2, r3) +fold3M f op1 op2 op3 = foldMM f op + where + op (r1', r2', r3') (r1, r2, r3) = (r1' `op1` r1, r2' `op2` r2, r3' `op3` r3) + +fold3M' :: Monad m => (a -> m (r1', r2', r3')) + -> (r1' -> r1 -> r1) + -> (r2' -> r2 -> r2) + -> (r3' -> r3 -> r3) + -> (r1, r2, r3) -> [a] -> m (r1, r2, r3) +fold3M' f op1 op2 op3 = foldMM' f op + where + op (r1', r2', r3') (r1, r2, r3) = (r1' `op1` r1, r2' `op2` r2, r3' `op3` r3) + +fold4M :: Monad m => (a -> m (r1', r2', r3', r4')) + -> (r1' -> r1 -> r1) + -> (r2' -> r2 -> r2) + -> (r3' -> r3 -> r3) + -> (r4' -> r4 -> r4) + -> (r1, r2, r3, r4) -> [a] -> m (r1, r2, r3, r4) +fold4M f op1 op2 op3 op4 = foldMM f op + where + op (r1', r2', r3', r4') (r1, r2, r3, r4) = (r1' `op1` r1, r2' `op2` r2, r3' `op3` r3, r4' `op4` r4) + +fold4M' :: Monad m => (a -> m (r1', r2', r3', r4')) + -> (r1' -> r1 -> r1) + -> (r2' -> r2 -> r2) + -> (r3' -> r3 -> r3) + -> (r4' -> r4 -> r4) + -> (r1, r2, r3, r4) -> [a] -> m (r1, r2, r3, r4) +fold4M' f op1 op2 op3 op4 = foldMM' f op + where + op (r1', r2', r3', r4') (r1, r2, r3, r4) = (r1' `op1` r1, r2' `op2` r2, r3' `op3` r3, r4' `op4` r4) + +mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) +mapMaybeM _ Nothing = return Nothing +mapMaybeM f (Just v) = liftM Just $ f v + +joinJust :: Maybe a -> Maybe b -> Maybe (a, b) +joinJust (Just a) (Just b) = Just (a, b) +joinJust Nothing Nothing = Nothing +joinJust _ _ = error "joinJust: unexpected case" + +consMaybe :: Maybe a -> [a] -> [a] +consMaybe Nothing l = l +consMaybe (Just e) l = e : l + +if' :: Bool -> (a -> b) -> (a -> b) -> a -> b +if' b f g x = if b then f x else g x + +ifM :: (a -> Bool) -> (a -> b) -> (a -> b) -> a -> b +ifM bf f g x = if bf x then f x else g x + +findAndDelete :: (a -> Bool) -> [a] -> (Maybe a, [a]) +findAndDelete _ [] = (Nothing, []) +findAndDelete p (x:xs) = if p x then (Just x, xs) else let + (r, xs') = findAndDelete p xs + in (r, x : xs') + +-- Returns the n-th element of a list +at :: Integer -> [a] -> a +at = flip genericIndex + +-- Returns the range between n-th and m-th elements of a list +range :: Integer -> Integer -> [a] -> [a] +range n m = genericDrop n . genericTake (m+1) + +-- Finds the position of x in a list +getPos :: (Eq a) => a -> [a] -> Integer +getPos x = toInteger . fromMaybe (error ".: Unexpected case") . elemIndex x + +-- Changes the n-th element of a list +putAt :: Integer -> a -> [a] -> [a] +putAt n x l = genericTake n l ++ [x] ++ genericDrop (n+1) l + +-- XXX: check this +replaceAt :: Int -> a -> [a] -> [a] +replaceAt pos val lst = let + (pref, suff) = splitAt pos lst + in pref ++ val : tail suff + +-- Changes the n-th to m-th elements of a list +putRange :: Integer -> Integer -> [a] -> [a] -> [a] +putRange n m xs l = genericTake n l ++ xs ++ genericDrop (m+1) l + +-- Split a list at regular intervals +chunk :: Integer -> [a] -> [[a]] +chunk _ [] = [] +chunk n xs = let (y, ys) = genericSplitAt n xs in y : chunk n ys + + +-- Auxiliary functions --------------------------------------------------------- + +nestStr :: Int -> String -> String +nestStr n = unlines . map (replicate n ' ' ++) . lines diff --git a/src/Language/CAO/Common/Var.hs b/src/Language/CAO/Common/Var.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Common/Var.hs @@ -0,0 +1,891 @@ +{- +Module : $Header$ +Description : Variables +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable () + +Variables +-} + +module Language.CAO.Common.Var + ( module Language.CAO.Common.Name + + -- * Names + , Var + , varType + , varId + , varScope + + , VarUniq + , Scope (..) + , iNIT_VAR_ID + + -- Create variables + , mkLId + , mkGId + + , mkLConst + , mkGConst + + , globalInit + , isGlobalInit + + , getSymbol + -- Modify variable + , setId + , setType + , setIndConst + , setName + , setSymbol + + -- Query namespaces + , nsVar + , nsStructFld + , nsPolInd + , nsTyVar + , nsFunName + + , isProcVar + , isLocal + , isGlobal + , isGlobalVar + , isNotExternal + + -- Consts + , indVar + , indConst + + -- Vars used in SSA + -- Create Ssa Var + , mkPhiFunVar + , mkStoreInit + , mkLoadGlobal + , mkStoreGlobal + + , storeVar + , loadStruct + , loadVar + , loadVarRng + , loadMatrix + , loadMatrixRng + , loadMatrixColRng + , loadMatrixRowRng + , ssaDecl + , sfield + , vind + , vrange + , mind + , mrange + , mcolrange + , mrowrange + + , isPhiFun + , isStoreVar + , isStoreGlobal + , isStoreInit + , isSsaDecl + , isLoadGlobal + , isLoadStruct + , isLoadVar + , isLoadVarRange + , isLoadMat + , isLoadMatRange + , isLoadMatRowR + , isLoadMatColR + + , isLValSField + , isLValVInd + , isLValVRng + , isLValMInd + , isLValMRng + , isLValMColRng + , isLValMRowRng + -- C Function + , getTName + , getOpName + , isCFunction + , isCRef + , isCGlobalRef + , isCRefCall + , isCStruct + , isCCast + , isCAssign + , isCComp + , cCast + , cGlobalRef + , mkCRef + , mkCStruct + , cFun + ) where + +import Language.CAO.Type +import Language.CAO.Type.Utils + +import Language.CAO.Index + +import Language.CAO.Common.Name +import Language.CAO.Platform.Naming +import Language.CAO.Common.Outputable + +-- | An AST Variable +-- A variable in the CAO AST is any identifier which is not a keyword. +-- +data Var + = Var { -- | @vname@ field, of type 'Name'. A 'Name' is just a string symbol + -- of a 'NameSpace' (CAO variables, function symbols, + -- struct fields, ...) + vname :: !Name + -- | @vuniq@, a 'VarUniq', or unique identifier. + , vuniq :: !VarUniq + -- | @vkind@ of type 'VarKind' is an annotation for the different + -- kinds of variables. + , vkind :: !VarKind + } + deriving (Show, Read) + +-- | Datatype representing different kinds of variables. +-- Those kinds of variables are normal variables, constants, +-- and special variables used in intermediate stages of the +-- compiler. +data VarKind + -- | A normal CAO identifier. + = VarId { -- | The 'Type' of the identifier. + vtype :: !(Type Var) + -- | @vscope@ of type 'Scope'. An identifier can be of scope + -- @Local@ or @Global@. Function names and struct fields + -- can only have 'Global' scope. + , vscope :: !Scope + } + -- | CAO constant. + | ConstId { -- | @vtype@. 'Type' of the constant. + vtype :: !(Type Var) + -- | @vconst@. The expression of type 'IExpr' defining the + -- constant. + , vconst :: !(Maybe (IExpr Var)) + -- | @vscope@. The 'Scope' of the constant. Local or Global. + , vscope :: !Scope + } + -- | Special variables for SSA: phi function, load/store, ... + | SsaVar { -- | The 'SVKind' represents the kind of special SSA variable. + -- Load/store, phi function, matrix/vector access, ... + _vkind :: !SVKind + } + -- | Special variable for C function names + | CVar { -- | @vtype@. The CAO 'Type' of the function name. + vtype :: !(Type Var) + -- | @opname@. The code of the function. Used for + -- generating the C code. + , opname :: !OpCode + -- | @tname@. The string symbol of the type. Used for + -- generating the C code. + , tname :: !String + -- | A 'CKind', or the kind of special variable. + , _ckind :: !CKind + } + deriving (Show, Read) + +-- | SSA Variable Kind. +data SVKind + = PhiFun -- ^ Phi function. + | LoadF LK -- ^ Load. 'LK' is the kind of specific Load. + | StoreF SK -- ^ Store. 'SK' is the kind of specific Store. + | AccessF (Type Var) AK -- ^ Access to a value in a container. The two + -- arguments are the 'Type' of the value being + -- accessed and the kind of specific access function + -- 'AK'. + | DeclF -- ^ Declaration functions. Should be removed in SsaBack + -- They are used only to mark a variable declaration. + -- TODO: maybe no longer needed. + deriving (Show, Read) + +-- | Load kind. +data LK + -- | Load global variable. + = LGlobal + -- | Load struct. + | LStruct + -- | Load vector value. + | LVect + -- | Load vector range. + | LVectRng + -- | Load matrix value. + | LMat + -- | Load matrix row and column range. + | LMatRng + -- | Load matrix row range. + | LMatRRng + -- | Load matrix column range. + | LMatCRng + deriving (Show, Read) + +-- | Kind of store functions. +data SK + -- | Store global variable. + = SGlobal + -- | Store variable. + | SVar + -- | Store variable initialization. + | SInit + deriving (Show, Read) + + +-- | Access kind. +data AK + -- | Access struct field. + = ASField + -- | Access vector value. + | AVInd + -- | Access vector range. + | AVRng + -- | Access matrix value. + | AMInd + -- | Access matrix row and column range. + | AMRng + -- | Access matrix column range. + | AMColRng + -- | Access matrix row range. + | AMRowRng + deriving (Show, Read) + +-- | Kind of special C variable. +data CKind + -- | A C function. + = CFun + -- | A C ref. + | CRef + -- | A C struct. + | CStruct + deriving (Show, Read) + +instance PP SVKind where + ppr PhiFun = text "phi" + ppr (LoadF _) = text "load" + ppr (StoreF _) = text "store" + ppr (AccessF _ ak) = text "access" <+> ppr ak + ppr DeclF = text "ssa_decl" + +instance PP AK where + ppr ASField = text "sfield" + ppr AVInd = text "var" + ppr AVRng = text "varrange" + ppr AMInd = text "mind" + ppr AMRng = text "mrange" + ppr AMColRng = text "mcolrange" + ppr AMRowRng = text "mrowrange" + +instance PP CKind where + ppr CFun = text "cfun" + ppr CRef = text "cref" + ppr CStruct = text "cstruct" + +instance IsName Var where + varName = vname + +-- | A unique identifier is a synonym to integer. +type VarUniq = Int + +-- | @iNIT_VAR_ID@ is the initial identifier. Values below 1000 are reserved as +-- identifiers for special variables. +iNIT_VAR_ID :: VarUniq +iNIT_VAR_ID = 1000 + +pHI_FUNCTION :: VarUniq +pHI_FUNCTION = 134 + +sTORE_INIT :: VarUniq +sTORE_INIT = 135 + +lOAD_GLOBAL :: VarUniq +lOAD_GLOBAL = 136 + +sTORE_GLOBAL :: VarUniq +sTORE_GLOBAL = 137 + +sTORE_VAR :: VarUniq +sTORE_VAR = 100 + +lOAD_STRUCT :: VarUniq +lOAD_STRUCT = 101 + +lOAD_VAR :: VarUniq +lOAD_VAR = 102 + +lOAD_VAR_RNG :: VarUniq +lOAD_VAR_RNG = 103 + +lOAD_MATRIX :: VarUniq +lOAD_MATRIX = 104 + +lOAD_MATRIX_RANGE :: VarUniq +lOAD_MATRIX_RANGE = 105 + +lOAD_MATRIX_ROW_RNG :: VarUniq +lOAD_MATRIX_ROW_RNG = 106 + +lOAD_MATRIX_COL_RNG :: VarUniq +lOAD_MATRIX_COL_RNG = 107 + +sFIELD :: VarUniq +sFIELD = 108 + +vIND :: VarUniq +vIND = 109 + +vRANGE :: VarUniq +vRANGE = 110 + +mIND :: VarUniq +mIND = 111 + +mRANGE :: VarUniq +mRANGE = 112 + +mCOLRANGE :: VarUniq +mCOLRANGE = 113 + +mROWRANGE :: VarUniq +mROWRANGE = 114 + +gLOBAL_INIT :: VarUniq +gLOBAL_INIT = 115 + +sSA_DECL ::VarUniq +sSA_DECL = 116 + +-- C Functions + +cGLOBAL_REF :: VarUniq +cGLOBAL_REF = 41 + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- | The @Scope@ of a variable. +data Scope + = Global -- ^ A global variable. + | Local -- ^ Local variable. + deriving (Show, Read) + +instance PP Scope where + ppr Global = text "Global" + ppr Local = text "Local" + +instance Eq Var where + v1 == v2 = vuniq v1 == vuniq v2 + +instance Ord Var where + v1 `compare` v2 = vuniq v1 `compare` vuniq v2 + +instance PP Var where + ppr = pprVar + +instance PP VarKind where + ppr = pprVarKind + +pprVar :: Var -> CDoc +pprVar (Var n i vk) = text (nameStr n) + <> ifPprIds (int i) + <> ifPprDebug (text "@ID=" <> int i) + <> ifPprDebug (pprVarKind vk) + +pprVarKind :: VarKind -> CDoc +pprVarKind (VarId t s) = text "@Type=" <> noPprDebug (ppr t) + <> text "@Scope=" <> ppr s +pprVarKind (ConstId t c s) = text "@Type=" <> noPprDebug (ppr t) + <> text "@Value=" <> ppr c + <> text "@Scope=" <> ppr s +pprVarKind (SsaVar k) = brackets $ ppr k +pprVarKind (CVar t _ tn k) = text "@Type=" <> noPprDebug (ppr t) + <> text "@TName=" <> text tn + <> text "@Kind=" <> ppr k + +-- | Create local variable. +{-# INLINE mkLId #-} +mkLId :: Name -> VarUniq -> Type Var -> Var +mkLId v i t = Var v i $ VarId t Local + +-- | Create global variable. +{-# INLINE mkGId #-} +mkGId :: Name -> VarUniq -> Type Var -> Var +mkGId v i t = Var v i $ VarId t Global + +-- | Create local constant. +{-# INLINE mkLConst #-} +mkLConst :: Name -> VarUniq -> Type Var -> Maybe (IExpr Var) -> Var +mkLConst v i t e = Var v i $ ConstId t e Local + +-- | Create global constant. +{-# INLINE mkGConst #-} +mkGConst :: Name -> VarUniq -> Type Var -> Maybe (IExpr Var) -> Var +mkGConst v i t e = Var v i $ ConstId t e Global + +-- | Global @init@ function identifier. Used to initialize global variables. +globalInit :: String -> [Var] -> Var +globalInit s vars = Var (mkFunName s) gLOBAL_INIT globalInitK + where + globalInitK :: VarKind + globalInitK = VarId (FuncSig [] (Tuple []) (Proc vars)) Global + +-- | Check if variable is a global init. +isGlobalInit :: Var -> Bool +isGlobalInit v = varId v == gLOBAL_INIT + +-- | Set type of variable. +setType :: Type Var -> Var -> Var +setType ty (Var n u v@(VarId _ _)) = Var n u (v {vtype = ty}) +setType ty (Var a b c@(ConstId _ _ _)) = Var a b (c {vtype = ty}) +setType _ v = v + +setIndConst :: IExpr Var -> Var -> Var +setIndConst e v = v { vkind = aux (vkind v) } + where + aux (ConstId c _ s) = ConstId c (Just e) s + aux k = k + +-- | Set variable name +setName :: Name -> Var -> Var +setName n v = v { vname = n } + +-- | Get string symbol of a variable name. +getSymbol :: Var -> String +getSymbol = nameStr . vname + +-- | Set string symbol of the name of a variable. +setSymbol :: String -> Var -> Var +setSymbol s v = v { vname = setNameStr s (vname v) } + +-- | Set variable identifier. +setId :: VarUniq -> Var -> Var +setId u (Var n _ vk) = Var n u vk + +-- | Get type name of a special C variable. +getTName :: Var -> String +getTName = tname . vkind + +-- | Get 'opname' of a special C variable. +getOpName :: Var -> OpCode +getOpName = opname . vkind + +-- | Get the type of a variable. +{-# INLINE varType #-} +varType :: Var -> Type Var +varType (Var _ _ (VarId ty _)) = ty +varType (Var _ _ (ConstId ty _ _)) = ty +varType (Var _ _ (SsaVar (AccessF ty _))) = ty +varType (Var _ _ (CVar ty _ _ _)) = ty +varType v = error $ ".:\ + \ Unexpected case: " ++ showPpr v + +-- | Get variable scope. +{-# INLINE varScope #-} +varScope :: Var -> Scope +varScope (Var _ _ v@(VarId {})) = vscope v +varScope (Var _ _ v@(ConstId {})) = vscope v +varScope _ = Global + +-- | Get variable unique identifier. +{-# INLINE varId #-} +varId :: Var -> VarUniq +varId = vuniq + +-- | Check if a variable is of 'Local' scope. +{-# INLINE isLocal #-} +isLocal :: Var -> Bool +isLocal (Var _ _ (VarId _ Local)) = True +isLocal (Var _ _ (ConstId _ _ Local)) = True +isLocal _ = False + +-- | Check if a variable is of 'Global' scope. +{-# INLINE isGlobal #-} +isGlobal :: Var -> Bool +isGlobal (Var _ _ (VarId _ Global)) = True +isGlobal (Var _ _ (ConstId _ _ Global)) = True +isGlobal _ = False + +-- | Check if a CAO variable is of 'Local' scope. +{-# INLINE isGlobalVar #-} +isGlobalVar :: Var -> Bool +isGlobalVar (Var n _ (VarId _ Global)) = isVarName n +isGlobalVar (Var n _ (ConstId _ _ Global)) = isVarName n +isGlobalVar _ = False + +-- XXX: Not used +-- | Check if variable is not external. +{-# INLINE isNotExternal #-} +isNotExternal :: Var -> Bool +isNotExternal (Var _ _ (ConstId _ Nothing Global)) = False +isNotExternal _ = True + +-- | Check if an AST variable is a CAO variable. +{-# INLINE nsVar #-} +nsVar :: Var -> Bool +nsVar (Var n _ (VarId{})) = isVarName n +nsVar (Var n _ (ConstId{})) = isVarName n +nsVar _ = False + +-- | Check if an AST variable is a struct field. +{-# INLINE nsStructFld #-} +nsStructFld :: Var -> Bool +nsStructFld (Var n _ (VarId{})) = isStructFldName n +nsStructFld _ = False + +-- | Check if an AST variable is polynomial index. +{-# INLINE nsPolInd #-} +nsPolInd :: Var -> Bool +nsPolInd (Var n _ (VarId{})) = isPolIndName n +nsPolInd _ = False + +-- | Check if an AST variable is a type identifier. +{-# INLINE nsTyVar #-} +nsTyVar :: Var -> Bool +nsTyVar (Var n _ (VarId{})) = isTvName n +nsTyVar _ = False + +-- | Check if an AST variable is a function identifier. +{-# INLINE nsFunName #-} +nsFunName :: Var -> Bool +nsFunName (Var n _ (VarId{})) = isFunName n +nsFunName _ = False + +-- | Check if an AST variable is a procedure. +{-# INLINE isProcVar #-} +isProcVar :: Var -> Bool +isProcVar (Var _ _ (VarId t _)) = isProc t +isProcVar _ = False + +-- | Check if an AST variable an index variable. +{-# INLINE indVar #-} +indVar :: Var -> Bool +indVar (Var n _ (ConstId {})) = isVarName n +indVar _ = False + +-- | Get expression defining a constant (when existing). +{-# INLINE indConst #-} +indConst :: Var -> Maybe (IExpr Var) +indConst (Var _ _ v@(ConstId {})) = vconst v +indConst _ = Nothing + +-- | Create phi function variable. +mkPhiFunVar :: Name -> Var +mkPhiFunVar n = Var n pHI_FUNCTION $ SsaVar PhiFun + +-- | Create store init variable. +mkStoreInit :: Name -> Var +mkStoreInit n = Var n sTORE_INIT $ SsaVar $ StoreF SInit + +-- | Create load global variable. +mkLoadGlobal :: Name -> Var +mkLoadGlobal n = Var n lOAD_GLOBAL $ SsaVar (LoadF LGlobal) + +-- | Create store global variable. +mkStoreGlobal :: Name -> Var +mkStoreGlobal n = Var n sTORE_GLOBAL $ SsaVar (StoreF SGlobal) + + +-- | Store var. +storeVar :: Var +storeVar = Var (mkFunName "store_v") sTORE_VAR storeVarK + where + storeVarK :: VarKind + storeVarK = SsaVar (StoreF SVar) + +-- | Load struct. +loadStruct :: Var +loadStruct = Var (mkFunName "load_s") lOAD_STRUCT loadStructK + where + loadStructK :: VarKind + loadStructK = SsaVar (LoadF LStruct) + +-- | Load variable. +loadVar :: Var +loadVar = Var (mkFunName "load_v") lOAD_VAR loadVarK + where + loadVarK :: VarKind + loadVarK = SsaVar (LoadF LVect) + +-- | Load variable range. +loadVarRng :: Var +loadVarRng = Var (mkFunName "load_v_range") lOAD_VAR_RNG loadVarRngK + where + loadVarRngK :: VarKind + loadVarRngK = SsaVar (LoadF LVectRng) + +-- | Load matrix value. +loadMatrix :: Var +loadMatrix = Var (mkFunName "load_m") lOAD_MATRIX loadMatrixK + where + loadMatrixK :: VarKind + loadMatrixK = SsaVar (LoadF LMat) + +-- | Load matrix range. +loadMatrixRng :: Var +loadMatrixRng = Var (mkFunName "load_m_range") lOAD_MATRIX_RANGE loadMatrixRngK + where + loadMatrixRngK :: VarKind + loadMatrixRngK = SsaVar (LoadF LMatRng) + +-- | Load matrix column range. +loadMatrixColRng :: Var +loadMatrixColRng = + Var (mkFunName "load_m_col_range") lOAD_MATRIX_COL_RNG loadMatrixColRngK + where + loadMatrixColRngK :: VarKind + loadMatrixColRngK = SsaVar (LoadF LMatCRng) + +-- | Load matrix row range. +loadMatrixRowRng :: Var +loadMatrixRowRng = + Var (mkFunName "load_m_row_range") lOAD_MATRIX_ROW_RNG loadMatrixRowRngK + where + loadMatrixRowRngK :: VarKind + loadMatrixRowRngK = SsaVar (LoadF LMatRRng) + +-- | Special marker for variable declarations in SSA. +ssaDecl :: Var +ssaDecl = Var (mkFunName "ssa_decl") sSA_DECL ssaDeclK + where + ssaDeclK :: VarKind + ssaDeclK = SsaVar DeclF + +-- | Access struct field. +sfield :: Type Var -> Var +sfield t = Var (mkFunName "sfield") sFIELD sfieldK + where + sfieldK :: VarKind + sfieldK = SsaVar (AccessF t ASField) + +-- | Access vector element. +vind :: Type Var -> Var +vind t = Var (mkFunName "vind") vIND vindK + where + vindK :: VarKind + vindK = SsaVar (AccessF t AVInd) + +-- | Access vector range. +vrange :: Type Var -> Var +vrange t = Var (mkFunName "vrange") vRANGE vrangeK + where + vrangeK :: VarKind + vrangeK = SsaVar (AccessF t AVRng) + +-- | Access matrix element. +mind :: Type Var -> Var +mind t = Var (mkFunName "mind") mIND mindK + where + mindK :: VarKind + mindK = SsaVar (AccessF t AMInd) + +-- | Access matrix range. +mrange :: Type Var -> Var +mrange t = Var (mkFunName "mrange") mRANGE mrangeK + where + mrangeK :: VarKind + mrangeK = SsaVar (AccessF t AMRng) + +-- | Access matrix column range. +mcolrange :: Type Var -> Var +mcolrange t = Var (mkFunName "mcolrange") mCOLRANGE mcolrangeK + where + mcolrangeK :: VarKind + mcolrangeK = SsaVar (AccessF t AMColRng) + +-- | Access matrix row range. +mrowrange :: Type Var -> Var +mrowrange t = Var (mkFunName "mrowrange") mROWRANGE mrowrangeK + where + mrowrangeK :: VarKind + mrowrangeK = SsaVar (AccessF t AMRowRng) + +-- | Check if variable is a phi function. +{-# INLINE isPhiFun #-} +isPhiFun :: Var -> Bool +isPhiFun (Var _ _ (SsaVar PhiFun)) = True +isPhiFun _ = False + +-- | Check if variable is a store global function. +{-# INLINE isStoreGlobal #-} +isStoreGlobal :: Var -> Bool +isStoreGlobal (Var _ _ (SsaVar (StoreF SGlobal))) = True +isStoreGlobal _ = False + +-- | Check if variable is a store function. +{-# INLINE isStoreVar #-} +isStoreVar :: Var -> Bool +isStoreVar (Var _ _ (SsaVar (StoreF SVar))) = True +isStoreVar _ = False + +-- | Check if variable is a store with initialization function. +{-# INLINE isStoreInit #-} +isStoreInit :: Var -> Bool +isStoreInit (Var _ _ (SsaVar (StoreF SInit))) = True +isStoreInit _ = False + +-- | Check if variable is a ssa declaration. +{-# INLINE isSsaDecl #-} +isSsaDecl :: Var -> Bool +isSsaDecl (Var _ _ (SsaVar DeclF)) = True +isSsaDecl _ = False + +-- | Check if variable is a load global. +{-# INLINE isLoadGlobal #-} +isLoadGlobal :: Var -> Bool +isLoadGlobal (Var _ _ (SsaVar (LoadF LGlobal))) = True +isLoadGlobal _ = False + +-- | Check if variable is a load struct. +{-# INLINE isLoadStruct #-} +isLoadStruct :: Var -> Bool +isLoadStruct (Var _ _ (SsaVar (LoadF LStruct))) = True +isLoadStruct _ = False + +-- | Check if variable is a load var. +{-# INLINE isLoadVar #-} +isLoadVar :: Var -> Bool +isLoadVar (Var _ _ (SsaVar (LoadF LVect))) = True +isLoadVar _ = False + +-- | Check if variable is a load var range. +{-# INLINE isLoadVarRange #-} +isLoadVarRange :: Var -> Bool +isLoadVarRange (Var _ _ (SsaVar (LoadF LVectRng))) = True +isLoadVarRange _ = False + +-- | Check if variable is a load matrix . +{-# INLINE isLoadMat #-} +isLoadMat :: Var -> Bool +isLoadMat (Var _ _ (SsaVar (LoadF LMat))) = True +isLoadMat _ = False + +-- | Check if variable is a load matrix range. +{-# INLINE isLoadMatRange #-} +isLoadMatRange :: Var -> Bool +isLoadMatRange (Var _ _ (SsaVar (LoadF LMatRng))) = True +isLoadMatRange _ = False + +-- | Check if variable is a load matrix row range. +{-# INLINE isLoadMatRowR #-} +isLoadMatRowR :: Var -> Bool +isLoadMatRowR (Var _ _ (SsaVar (LoadF LMatRRng))) = True +isLoadMatRowR _ = False + +-- | Check if variable is a load matrix column range. +{-# INLINE isLoadMatColR #-} +isLoadMatColR :: Var -> Bool +isLoadMatColR (Var _ _ (SsaVar (LoadF LMatCRng))) = True +isLoadMatColR _ = False + +-- | Check if variable is a struct field 'LValue'. +{-# INLINE isLValSField #-} +isLValSField :: Var -> Bool +isLValSField (Var _ _ (SsaVar (AccessF _ ASField))) = True +isLValSField _ = False + +-- | Check if variable is a vector element 'LValue'. +{-# INLINE isLValVInd #-} +isLValVInd :: Var -> Bool +isLValVInd (Var _ _ (SsaVar (AccessF _ AVInd))) = True +isLValVInd _ = False + +-- | Check if variable is a vector range 'LValue'. +{-# INLINE isLValVRng #-} +isLValVRng :: Var -> Bool +isLValVRng (Var _ _ (SsaVar (AccessF _ AVRng))) = True +isLValVRng _ = False + +-- | Check if variable is a matrix element 'LValue'. +{-# INLINE isLValMInd #-} +isLValMInd :: Var -> Bool +isLValMInd (Var _ _ (SsaVar (AccessF _ AMInd))) = True +isLValMInd _ = False + +-- | Check if variable is a matrix range 'LValue'. +{-# INLINE isLValMRng #-} +isLValMRng :: Var -> Bool +isLValMRng (Var _ _ (SsaVar (AccessF _ AMRng))) = True +isLValMRng _ = False + +-- | Check if variable is a matrix column range 'LValue'. +{-# INLINE isLValMColRng #-} +isLValMColRng :: Var -> Bool +isLValMColRng (Var _ _ (SsaVar (AccessF _ AMColRng))) = True +isLValMColRng _ = False + +-- | Check if variable is a matrix row range 'LValue'. +{-# INLINE isLValMRowRng #-} +isLValMRowRng :: Var -> Bool +isLValMRowRng (Var _ _ (SsaVar (AccessF _ AMRowRng))) = True +isLValMRowRng _ = False + +-- | Check if variable is a C function. +{-# INLINE isCFunction #-} +isCFunction :: Var -> Bool +isCFunction (Var _ _ (CVar _ _ _ CFun)) = True +isCFunction _ = False + +-- | Check if variable is a C reference. +isCRef :: Var -> Bool +isCRef (Var _ _ (CVar _ _ _ CRef)) = True +isCRef _ = False + +-- | Check if variable is a C reference. +isCRefCall :: Var -> Bool +isCRefCall (Var _ uid (CVar _ _ _ CFun)) = uid == code_ref +isCRefCall _ = False + +-- | Check if variable is a C reference call. +isCStruct :: Var -> Bool +isCStruct (Var _ _ (CVar _ _ _ CStruct)) = True +isCStruct _ = False + +-- | Check if a variable is a C cast. +isCCast :: Var -> Bool +isCCast (Var _ uid (CVar _ _ _ CFun)) = uid == code_cast +isCCast _ = False + +-- | Check if a variable is a C assignment +isCAssign :: Var -> Bool +isCAssign (Var _ uid (CVar _ _ _ CFun)) = uid == code_assign +isCAssign _ = False + +-- | Check if variable is a C comp. +isCComp :: Var -> Bool +isCComp (Var _ uid (CVar _ _ _ CFun)) = isCompCode uid +isCComp _ = False + +-- | Check if variable is a C global reference. +isCGlobalRef :: Var -> Bool +isCGlobalRef (Var _ uid (CVar _ _ _ CFun)) = uid == cGLOBAL_REF +isCGlobalRef _ = False + +-- | Create a C cast function variable. +cCast :: Type Var -> String -> String -> String -> Var +cCast v tp tn td = + Var (mkFunName $ tp ++ "_" ++ tn ++ "_cast_" ++ td) code_cast cCastK + where + cCastK = CVar v code_cast tn CFun + +-- | Create C global reference. +cGlobalRef :: String -> Var +cGlobalRef tp = Var (mkFunName $ tp ++ "_global_ref") cGLOBAL_REF cGlobalRefK + where + cGlobalRefK = CVar Bullet code_ref "global" CFun + +-- | Create a C reference variable. +mkCRef :: String -> VarUniq -> String -> Var +mkCRef nm uid tn = Var (mkVarName nm) uid $ CVar Bullet (-1) tn CRef + +-- | Create a C struct variable +mkCStruct :: String -> VarUniq -> Type Var -> String -> String -> Var +mkCStruct nm uid typ tp tn = Var (mkVarName $ tp ++ "_" ++ nm) uid cstructK + where + cstructK = CVar typ (-1) tn CStruct + +assembleName :: String -> String -> OpCode -> Name +assembleName tp tn op = mkFunName $ tp ++ "_" ++ tn ++ "_" ++ operName op + +cFun :: OpCode -> Type Var -> String -> String -> Var +cFun op t tp tn = Var (assembleName tp tn op) op $ CVar t op tn CFun diff --git a/src/Language/CAO/Index.hs b/src/Language/CAO/Index.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Index.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{- | +Module : $Header$ +Description : Index language +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable () + +In CAO, sizes of types, accesses to vectors or matrices can depend on +symbolic constants. The language of these expressions is treated independently +of the language of CAO expressions. This module describes how these are +handled, dividing them in two types: one for conditions and invariants +over the symbolic constants and other for the expressions themselves. +--} + +module Language.CAO.Index + ( ICond(..) + , IExpr(..) + , IAOp(..) + , IBOp(..) + , (.-.) + , (.*.) + , (.**.) + , (./.) + , (.%.) + , (.==.) + , (./=.) + , (.<.) + , (.<=.) + , (.>.) + , (.>=.) + , (.||.) + , (.^^.) + ) where + +import Data.Foldable ( Foldable ) +import Data.Traversable ( Traversable ) + +import Language.CAO.Common.Operator +import Language.CAO.Common.Outputable + +-- TODO: Some modules use Indexes but they do not reduce them to the canonical form +-------------------------------------------------------------------------------- +-- * Index conditions +-- TODO: Implication to decide validity? +-- | The conditions are expressed as boolean values and expressions over them. +data ICond id + -- | Boolean literal + = IBool !Bool + -- | Boolean variable + | IBInd !id + -- | Boolean negation (not) + | INot (ICond id) + -- | Boolean conjunction. The list must be non-empty. + | IAnd [ICond id] + -- | Boolean binary operations. + | IBoolOp IBOp (ICond id) (ICond id) + -- | Non-negative operator on expressions. + -- This has the meaning of @0 <= expr@ + | ILeq (IExpr id) + -- | Test of equality with 0 (@expr == 0@). + | IEq (IExpr id) + deriving (Eq, Read, Show, Functor, Foldable, Traversable) + +instance PP id => PP (ICond id) where + ppr = pprICond + +pprICond :: PP id => ICond id -> CDoc +pprICond (IBool b) + = text $ show b +pprICond (IBInd b) + = ppr b +pprICond ctx@(INot e) + = char '!' <> pprParens_ e ctx +pprICond (IAnd l) + = parens (cat (punctuate (text " && ") (map ppr l))) +pprICond ctx@(IBoolOp op l r) + = pprParensL_ l ctx <+> ppr op <+> pprParensR_ r ctx +pprICond ctx@(ILeq r) + = integer 0 <+> text "<=" <+> pprParensR_ r ctx +pprICond ctx@(IEq r) + = integer 0 <+> text "=" <+> pprParensR_ r ctx + +instance Operator (ICond id) where + isSimple (IBool _) = True + isSimple (IBInd _) = True + isSimple _ = False + + assoc (IAnd _) = ALeft + assoc (IBoolOp op _ _) = assoc op + assoc _ = NoAssoc + + fixity (INot _) = Prefix + fixity (IAnd _) = Infix + fixity (IBoolOp op _ _) = fixity op + fixity (IEq _) = Infix + fixity (ILeq _) = Infix + fixity _ = Nofix + + prec (IBool _) = 200 + prec (IBInd _) = 200 + prec (INot _) = 180 + prec (IAnd _) = 60 + prec (IBoolOp op _ _) = prec op + prec (IEq _) = 110 + prec (ILeq _) = 120 + +-- | Boolean binary operations +data IBOp + = IOr -- ^ Boolean disjunction + | IXor -- ^ Boolean exclusive disjunction + deriving (Eq, Read, Show) + +instance PP IBOp where + ppr = pprIBOp + +pprIBOp :: IBOp -> CDoc +pprIBOp IOr = text "||" +pprIBOp IXor = text "^^" + +instance Operator IBOp where + isSimple _ = False + assoc _ = ALeft + fixity _ = Infix + + prec IOr = 40 + prec IXor = 50 + +-- * Index expressions +-- | Index expressions. Normal form: ... +data IExpr id + -- | Integer literals + = IInt !Integer + -- | Index variables + | IInd !id + -- | Arithmetic sum + | ISum [IExpr id] + -- | Binary arithmetic operators + | IArith IAOp (IExpr id) (IExpr id) + -- | Symmetric + | ISym (IExpr id) + deriving (Eq, Read, Show, Functor, Foldable, Traversable) + +instance PP id => PP (IExpr id) where + ppr = pprExpr + +pprExpr :: PP id => IExpr id -> CDoc +pprExpr (IInt n) = integer n +pprExpr (IInd i) = ppr i +pprExpr (ISum l) = parens (cat (punctuate (text " + ") (map ppr l))) +pprExpr ctx@(IArith op l r) = pprParensL_ l ctx <+> ppr op <+> pprParensR_ r ctx +pprExpr ctx@(ISym e) = parens $ char '-' <> pprParens_ e ctx + +instance Operator (IExpr id) where + isSimple (IInt _) = True + isSimple (IInd _) = True + isSimple _ = False + + assoc (ISum _) = ALeft + assoc (IArith op _ _) = assoc op + assoc _ = NoAssoc + + fixity (ISum _) = Infix + fixity (IArith op _ _) = fixity op + fixity (ISym _) = Prefix + fixity _ = Nofix + + prec (IInt _) = 200 + prec (IInd _) = 200 + prec (ISum _) = 140 + prec (IArith op _ _) = prec op + prec (ISym _) = 180 + +-- | Binary arithmetic operators +data IAOp + = IMinus -- ^ Substraction + | ITimes -- ^ Multiplication + | IPower -- ^ Exponentiation + | IDiv -- ^ Whole division + | IModOp -- ^ Remainer of whole division + deriving (Eq, Read, Show) + +instance PP IAOp where + ppr = pprIAOp + +pprIAOp :: IAOp -> CDoc +pprIAOp IMinus = char '-' +pprIAOp ITimes = char '*' +pprIAOp IPower = text "**" +pprIAOp IDiv = char '/' +pprIAOp IModOp = char '%' + +instance Operator IAOp where + isSimple _ = False + + assoc ITimes = ALeft + assoc _ = NoAssoc + + fixity _ = Infix + + prec IMinus = 140 + prec ITimes = 150 + prec IDiv = 150 + prec IModOp = 150 + prec IPower = 160 + +-------------------------------------------------------------------------------- +-- * Syntactic sugar + +(.-.), (.*.), (.**.), (./.), (.%.) :: IExpr id -> IExpr id -> IExpr id +(.-.) = IArith IMinus +(.*.) = IArith ITimes +(.**.) = IArith IPower +(./.) = IArith IDiv +(.%.) = IArith IModOp + +(.==.), (./=.), (.<.), (.<=.), (.>.), (.>=.) :: IExpr id -> IExpr id -> ICond id +(.==.) e1 e2 = IEq (IArith IMinus e1 e2) +(./=.) e1 e2 = INot (e1 .==. e2) +(.<.) e1 e2 = ILeq $ ISum [e2, ISym e1, IInt (-1)] +(.<=.) e1 e2 = ILeq $ ISum [e2, ISym e1] +(.>.) = flip (.<.) +(.>=.) = flip (.<=.) + +(.||.), (.^^.) :: ICond id -> ICond id -> ICond id +(.||.) = IBoolOp IOr +(.^^.) = IBoolOp IXor + diff --git a/src/Language/CAO/Index/Eval.hs b/src/Language/CAO/Index/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Index/Eval.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{- | +Module : $Header$ +Description : Evaluation of index language +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable () + +--} + +module Language.CAO.Index.Eval + ( evalCond + , evalExpr + ) where + +import Data.List + +import Language.CAO.Index +import Language.CAO.Semantics.Integer +import Language.CAO.Semantics.Bool + +-------------------------------------------------------------------------------- +-- This implements the properties of the several boolean operators, +-- except conjuntion. It does not use equality on expressions, only +-- on variables. +truthTable :: Eq id => ICond id -> ICond id +truthTable (IBoolOp op (IBool b1) (IBool b2)) + = IBool $ mapIBOp op b1 b2 +truthTable (IBoolOp IOr (IBool b1) b2) + | b1 = IBool True + | otherwise = truthTable b2 +truthTable (IBoolOp IOr b1 (IBool b2)) + | b2 = IBool True + | otherwise = truthTable b1 +truthTable (IBoolOp IXor (IBool b1) b2) + | b1 = truthTable $ deMorgan b2 + | otherwise = truthTable b2 +truthTable (IBoolOp IXor b1 (IBool b2)) + | b2 = truthTable $ deMorgan b1 + | otherwise = truthTable b1 +truthTable (IBoolOp IXor (IBInd b1) (IBInd b2)) + | b1 == b2 = IBool False + | otherwise = IBool True +truthTable (IBoolOp _ (IBInd b1) (IBInd b2)) -- Idempotence + | b1 == b2 = IBInd b1 +truthTable e = e + +-------------------------------------------------------------------------------- +-- Application of deMorgan rules +deMorgan :: ICond id -> ICond id +deMorgan (IBool b) = IBool $ not b +deMorgan (INot c) = c +deMorgan (IBoolOp IOr c1 c2) = IAnd [deMorgan c1, deMorgan c2] +deMorgan (IBoolOp IXor c1 c2) = aux c1 c2 + where + aux (IBool b) e = IBoolOp IXor (IBool $ not b) e + aux e (IBool b) = IBoolOp IXor e (IBool $ not b) + aux (INot b) e = IBoolOp IXor b e + aux e (INot b) = IBoolOp IXor e b + aux i@(IBInd _) e = IBoolOp IXor (INot i) e + aux e i@(IBInd _) = IBoolOp IXor e (INot i) + aux e1 e2 = IBoolOp IXor (deMorgan e1) e2 +deMorgan (IAnd lc) = andToOr $ map deMorgan lc + where + andToOr [] = error ": unexpected case" + andToOr [x] = x + andToOr (x:xs) = IBoolOp IOr x (andToOr xs) +deMorgan i = INot i + +-------------------------------------------------------------------------------- +evalCond :: (Ord id, Eq id) => ICond id -> ICond id + +evalCond (INot c) = case deMorgan (evalCond c) of + IAnd l -> flatAnd l + c' -> truthTable c' + +evalCond (IAnd l) = flatAnd $ map evalCond l +-- Canonical form for Nested expressions +evalCond (IBoolOp op c1 c2) = case (evalCond c1, evalCond c2) of + (l1@(IAnd _), l2) -> flatAnd $ distrOr l1 l2 + (l1, l2@(IAnd _)) -> flatAnd $ distrOr l1 l2 + (l1, l2) -> truthTable $ IBoolOp op l1 l2 + +evalCond (ILeq e) = case evalExpr e of + IInt i -> IBool $ 0 <= i + e' -> ILeq e' + +evalCond (IEq e) = case evalExpr e of + IInt i -> IBool $ 0 == i + e' -> IEq e' + +evalCond c = c + +-------------------------------------------------------------------------------- +distrOr :: ICond id -> ICond id -> [ICond id] +distrOr (IAnd l1) (IAnd l2) = concatMap (distrOr' l1) l2 +distrOr c (IAnd l2) = distrOr' l2 c +distrOr (IAnd l1) c = distrOr' l1 c +distrOr _ _ = error ": not expected" + +distrOr' :: [ICond id] -> ICond id -> [ICond id] +distrOr' l c = map (IBoolOp IOr c) l + +-------------------------------------------------------------------------------- +-- Remove True +-- Reduce to False +-- Bring out nested And +flatAnd :: Eq id => [ICond id] -> ICond id +flatAnd c = let + (v, var, i) = foldr aux (True, [], []) c + in if v && not (null i && null var) + then IAnd (nub var ++ i) + else IBool v + + where + aux (IBool False) _ = (False, [], []) + aux (IBool True) r = r + aux (IAnd l) (v, vs, r) = case flatAnd l of + IAnd l' -> (v, vs, l' ++ r) + IBool False -> (False, [], []) + IBool True -> (v, vs, r) + _ -> error "flatAnd.aux: Not expected case" + aux i@(IBInd _) (v, vs, r) = (v, i : vs, r) + aux x (v, vs, r) = case truthTable x of + IBool False -> (False, [], []) + IBool True -> (v, vs, r) + x' -> (v, vs, x' : r) + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- Partially inspired by +-- Producing Proofs from an Arithmetic Decision Procedure in Elliptical LF +-- Aaron Stump, Clark W. Barrett, and David L. Dill + +{- + Flat form: + 1. All sums are non-empty + 2. The first element of a sum is always a constant + 3. Variables are never alone. They are always part of a product 1 * v + 4. Symmetric is moved downwards to values and variables + 5. There are not nested sums + 6. The outer symbol of a flatExpr is always a ISum + 7. Operations on literals are always computed +-} +-------------------------------------------------------------------------------- +evalExpr :: (Eq id, Ord id) => IExpr id -> IExpr id +evalExpr = canonicalExpr . flatExpr + +flatExpr :: Eq id => IExpr id -> IExpr id + +flatExpr i@(IInt _) = ISum [i] + +flatExpr i@(IInd _) = ISum [IInt 0, IArith ITimes (IInt 1) i] + +flatExpr (ISym (IInt n)) = resInt $ negate n -- shortcut +flatExpr (ISym t) = distrSym $ flatExpr t + +flatExpr (ISum l) = ISum $ flatSum $ map flatExpr l + +flatExpr (IArith IMinus (IInt n) (IInt n')) = resInt $ n - n' +flatExpr (IArith IMinus (IInd i) (IInd i')) + | i == i' = resInt 0 +flatExpr (IArith IMinus i1 i2) = + ISum $ flatSum [flatExpr i1, distrSym $ flatExpr i2] + +flatExpr (IArith ITimes (IInt n) (IInt n')) = resInt $ n * n' +flatExpr e@(IArith ITimes _ _) = flatTimes e + +flatExpr (IArith IDiv (IInt n) (IInt n')) = resInt $ div n n' +flatExpr (IArith IDiv p q) = let + ISum p' = flatExpr p + ISum q' = flatExpr q + in ISum [listDiv p' q'] + +flatExpr (IArith IPower (IInt b) (IInt e)) = resInt $ b^e +flatExpr (IArith IPower b e) = + ISum [IInt 0, IArith ITimes (IInt 1) (IArith IPower (flatExpr b) (flatExpr e))] + +flatExpr (IArith IModOp (IInt a) (IInt b)) = resInt $ mod a b + +flatExpr _ = error "TODO: flatExpr: " + +resInt :: Integer -> IExpr id +resInt n = ISum [IInt n] + +flatTimes :: Eq id => IExpr id -> IExpr id +flatTimes e@(IArith ITimes _ _) = let + (ci, si, mi) = sepTimes e + + mm = toMult (product ci) mi + + (sc, ssi) = iTimesConcat $ map flatExpr si + + (pc, pe) = iTimesLst [mm] ssi + (pc', pe') = iTimesLst [mm] sc + + sumCi = constSum $ pc ++ pc' + + in ISum $ sumCi : pe ++ pe' +flatTimes _ = error ": not expected" + +toMult :: Integer -> [IExpr id] -> IExpr id +toMult n [] = IInt n +toMult n xs@(_:_) = IArith ITimes (IInt n) (aux xs) + where + aux [] = error ": not expected" + aux [e] = e + aux (e:es) = IArith ITimes e (aux es) + +sepTimes :: Eq id => IExpr id -> ([Integer], [IExpr id], [IExpr id]) +sepTimes (IInt n) = ([n], [], []) +sepTimes i@(IInd _) = ([], [], [i]) +sepTimes s@(ISum _) = ([], [s], []) +sepTimes (IArith ITimes i1 i2) = let + (ci1, si1, mi1) = sepTimes i1 + (ci2, si2, mi2) = sepTimes i2 + in (ci1 ++ ci2, si1 ++ si2, mi1 ++ mi2) +sepTimes (IArith IPower (IInt n) (IInt e)) = ([n ^ e], [], []) +sepTimes e@(IArith IMinus _ _) = sepTimes (flatExpr e) +sepTimes (ISym e) = sepTimes (flatExpr e) +sepTimes s@(IArith IDiv _ _) = ([], [s], []) +sepTimes _ = error "<> IExpr id +constSum = constOp ((+), 0) + +constOp :: (Integer -> Integer -> Integer, Integer) -> [IExpr id] -> IExpr id +constOp (f, n) = foldr aux (IInt n) + where + aux (IInt m) (IInt res) = IInt (f m res) + aux _ _ = error ": not expected" + +iTimesConcat :: [IExpr id] -> ([IExpr id], [IExpr id]) +iTimesConcat [] = ([IInt 0],[IInt 1]) +iTimesConcat [ISum x] = ([head x], tail x) +iTimesConcat (ISum x:xs) = let + (cs, xs') = iTimesConcat xs + (c, i) = iTimesLst x cs + (c', i') = iTimesLst x xs' + in ([constSum $ c ++ c'], i ++ i') +iTimesConcat (_:_) = error ": not expected" + +iTimesLst :: [IExpr id] -> [IExpr id] -> ([IExpr id], [IExpr id]) +iTimesLst [] _ = ([], []) +iTimesLst [x] xr = let + (nl, ol) = unzip $ map (iTimes x) xr + in ([constSum $ concat nl], concat ol) +iTimesLst (x:xl) xr = let + (nl, ol) = iTimesLst xl xr + (nl', ol') = unzip $ map (iTimes x) xr + in ([constSum (nl ++ concat nl')], ol ++ concat ol') + +iTimes :: IExpr id -> IExpr id -> ([IExpr id], [IExpr id]) +-- Constant * Constant +iTimes (IInt n) (IInt n') = ([IInt $ n * n'], []) +-- Constant * Variable +iTimes (IInt 0) (IInd _) = ([], []) +iTimes (IInt n) (IInd i) = ([], [IArith ITimes (IInt n) (IInd i)]) +iTimes (IInd _) (IInt 0) = ([], []) +iTimes (IInd i) (IInt n) = ([], [IArith ITimes (IInt n) (IInd i)]) +-- Constant * Product +iTimes (IInt 0) (IArith ITimes (IInt _) _) = ([], []) +iTimes (IInt n) (IArith ITimes (IInt c) i) = ([], [IArith ITimes (IInt $ c * n) i]) +iTimes (IArith ITimes (IInt _) _) (IInt 0) = ([], []) +iTimes (IArith ITimes (IInt c) i) (IInt n) = ([], [IArith ITimes (IInt $ c * n) i]) +-- Variable * Product +iTimes (IInd i) (IArith ITimes (IInt c) i') = ([], [IArith ITimes (IInt c) (IArith ITimes (IInd i) i')]) +iTimes (IArith ITimes (IInt c) i') (IInd i) = ([], [IArith ITimes (IInt c) (IArith ITimes (IInd i) i')]) +-- Product * Product +iTimes (IArith ITimes (IInt c) i) (IArith ITimes (IInt c') i') = + ([], [IArith ITimes (IInt $ c * c') (IArith ITimes i i')]) -- TODO: Not in the right form +iTimes (IArith ITimes i1 i2) e2@(IArith ITimes _ _) = + ([], [IArith ITimes (IInt 1) $ IArith ITimes i1 (IArith ITimes i2 e2)]) +-- Produce * Division +iTimes l@(IArith IDiv _ _) r@(IInt _) = ([], [IArith ITimes l r]) +iTimes l@(IInt _) r@(IArith IDiv _ _) = ([], [IArith ITimes l r]) +-- Error +iTimes _ _ = error ": not expected" + +-------------------------------------------------------------------------------- +-- Expectes a flat expression +distrSym :: IExpr id -> IExpr id +distrSym e = case e of + IInt n -> IInt (negate n) + ISym i -> i + + ISum l -> ISum $ map distrSym l -- always the entry point + + IArith ITimes (IInt c) i -> IArith ITimes (IInt (negate c)) i + IArith ITimes c _ -> IArith ITimes (distrSym c) e + IArith IDiv (IInt c) i -> IArith IDiv (IInt (negate c)) i + IArith IDiv c (IInt i) -> IArith IDiv c (IInt (negate i)) + IArith IDiv c i -> IArith IDiv (distrSym c) i + + IArith IModOp _ _ -> error ": <> mod" + IArith IPower _ _ -> error ": should never reach a power" + IInd _ -> error ": should never reach a index variable" + _ -> error "<>: missing case: " + +-------------------------------------------------------------------------------- + +listDiv :: [IExpr id] -> [IExpr id] -> IExpr id +listDiv [IInt l] [IInt r] = IInt $ mapIAOp IDiv l r +listDiv [IInt l] [IInd r] = IArith IDiv (IInt l) (IInd r) +listDiv [IInd l] [IInt r] = IArith IDiv (IInd l) (IInt r) +listDiv [IInd l] [IInd r] = IArith IDiv (IInd l) (IInd r) +listDiv l r = IArith IDiv (ISum l) (ISum r) + +-------------------------------------------------------------------------------- +-- This may not be enough to bring them to the top level +flatSum :: [IExpr id] -> [IExpr id] +flatSum l = let + (c, l') = aux l + in IInt (sum c) : concat l' + where + aux :: [IExpr id] -> ([Integer], [[IExpr id]]) + aux [] = ([], []) + aux (ISum (IInt n:l'):ls) = let + (ns, ls') = aux ls + in (n : ns, l' : ls') + aux (ISum l':ls) = let + (ns, ls') = aux ls + in (ns, l' : ls') + aux (x:ls) = let + (ns, ls') = aux ls + in (ns, [x]:ls') + +-------------------------------------------------------------------------------- +cmp :: Ord id => IExpr id -> IExpr id -> Ordering +cmp (IInt _) _ = LT +cmp _ (IInt _) = GT +cmp (IArith ITimes (IInt _) (IInd i)) (IArith ITimes (IInt _) (IInd i')) = + compare i i' +cmp (IArith op _ _) (IArith op' _ _) = + cmpIAOp op op' +cmp (ISum _) (IArith {}) = LT +cmp (IArith {}) (ISum _) = GT +cmp (ISum l) (ISum l') = cmpList l l' +cmp _ _ = error "Ordering: not expected: " +-- Lexicographic order +cmpList :: Ord id => [IExpr id] -> [IExpr id] -> Ordering +cmpList [] [] = EQ +cmpList [] _ = LT +cmpList _ [] = GT +cmpList (x:xs) (x':xs') = case cmp x x' of + EQ -> cmpList xs xs' + r -> r + +cmpIAOp :: IAOp -> IAOp -> Ordering +cmpIAOp ITimes _ = LT +cmpIAOp _ ITimes = GT +cmpIAOp IDiv _ = LT +cmpIAOp _ IDiv = GT +cmpIAOp IPower _ = LT +cmpIAOp _ IPower = GT +cmpIAOp IModOp _ = GT +cmpIAOp _ _ = error ": not expected" + +-- TODO: non-linear coeficients may need this as well +canonicalExpr :: Ord id => IExpr id -> IExpr id +canonicalExpr (ISum l) = revert $ ISum $ combine $ sortBy cmp l + where + + combine :: Eq id => [IExpr id] -> [IExpr id] + combine [] = [] + combine [i] = [i] + combine (e1@(IArith ITimes (IInt n) (IInd i)): e2@(IArith ITimes (IInt n') (IInd i')) : xs) = let r = n + n' + in if i == i' + then if r /= 0 + then combine (IArith ITimes (IInt r) (IInd i) : xs) + else combine xs + else e1 : combine (e2 : xs) + combine (x:xs) = x : combine xs + + revert :: IExpr id -> IExpr id + revert (ISum [i@(IInt _)]) = i + revert (ISum [IInt 0, IArith ITimes (IInt 1) v]) = v + revert (ISum (IInt 0 : xs)) = ISum $ concatMap aux xs + revert (ISum lst) = ISum $ concatMap aux lst + revert lst = lst + + aux (IArith ITimes (IInt 1) e) = [e] + aux (IArith ITimes (IInt 0) _) = [] + aux e = [e] +canonicalExpr e = e +-------------------------------------------------------------------------------- +mapIBOp :: IBOp -> Bool -> Bool -> Bool +mapIBOp IOr = boolOr +mapIBOp IXor = boolXor + +-------------------------------------------------------------------------------- +mapIAOp :: IAOp -> Integer -> Integer -> Integer +mapIAOp IMinus = integerMinus +mapIAOp ITimes = integerTimes +mapIAOp IPower = integerPower +mapIAOp IDiv = integerDiv +mapIAOp IModOp = integerMod + diff --git a/src/Language/CAO/Index/Utils.hs b/src/Language/CAO/Index/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Index/Utils.hs @@ -0,0 +1,78 @@ + +{- | +Module : $Header$ +Description : Useful function to manipulate indexes. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Index.Utils where + +import Language.CAO.Common.Literal +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.Var + +import Language.CAO.Index + +import Language.CAO.Syntax + +import Language.CAO.Type + +ind2Expr :: IExpr Var -> LExpr Var +-- TODO: Not handling int's +ind2Expr (IInt n) = genLoc $ Lit $ ILit n +ind2Expr (IInd v) = genLoc $ Var v +ind2Expr (ISum l) = aux l + where + aux :: [IExpr Var] -> LExpr Var + aux [] = error ": empty sum list" + aux [e] = ind2Expr e + -- TODO: HACK to handle type annotations + aux (e:es) = genLoc $ BinaryOp (ArithOp Plus) (annL RInt (ind2Expr e)) (annL RInt (aux es)) + + +ind2Expr (IArith op e1 e2) = genLoc $ + BinaryOp (ArithOp (iAOp2AOp op)) (annL RInt (ind2Expr e1)) (annL RInt (ind2Expr e2)) +ind2Expr (ISym e) = genLoc $ UnaryOp Sym (annL RInt (ind2Expr e)) + +iAOp2AOp :: IAOp -> AOp +iAOp2AOp IMinus = Minus +iAOp2AOp ITimes = Times +iAOp2AOp IPower = Power +iAOp2AOp IDiv = Div +iAOp2AOp IModOp = ModOp + +queryIndexTy :: IExpr Var -> Type Var +queryIndexTy (IInt _) = RInt -- TODO: what about Int's?? +queryIndexTy (IInd v) = varType v +queryIndexTy (ISym e) = queryIndexTy e +queryIndexTy (IArith _ e _) = queryIndexTy e +queryIndexTy (ISum (e:_)) = queryIndexTy e +queryIndexTy _ = error ": not expected" + +mapAOp :: AOp -> (IExpr id -> IExpr id -> IExpr id) +mapAOp Minus = (.-.) +mapAOp Times = (.*.) +mapAOp Power = (.**.) +mapAOp Div = (./.) +mapAOp ModOp = (.%.) +mapAOp _ = error ": not expected" + +mapBOp :: BOp -> (ICond id -> ICond id -> ICond id) +mapBOp Or = (.||.) +mapBOp Xor = (.^^.) +mapBOp _ = error ": not expected" + +mapCOp :: COp -> (IExpr id -> IExpr id -> ICond id) +mapCOp Eq = (.==.) +mapCOp Neq = (./=.) +mapCOp Lt = (.<.) +mapCOp Leq = (.<=.) +mapCOp Gt = (.>.) +mapCOp Geq = (.>=.) + diff --git a/src/Language/CAO/Parser/Config.hs b/src/Language/CAO/Parser/Config.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Parser/Config.hs @@ -0,0 +1,331 @@ + +{- +Module : $Header$ +Description : Parsing of the platform configuration. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Parser.Config ( loadConfig ) where + +import Control.Monad + +import Data.Array +import Data.Char (isSpace, isAlphaNum, isNumber) +import Data.ConfigFile +import Data.Function (on) +import Data.List(foldl', sortBy) +import Data.Maybe (fromMaybe) + +import Language.CAO.Platform.Literals +import Language.CAO.Platform.Specification +import Language.CAO.Platform.Naming + +loadConfig :: String -> IO TranslationSpec +loadConfig confFile = do + readStr <- readfile emptyCP confFile + case readStr of + Left e -> configError $ show e + Right cf -> let + gpec = readGlobalSpec cf + spec = emptyTranslationSpec { globalTransSpec = gpec } + fpec = readType cf (defaultSafety gpec) + in return $ foldl' fpec spec (sections cf) + +readGlobalSpec :: ConfigParser -> GlobalTransSpec +readGlobalSpec cff = GlobalTransSpec { + initProcName = readOptionDefault word' "initproc" + , disposeProcName = readOptionDefault word' "disposeproc" + , tpPrefix = readOptionDefault word' "typeprefix" + , callPrefix = readOptionDefault word' "callprefix" + , defaultHeader = readOptionDefault word' "header" + , defaultSafety = readOptionDefault parseSafety "safety" + , structFields = readOptionDefault parseFields "fields" + , wordSize = readOptionDefault parseWord "word"} + where + readOptionDefault p = run p . readOption cff "DEFAULT" + +readType :: ConfigParser -> SafetyConv -> TranslationSpec -> SectionSpec -> TranslationSpec +readType cff safe tinfo sspec = updateTypes typinfo tinfo nrWords caotypes + where + typinfo = TypeSpec { + nameInPlat = sspec + , headerFile = readOptionS word' "header" + , code = readOptionS word' "code" + , declConv = readOptionS parseCall "declaration" + , memoryConv = readOptionS parseMemory "memory" + , funcCall = readOptionS parseFReturn "return" + , operands = readOptionS parseConsts "operands" + , literal = Nothing + , operations = array (0, 36) (auxOpers opers) } + + nrWords = readOptionS parseSize "size" + caotypes = readOptionS parseType "type" + opcall = readOptionS parseOpCall "opcall" + opers = readOptionS (parseOperations opcall (operands typinfo) safe) "operations" + + readOptionS p = run p . readOption cff sspec + +-- Not very elegant solution + auxOpers = worker 0 . sortBy (compare `on` fst) + worker :: Int -> [(OpCode, (OpReturn, Consts, SafetyConv))] -> [(OpCode, Maybe (OpReturn, Consts, SafetyConv))] + worker 37 [] = [] + worker 37 _ = error "Not expected configuration" + worker n [] = (n, Nothing) : worker (n+1) [] + worker n l@((i, v):lst) = if n < i then (n, Nothing) : worker (n+1) l else (i, Just v) : worker (n+1) lst + + +updateTypes :: TypeSpec -> TranslationSpec -> Maybe (NumberOfWords, Maybe WordsPerChunk) -> [(String, Size)] -> TranslationSpec +updateTypes typinfo tspec nrWords = foldl' worker tspec + where + wordSz :: Maybe WordSize + wordSz = wordSize $ globalTransSpec tspec + + worker :: TranslationSpec -> (String, Size) -> TranslationSpec + worker ti (typ, siz) = case typ of + "bool" -> tworker ti typ (\ ti' -> ti' { boolT = Just typinfo } ) boolT + "struct" -> tworker ti typ (\ ti' -> ti' { structT = Just typinfo } ) structT + "modpol" -> tworker ti typ (\ ti' -> ti' { modpolT = Just typinfo } ) modpolT + "int" -> tworker ti typ (\ ti' -> ti' { intT = Just $ typinfo { literal = checkInt wordSz nrWords } } ) intT + "rint" -> tworker ti typ (\ ti' -> ti' { rintT = Just $ typinfo { literal = checkInt wordSz nrWords } } ) rintT + "ubits" -> ti { typeTransSpec = (typeTransSpec ti) { + ubitsT = (siz, typinfo { literal = checkBits wordSz siz nrWords }) : ubitsT (typeTransSpec ti) } } + "sbits" -> ti { typeTransSpec = (typeTransSpec ti) { + sbitsT = (siz, typinfo { literal = checkBits wordSz siz nrWords }) : sbitsT (typeTransSpec ti) } } + "vector" -> ti { typeTransSpec = (typeTransSpec ti) { + vectorT = (siz, typinfo) : vectorT (typeTransSpec ti) } } + "matrix" -> ti { typeTransSpec = (typeTransSpec ti) { + matrixT = (siz, typinfo) : matrixT (typeTransSpec ti) } } + "mod" -> ti { typeTransSpec = (typeTransSpec ti) { + modT = (siz, typinfo { literal = checkMod wordSz siz nrWords }) : modT (typeTransSpec ti) } } + _ -> configError $ "Not known type identifier: " ++ typ + + tworker :: TranslationSpec -> String -> (TypeTransSpec -> TypeTransSpec) -> (TypeTransSpec -> Maybe TypeSpec) -> TranslationSpec + tworker ti typ f1 sel = maybe + (ti {typeTransSpec = f1 (typeTransSpec ti) }) + (configError $ "Configuration already found for type: " ++ typ) + (sel (typeTransSpec ti)) + +configError :: String -> a +configError err = error $ + "[ERROR] There was an error in the configuration file:\n" ++ err + +readOption :: ConfigParser -> SectionSpec -> OptionSpec -> String +readOption cff sspec opt = + either (configError . ("Option not found: " ++) . show) id + ((get cff sspec opt)::Either CPError String) + +-------------------------------------------------------------------------------- +parseType :: ReadC [(String, Size)] +parseType = sepBy (comp (,) (word id) (option Generic (brackets tsize))) comma + +parseCall :: ReadC VarDeclaration +parseCall + = keyword VarDecl "var" + <|> keyword MacroDecl "macro" + +parseMemory :: ReadC VarMemory +parseMemory + = seqOpt (keyword Auto "auto") + (keyword AutoRef "ref") + Auto + <|> keyword Alloc "alloc" + +parseFReturn :: ReadC FuncReturn +parseFReturn + = keyword FFuncReturn "val" + <|> keyword FFuncRef "ref" + +parseOpCall :: ReadC OpReturn +parseOpCall + = seqOpt (keyword OMacroRef "macro") + (keyword OMacroReturn "val") + OMacroRef + <|> seqOpt (keyword OFuncRef "func") + (keyword OFuncReturn "val") + OFuncRef + +parseSafety :: ReadC SafetyConv +parseSafety + = keyword Safe "safe" + <|> keyword Unsafe "unsafe" + <|> keyword ArgSafe "arg_safe" + +parseConsts :: ReadC Consts +parseConsts + = keyword GlobalV "vars_global" + <|> keyword LocalV "vars_local" + <|> keyword Inlined "inlined" + <|> keyword Mixed "mixed" + +parseFields :: ReadC FieldsConv +parseFields + = keyword GlobalF "global" + <|> keyword InlinedF "inlined" + +parseWord :: ReadC (Maybe WordSize) +parseWord + = keyword Nothing "undefined" + <|> apply (Just . fromInteger) number + +parseSize :: ReadC (Maybe (NumberOfWords, Maybe WordsPerChunk)) +parseSize + = keyword Nothing "undefined" + <|> apply (Just . (\x -> (x, Nothing)) . fromInteger) number + <|> comp (\ _ (n1, n2) -> Just (fromInteger n1, Just $ fromInteger n2)) + (keyword () "split") + (pair number number) + +parseOperations :: OpReturn -> Consts -> SafetyConv -> ReadC [(OpCode, (OpReturn, Consts, SafetyConv))] +parseOperations defaultRet operand safe = + sepBy (comp (,) parseOperation + (option (defaultRet, operand, safe) (parens $ + perm3 comma + parseOpCall + parseConsts + parseSafety + defaultRet operand safe))) comma + +parseOperation :: ReadC OpCode +parseOperation = word aux + where + aux w = fromMaybe + (parseError $ "Not expected operation name: `" ++ w ++ "'") $ getCode w + +-------------------------------------------------------------------------------- +type ReadC a = String -> Either String (String, a) + +parseError :: String -> a +parseError err = error $ + "[ERROR] There was a parsing error while reading the configuration file:\n" ++ + err + +run :: ReadC a -> String -> a +run p str = case p str of + Left err -> parseError err + Right (str', v) -> + if null str' + then v + else parseError $ "Trailing string not expected: `" ++ str' ++ + "' while reading `" ++ str ++ "'" + +sepBy :: ReadC a -> ReadC sep -> ReadC [a] +sepBy p psep str = do + (str', v) <- p str + if null str' then return (str', [v]) + else do + (str'', _) <- psep str' + (str''', lv) <- sepBy p psep str'' + return (str''', v : lv) + +comp :: (a -> b -> c) -> ReadC a -> ReadC b -> ReadC c +comp f p1 p2 str = do + (str1, v1) <- p1 str + (str2, v2) <- p2 str1 + return (str2, f v1 v2) + +inject :: a -> ReadC a +inject d = \ s -> return (s, d) + +(<|>) :: ReadC a -> ReadC a -> ReadC a +(p1 <|> p2) str = p1 str `mplus` p2 str + +option :: a -> ReadC a -> ReadC a +option a p str = p str `mplus` return (str, a) + +comma :: ReadC () +comma (',' : str) = white str +comma str = Left $ "Expected comma before `" ++ str ++ "'" + +white :: ReadC () +white str = return (dropWhile isSpace str, ()) + +delim :: Char -> Char -> ReadC a -> ReadC a +delim co cc p (co' : str) | co == co' = do + (str', _) <- white str + (str'', v) <- p str' + when (null str'' || head str'' /= cc) $ Left $ + "Expected delimiters `" ++ [co] ++ "' `" ++ [cc] ++ "' around `" ++ + str' ++ "'" + (str''', _) <- white (tail str'') + return (str''', v) +delim co cc _ _ = Left $ "Expected delimiters `" ++ [co] ++ "' `" ++ [cc] ++ "'" + +parens :: ReadC a -> ReadC a +parens = delim '(' ')' + +brackets :: ReadC a -> ReadC a +brackets = delim '[' ']' + +number :: ReadC Integer +number str = do + let (n, str') = span isNumber str + when (null n) $ Left $ "Expected number in `" ++ str ++ "'" + (str'', _) <- white str' + return (str'', (read n::Integer)) + +keyword :: a -> String -> ReadC a +keyword val key str = do + (str', w) <- word id str + if key == w + then return (str', val) + else Left $ + "Expected keyword `" ++ key ++ "'. Got `" ++ w ++ "' instead." + +word :: (String -> b) -> ReadC b +word f str = do + let (w, str') = span (\ c -> isAlphaNum c || c == '.' || c == '_') str + (ww, _) <- white str' + return (ww, f w) + +word' :: ReadC String +word' = word id + +tsize :: ReadC Size +tsize str = do + (str', n1) <- option 0 number str + if n1 == 0 + then return (str', Generic) + else if not (null str') && head str' == 'x' + then do + (str'', _) <- white (tail str') + (str''', n2) <- option 0 number str'' + if n2 == 0 + then Left "Invalid size (0)" + else return (str''', MSize n1 n2) + else return (str', Simple n1) + +perm2 :: ReadC () -> ReadC a -> ReadC b -> a -> b -> ReadC (a, b) +perm2 sep p1 p2 d1 d2 = + comp (,) p1 (comp (curry snd) sep p2) <|> + comp (flip (,)) p2 (comp (curry snd) sep p1) <|> + comp (,) p1 (inject d2) <|> + comp (,) (inject d1) p2 + +perm3 :: ReadC () -> ReadC a -> ReadC b -> ReadC c -> a -> b -> c -> ReadC (a, b, c) +perm3 sep p1 p2 p3 d1 d2 d3 = + comp (\ x (y, z) -> (x, y, z)) p1 (comp (curry snd) sep (perm2 sep p2 p3 d2 d3)) <|> + comp (\ (y, z) x -> (x, y, z)) (perm2 sep p2 p3 d2 d3) (comp (curry snd) sep p1) <|> + comp (\ x (y, z) -> (x, y, z)) p1 (inject (d2, d3)) <|> + comp (\ x (y, z) -> (x, y, z)) (inject d1) (perm2 sep p2 p3 d2 d3) + +seqOpt :: ReadC a -> ReadC b -> b -> ReadC b +seqOpt p1 p2 d1 = comp (\_ y -> y) p1 (option d1 (parens p2)) + +apply :: (a -> b) -> ReadC a -> ReadC b +apply f p str = do + (str', v) <- p str + return (str', f v) + +pair :: ReadC a -> ReadC b -> ReadC (a, b) +pair p1 p2 = parens (\ str -> do + (str', v1) <- p1 str + (str'', _) <- comma str' + (str''', v2) <- p2 str'' + return (str''', (v1, v2))) + diff --git a/src/Language/CAO/Parser/Lexer.x b/src/Language/CAO/Parser/Lexer.x new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Parser/Lexer.x @@ -0,0 +1,224 @@ +{ + +{-# OPTIONS_GHC -w #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} + +{- +Module : $Header$ +Description : CAO language lexer. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Parser.Lexer where + +import Control.Monad.Error +import Control.Monad.State + +import Language.CAO.Common.Error +import Language.CAO.Common.Outputable +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.Utils (ifM, split) + +import Language.CAO.Parser.Tokens + +import Language.CAO.Semantics.Bits (stringToBits) +} + +%wrapper "monadUserState" + +$digit = [0-9] +$hexdig = [0-9A-Fa-f] +$bindig = [01] +$alpha = [A-Za-z] +$alphaext = [0-9A-Za-z'_] + +@identifier = $alpha$alphaext* +@number = $digit+ +@hexnumber = 0x$hexdig+ +@binnumber = 0b$bindig+ +@signbinnumber = 1b$bindig+ + + +tokens :- + +<0> def { lexerTokenInfo TokenDef } +<0> typedef { lexerTokenInfo TokenTypedef } +<0> const { lexerTokenInfo TokenConst } +<0> \: { lexerTokenInfo TokenOfType } +<0> of { lexerTokenInfo TokenOf } +<0> \:= { lexerTokenInfo TokenAssign } +<0> return { lexerTokenInfo TokenReturn } +<0> \[ { lexerTokenInfo TokenOSB } +<0> \] { lexerTokenInfo TokenCSB } +<0> \{ { lexerTokenInfo TokenOCB } +<0> \} { lexerTokenInfo TokenCCB } +<0> \; { lexerTokenInfo TokenSemiColon } +<0> \, { lexerTokenInfo TokenComma } +<0> \.\. { lexerTokenInfo TokenDoublePeriod } +<0> \. { lexerTokenInfo TokenPeriod } +<0> true { lexerTokenInfo TokenTrue } +<0> false { lexerTokenInfo TokenFalse } +<0> void { lexerTokenInfo TokenVoid } +<0> unsigned { lexerTokenInfo TokenUnsigned } +<0> signed { lexerTokenInfo TokenSigned } +<0> register { lexerTokenInfo TokenRegister } +<0> int { lexerTokenInfo TokenInt } +<0> bits { lexerTokenInfo TokenBits } +<0> bool { lexerTokenInfo TokenBool } +<0> vector { lexerTokenInfo TokenVector } +<0> matrix { lexerTokenInfo TokenMatrix } +<0> mod { lexerTokenInfo TokenMod } +<0> struct { lexerTokenInfo TokenStruct } +<0> if { lexerTokenInfo TokenIf } +<0> else { lexerTokenInfo TokenElse } +<0> while { lexerTokenInfo TokenWhile } +<0> seq { lexerTokenInfo TokenSeq } +<0> by { lexerTokenInfo TokenBy } +<0> to { lexerTokenInfo TokenTo } +<0> == { lexerTokenInfo TokenEq } +<0> \&\& { lexerTokenInfo TokenAnd } +<0> \|\| { lexerTokenInfo TokenOr } +<0> \>= { lexerTokenInfo TokenGET } +<0> \<= { lexerTokenInfo TokenLET } +<0> \> { lexerTokenInfo TokenGT } +<0> \< { lexerTokenInfo TokenLT } +<0> ! { lexerTokenInfo TokenNot } +<0> != { lexerTokenInfo TokenNotEqual } +<0> \^\^ { lexerTokenInfo TokenXor } +<0> \+ { lexerTokenInfo TokenPlus } +<0> \- { lexerTokenInfo TokenMinus } +<0> \* { lexerTokenInfo TokenTimes } +<0> \/ { lexerTokenInfo TokenDiv } +<0> \*\* { lexerTokenInfo TokenPower } +<0> \% { lexerTokenInfo TokenRemainder } +<0> \~ { lexerTokenInfo TokenBitNot } +<0> \& { lexerTokenInfo TokenBitAnd } +<0> \| { lexerTokenInfo TokenBitOr } +<0> \^ { lexerTokenInfo TokenBitXor } +<0> \<\< { lexerTokenInfo TokenShiftUp } +<0> \>\> { lexerTokenInfo TokenShiftDown } +<0> \<\| { lexerTokenInfo TokenRotUp } +<0> \|\> { lexerTokenInfo TokenRotDown } +<0> @ { lexerTokenInfo TokenConcat } +<0> \( { lexerTokenInfo TokenOB } +<0> \) { lexerTokenInfo TokenCB } + +<0> @number { lexerTokenInfoFunc handleIntValue } +<0> @hexnumber { lexerTokenInfoFunc handleIntValue } +<0> @identifier { lexerTokenInfoFunc handleStr } +<0> @binnumber { lexerTokenInfoFunc (handleBitsValue + TokenUnsignedBitsValue) } +<0> @signbinnumber { lexerTokenInfoFunc (handleBitsValue + TokenSignBitsValue) } + +<0> "//".* ; +<0> \/\* { enterNewComment } + \/\* { embedComment } + \*\/ { unembedComment } + +<0> $white+ ; + $white+ ; +<0> . { lexerTokenInfoFunc handleError } + . ; + +{ + +-- Token Functions ------------------------------------------------------------- + +lexerTokenInfo :: Token -> AlexInput -> Int -> Alex TokenInfo +lexerTokenInfo t (AlexPn a ln c, _, _, s) l = + return $ TokenInfo t (take l $ s) (srcLoc ln c a) + +lexerTokenInfoFunc :: (String -> Alex Token) -> AlexInput -> Int -> Alex TokenInfo +lexerTokenInfoFunc f (AlexPn a ln c, _, _, s) l = do + r <- f (take (fromIntegral l) s) + return $ TokenInfo r (take (fromIntegral l) s) (srcLoc ln c a) + +handleIntValue :: String -> Alex Token +handleIntValue = return . TokenIntValue . read + +handleBitsValue :: ([Bool] -> Token) -> String -> Alex Token +handleBitsValue cnstr = return . cnstr . stringToBits . drop 2 + +handleStr :: String -> Alex Token +handleStr s = do + aus <- get + return $ ifM (`elem` types aus) TokenTypeAlias TokenStr s + +handleError :: String -> Alex Token +handleError _ = return TokenError + +enterNewComment :: AlexInput -> Int -> Alex TokenInfo +enterNewComment input len = do + modify (\ aus -> aus { commentDepth = 1 } ) + alexSetStartCode comment + skip input len + +embedComment :: AlexInput -> Int -> Alex TokenInfo +embedComment input len = do + modify (\ aus -> aus { commentDepth = commentDepth aus + 1 }) + skip input len + +unembedComment :: AlexInput -> Int -> Alex TokenInfo +unembedComment input len = do + aus <- get + let cd = commentDepth aus + put (aus { commentDepth = cd - 1 }) + when (cd == 1) $ alexSetStartCode 0 + skip input len + +-- Alex Functions -------------------------------------------------------------- + +data AlexUserState = AlexUserState + { filename :: !String + , types :: [String] + , commentDepth :: Integer + } + +alexInitUserState :: AlexUserState +alexInitUserState = AlexUserState "" [] 0 + +instance MonadState AlexUserState Alex where + get = alexGetUserState + put = alexSetUserState + +instance MonadError CaoError Alex where + throwError e = Alex $ \ s -> Left (show e) + catchError (Alex un) f = Alex $ \ s -> either (catchMe s) Right (un s) + where + catchMe s = fmap (split (const s) id) . runAlex "" . f . read + +alexSetUserState :: AlexUserState -> Alex () +alexSetUserState ust = Alex $ \ s -> Right (s {alex_ust = ust}, ()) + +alexGetUserState :: Alex AlexUserState +alexGetUserState = Alex $ \ s -> Right (s, alex_ust s) + +alexEOF :: Alex TokenInfo +alexEOF = do + (AlexPn a ln c, _, _, _) <- alexGetInput + return $ TokenInfo TokenEOF "" (srcLoc ln c a) + + +-- Processing Functions -------------------------------------------------------- + +getTokens :: Alex [TokenInfo] +getTokens = do + tok <- alexMonadScan + case tSymb tok of + TokenEOF -> return [tok] + _ -> liftM (tok:) getTokens + +flushLexer :: Alex () +flushLexer = getTokens >> return () + +} + diff --git a/src/Language/CAO/Parser/Parser.y b/src/Language/CAO/Parser/Parser.y new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Parser/Parser.y @@ -0,0 +1,556 @@ +{ + +{- +Module : $Header$ +Description : CAO language parser. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Parser.Parser ( + parseFile, + parseCao, + parseCommand, + Command(..), + ) where + +import Control.Monad.Error +import Control.Monad.State + +import Language.CAO.Common.Error +import Language.CAO.Common.Literal +import Language.CAO.Common.Monad +import Language.CAO.Common.Polynomial +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.Var + +import Language.CAO.Parser.Lexer +import Language.CAO.Parser.Tokens + +import Language.CAO.Syntax + +import Language.CAO.Type + +} + +%name parse +%name parseDef Definition +%name parseStmt Statement +%name parseExpr Expression + +%tokentype { TokenInfo } +%error { parseError } +%monad { Alex } +%lexer { lexer }{ TokenInfo TokenEOF _ _ } + +%token + +def { TokenInfo TokenDef _ _ } +typedef { TokenInfo TokenTypedef _ _ } +const { TokenInfo TokenConst _ _ } +':' { TokenInfo TokenOfType _ _ } +of { TokenInfo TokenOf _ _ } +':=' { TokenInfo TokenAssign _ _ } +return { TokenInfo TokenReturn _ _ } +'[' { TokenInfo TokenOSB _ _ } +']' { TokenInfo TokenCSB _ _ } +'{' { TokenInfo TokenOCB _ _ } +'}' { TokenInfo TokenCCB _ _ } +';' { TokenInfo TokenSemiColon _ _ } +',' { TokenInfo TokenComma _ _ } +'..' { TokenInfo TokenDoublePeriod _ _ } +'.' { TokenInfo TokenPeriod _ _ } + +true { TokenInfo TokenTrue _ _ } +false { TokenInfo TokenFalse _ _ } +intLit { TokenInfo (TokenIntValue _) _ _ } +bitsLit { TokenInfo (TokenUnsignedBitsValue _) _ _ } +signbitsLit { TokenInfo (TokenSignBitsValue _) _ _ } +str { TokenInfo (TokenStr _) _ _ } +type_alias { TokenInfo (TokenTypeAlias _) _ _ } + +void { TokenInfo TokenVoid _ _ } +unsigned { TokenInfo TokenUnsigned _ _ } +signed { TokenInfo TokenSigned _ _ } +register { TokenInfo TokenRegister _ _ } +int { TokenInfo TokenInt _ _ } +bits { TokenInfo TokenBits _ _ } +bool { TokenInfo TokenBool _ _ } +vector { TokenInfo TokenVector _ _ } +matrix { TokenInfo TokenMatrix _ _ } +mod { TokenInfo TokenMod _ _ } +struct { TokenInfo TokenStruct _ _ } + +if { TokenInfo TokenIf _ _ } +else { TokenInfo TokenElse _ _ } +while { TokenInfo TokenWhile _ _ } +seq { TokenInfo TokenSeq _ _ } +to { TokenInfo TokenTo _ _ } +by { TokenInfo TokenBy _ _ } + +'==' { TokenInfo TokenEq _ _ } +'&&' { TokenInfo TokenAnd _ _ } +'||' { TokenInfo TokenOr _ _ } +'>=' { TokenInfo TokenGET _ _ } +'<=' { TokenInfo TokenLET _ _ } +'>' { TokenInfo TokenGT _ _ } +'<' { TokenInfo TokenLT _ _ } +'!' { TokenInfo TokenNot _ _ } +'!=' { TokenInfo TokenNotEqual _ _ } +'^^' { TokenInfo TokenXor _ _ } + +'+' { TokenInfo TokenPlus _ _ } +'-' { TokenInfo TokenMinus _ _ } +'*' { TokenInfo TokenTimes _ _ } +'/' { TokenInfo TokenDiv _ _ } +'**' { TokenInfo TokenPower _ _ } +'%' { TokenInfo TokenRemainder _ _ } + +'~' { TokenInfo TokenBitNot _ _ } +'&' { TokenInfo TokenBitAnd _ _ } +'|' { TokenInfo TokenBitOr _ _ } +'^' { TokenInfo TokenBitXor _ _ } +'<<' { TokenInfo TokenShiftUp _ _ } +'>>' { TokenInfo TokenShiftDown _ _ } +'<|' { TokenInfo TokenRotUp _ _ } +'|>' { TokenInfo TokenRotDown _ _ } +'@' { TokenInfo TokenConcat _ _ } + +'(' { TokenInfo TokenOB _ _ } +')' { TokenInfo TokenCB _ _ } + + + +-- precedences from the CAO Language manual +%right ':=' +%left ',' +%left '..' + +%left '||' +%left '^^' +%left '&&' +%left '|' +%left '^' +%left '&' +%left '==' '!=' +%left '<' '<=' '>' '>=' +%left '>>' '<<' '|>' '<|' +%left '+' '-' +%left '*' '/' '%' '@' +%left '**' +%right CAST +%right '!' '~' UNARY_MINUS +%left '.' '[' ']' + +%% + + +Prog :: { Prog Name } +Prog : Definitions { Prog $1 Nothing } + + +-- Definitions ----------------------------------------------------------------- + +Definitions :: { [LDef Name] } +Definitions + : Definition { [$1] } + | Definition Definitions { $1:$2 } + +Definition :: { LDef Name } +Definition + : VarDecl ';' { fmap VarDef $1 } + | ConstDecl ';' { fmap ConstDef $1 } + | TypeDef { fmap TyDef $1 } + | Func { fmap FunDef $1 } + +VarDecl :: { Located (VarDecl Name) } +VarDecl + : def str ':' TypeDecl { la $1 (VarD (str2Name $2) (unLoc $4) Nothing) } + | def Strings2 ':' TypeDecl { la $1 (MultiD (map str2Name $2) (unLoc $4)) } + | def str ':' TypeDecl ':=' Expression { la $1 (VarD (str2Name $2) (unLoc $4) (Just (nullTyp $6))) } + | def str ':' TypeDecl ':=' '{' Expressions '}' { la $1 (ContD (str2Name $2) (unLoc $4) (map nullTyp $7)) } + +ConstDecl :: { Located (ConstDecl Name) } +ConstDecl + : def const str ':' TypeDecl { la $1 (ConstD (str2Name $3) (unLoc $5) None) } + | def const str ':' TypeDecl ':=' Expression { la $1 (ConstD (str2Name $3) (unLoc $5) (ConstInit $7)) } + | def const str ':' TypeDecl '{' Expression '}' { la $1 (ConstD (str2Name $3) (unLoc $5) (ConstCond $7)) } + | def const Strings2 ':' TypeDecl { la $1 (MultiConstD (map str2Name $3) (unLoc $5) Nothing) } + | def const Strings2 ':' TypeDecl '{' Expression '}' { la $1 (MultiConstD (map str2Name $3) (unLoc $5) (Just $7) ) } + +Strings2 :: { [TokenInfo] } +Strings2 + : str ',' str { [$1, $3] } + | str ',' Strings2 { $1:$3 } + + +-- TypeDecls ------------------------------------------------------------------- + +TypeDecls :: { [LTyDecl Name] } +TypeDecls + : TypeDecl { [$1] } + | TypeDecls ',' TypeDecl { $1 ++ [$3] } + +TypeDecl :: { LTyDecl Name } +TypeDecl + : int { la $1 IntD } + | register int { la $1 RIntD } + | bool { la $1 BoolD } + | unsigned bits '[' Expression ']' { la $1 (BitsD U $4) } + | signed bits '[' Expression ']' { la $1 (BitsD S $4) } + | mod '[' Expression ']' { la $1 (ModD (ModNum $3)) } + | mod '[' TypeDecl '<' str '>' '/' Polynomial ']' { la $1 (ModD (ModPol (unLoc $3) (unLoc $ str2PolInd $5) (unLoc $8))) } + | vector '[' Expression ']' of TypeDecl { la $1 (VectorD $3 (unLoc $6)) } + | matrix '[' Expression ',' Expression ']' of TypeDecl { la $1 (MatrixD $3 $5 (unLoc $8)) } + | type_alias { la $1 (TySynD (str2Tv $1)) } + + +-- Polynomials ----------------------------------------------------------------- + +Polynomial :: { Located (Pol Name) } +Polynomial + : Monomial {% checkPol (getLoc $1) (mon (unLoc $1)) } + | '-' Monomial {% checkPol (tLoc $1) (mon (neg (unLoc $2))) } + | Polynomial '+' Monomial {% checkPol (getLoc $1) ((unLoc $3) .+. (unLoc $1)) } + | Polynomial '-' Monomial {% checkPol (getLoc $1) ((neg (unLoc $3)) .+. (unLoc $1)) } + +Monomial :: { Located (Mon Name) } +Monomial + : str { la $1 (intC 1 .*. (unLoc $ str2PolInd $1) .^. 1 )} + | str '**' intLit { la $1 (intC 1 .*. (unLoc $ str2PolInd $1) .^. (int_value $ tSymb $3) )} + | intLit { la $1 (intC (int_value $ tSymb $1) .*. EZero )} + | intLit '*' str { la $1 (intC (int_value $ tSymb $1) .*. (unLoc $ str2PolInd $3) .^. 1 )} + | intLit '*' str '**' intLit { la $1 (intC (int_value $ tSymb $1) .*. (unLoc $ str2PolInd $3) .^. (int_value $ tSymb $5) )} + | '(' Polynomial ')' { la $1 (polC (unLoc $2) .*. EZero )} + | '(' Polynomial ')' '*' str { la $1 (polC (unLoc $2) .*. (unLoc $ str2PolInd $5) .^. 1 )} + | '(' Polynomial ')' '*' str '**' intLit { la $1 (polC (unLoc $2) .*. (unLoc $ str2PolInd $5) .^. (int_value $ tSymb $7) )} + + +-- Expressions ----------------------------------------------------------------- + +Expressions0 :: { [LExpr Name]} +Expressions0 + : {- empty -} { [] } + | Expressions { $1 } + +Expressions :: { [LExpr Name]} +Expressions + : Expression { [$1] } + | Expression ',' Expressions { ($1:$3) } + +Expression :: { LExpr Name } +Expression + : Literal { lg $1 (Lit (unLoc $1)) } + | str { la $1 (Var (unLoc $ str2Name $1)) } + | str '(' Expressions0 ')' { la $1 (FunCall (str2FName $1) (map nullTyp $3)) } + | Expression '.' str { lg $1 (StructProj (nullTyp $1) (unLoc (str2SFldName $3))) } + + | '-' Expression %prec UNARY_MINUS { la $1 (UnaryOp Sym (nullTyp $2)) } + | '!' Expression { la $1 (UnaryOp Not (nullTyp $2)) } + | '~' Expression { la $1 (UnaryOp BNot (nullTyp $2)) } + | Expression '+' Expression { lg $1 (BinaryOp (ArithOp Plus) (nullTyp $1) (nullTyp $3)) } + | Expression '-' Expression { lg $1 (BinaryOp (ArithOp Minus) (nullTyp $1) (nullTyp $3)) } + | Expression '*' Expression { lg $1 (BinaryOp (ArithOp Times) (nullTyp $1) (nullTyp $3)) } + | Expression '**' Expression { lg $1 (BinaryOp (ArithOp Power) (nullTyp $1) (nullTyp $3)) } + | Expression '/' Expression { lg $1 (BinaryOp (ArithOp Div) (nullTyp $1) (nullTyp $3)) } + | Expression '%' Expression { lg $1 (BinaryOp (ArithOp ModOp) (nullTyp $1) (nullTyp $3)) } + + | Expression '==' Expression { lg $1 (BinaryOp (CmpOp Bullet Eq) (nullTyp $1) (nullTyp $3)) } + | Expression '!=' Expression { lg $1 (BinaryOp (CmpOp Bullet Neq) (nullTyp $1) (nullTyp $3)) } + | Expression '<' Expression { lg $1 (BinaryOp (CmpOp Bullet Lt) (nullTyp $1) (nullTyp $3)) } + | Expression '<=' Expression { lg $1 (BinaryOp (CmpOp Bullet Leq) (nullTyp $1) (nullTyp $3)) } + | Expression '>' Expression { lg $1 (BinaryOp (CmpOp Bullet Gt) (nullTyp $1) (nullTyp $3)) } + | Expression '>=' Expression { lg $1 (BinaryOp (CmpOp Bullet Geq) (nullTyp $1) (nullTyp $3)) } + + | Expression '||' Expression { lg $1 (BinaryOp (BoolOp Or) (nullTyp $1) (nullTyp $3)) } + | Expression '&&' Expression { lg $1 (BinaryOp (BoolOp And) (nullTyp $1) (nullTyp $3)) } + | Expression '^^' Expression { lg $1 (BinaryOp (BoolOp Xor) (nullTyp $1) (nullTyp $3)) } + + | Expression '|' Expression { lg $1 (BinaryOp (BitOp BWOr) (nullTyp $1) (nullTyp $3)) } + | Expression '&' Expression { lg $1 (BinaryOp (BitOp BWAnd) (nullTyp $1) (nullTyp $3)) } + | Expression '^' Expression { lg $1 (BinaryOp (BitOp BWXor) (nullTyp $1) (nullTyp $3)) } + + | Expression '<<' Expression { lg $1 (BinaryOp (BitsSROp SUp) (nullTyp $1) (nullTyp $3)) } + | Expression '>>' Expression { lg $1 (BinaryOp (BitsSROp SDown) (nullTyp $1) (nullTyp $3)) } + | Expression '<|' Expression { lg $1 (BinaryOp (BitsSROp RUp) (nullTyp $1) (nullTyp $3)) } + | Expression '|>' Expression { lg $1 (BinaryOp (BitsSROp RDown) (nullTyp $1) (nullTyp $3)) } + | Expression '@' Expression { lg $1 (BinaryOp Concat (nullTyp $1) (nullTyp $3)) } + + | Expression APat { lg $1 (Access (nullTyp $1) $2) } + + | '(' TypeDecls ')' Expression %prec CAST { la $1 (Cast True $2 (nullTyp $4)) } + | '(' Expression ')' { $2 } + +APat :: { APat Name } +APat + : '[' Expression ']' { VectP (CElem (nullTyp $2)) } + | '[' Expression '..' Expression ']' { VectP (CRange (nullTyp $2) (nullTyp $4)) } + | '[' Expression ',' Expression ']' { MatP (CElem (nullTyp $2)) (CElem (nullTyp $4)) } + | '[' Expression '..' Expression ',' + Expression '..' Expression ']' { MatP (CRange (nullTyp $2) (nullTyp $4)) (CRange (nullTyp $6) (nullTyp $8)) } + | '[' Expression ',' + Expression '..' Expression ']' { MatP (CElem (nullTyp $2)) (CRange (nullTyp $4) (nullTyp $6)) } + | '[' Expression '..' Expression ',' + Expression ']' { MatP (CRange (nullTyp $2) (nullTyp $4)) (CElem (nullTyp $6)) } +-- Literal --------------------------------------------------------------------- + +Literal :: { Located (Literal Name) } +Literal + : intLit { la $1 (ILit (int_value $ tSymb $1)) } + | bitsLit { la $1 (BSLit U (bit_value $ tSymb $1)) } + | signbitsLit { la $1 (BSLit S (bit_value $ tSymb $1)) } + | '[' Polynomial ']' { la $1 (PLit (unLoc $2)) } + | true { la $1 (BLit True) } + | false { la $1 (BLit False) } + +-- TypeDef --------------------------------------------------------------------- + +TypeDef :: { Located (TyDef Name) } +TypeDef + : typedef str ':=' TypeDecl ';' {% doTypeSynonymDecl (tLoc $1) $2 (unLoc $4) } + | typedef str ':=' struct '[' StructFieldDecls ']' ';' {% doStructDecl (tLoc $1) $2 $6 } + +StructFieldDecls :: { [(Located Name, TyDecl Name)] } +StructFieldDecls + : StructFieldDecl { [$1] } + | StructFieldDecls StructFieldDecl { $1 ++ [$2] } + +StructFieldDecl :: { (Located Name, TyDecl Name) } +StructFieldDecl + : def str ':' TypeDecl ';' { (str2SFldName $2, unLoc $4) } + + +-- Function -------------------------------------------------------------------- + +Func :: { Located (Fun Name) } +Func + : def str '(' Args0 ')' ':' ReturnTypes '{' Statements '}' { la $1 $ Fun (str2FName $2) $4 $7 $9 } + +ReturnTypes :: { [TyDecl Name] } +ReturnTypes + : TypeDecls { map unLoc $1 } + | void { [] } + +Args0 :: { [Arg Name]} +Args0 + : {- empty -} { [] } + | Args { $1 } + +Args :: { [Arg Name]} +Args + : Arg { [$1] } + | ArgList { $1 } + | Args ',' Arg { $1 ++ [$3] } + | Args ',' ArgList { $1 ++ $3 } + +Arg :: { Arg Name } +Arg : str ':' TypeDecl { Arg (str2Name $1) (unLoc $3) } + | const str ':' TypeDecl { ArgConst (str2Name $2) (unLoc $4) Nothing } + | const str ':' TypeDecl '{' Expression '}' { ArgConst (str2Name $2) (unLoc $4) (Just $6) } + +ArgList :: { [Arg Name] } +ArgList + : Strings2 ':' TypeDecl { map (flip Arg (unLoc $3) . str2Name) $1 } + | const Strings2 ':' TypeDecl { map (\c -> ArgConst (str2Name c) (unLoc $4) Nothing) $2 } + +-- Statements ------------------------------------------------------------------ + +Statements :: { [LStmt Name] } +Statements + : Statement { [$1] } + | Statements Statement { $1 ++ [$2] } + +Statement :: { LStmt Name } +Statement + : VarDecl ';' { fmap VDecl $1 } + | ConstDecl ';' { fmap CDecl $1 } + | Assignment ';' { $1 } + | FunctionCallStatement ';' { $1 } + | return Expressions0 ';' { la $1 (Ret (map nullTyp $2)) } + | IfThenElseStatement { $1 } + | WhileStatement { $1 } + | SeqStatement { $1 } + +Assignment :: { LStmt Name } +Assignment + : LValues ':=' Expressions { lg $1 (Assign (unLoc $1) (map nullTyp $3)) } + +LValues :: { Located [LVal Name] } +LValues + : LValue { lg $1 [unLoc $1] } + | LValues ',' LValue { lg $1 (unLoc $1 ++ [unLoc $3]) } + +LValue :: { Located (LVal Name) } +LValue + : str { la $1 (LVVar (str2Name $1)) } + | LValue '.' str { lg $1 (LVStruct (unLoc $1) (unLoc $ str2SFldName $3)) } + | LValue APat { lg $1 (LVCont Bullet (unLoc $1) $2) } + +FunctionCallStatement :: { LStmt Name } +FunctionCallStatement + : str '(' Expressions0 ')' { la $1 (FCallS (unLoc $ str2FName $1) (map nullTyp $3)) } + + +-- Control Statements ---------------------------------------------------------- + +IfThenElseStatement :: { LStmt Name } +IfThenElseStatement + : if '(' Expression ')' '{' Statements '}' { la $1 (Ite (nullTyp $3) $6 Nothing) } + | if '(' Expression ')' '{' Statements '}' + else '{' Statements '}' { la $1 (Ite (nullTyp $3) $6 (Just $10)) } + +WhileStatement :: { LStmt Name } +WhileStatement + : while '(' Expression ')' '{' Statements '}' { la $1 (While (nullTyp $3) $6) } + +SeqStatement :: { LStmt Name } +SeqStatement + : seq str ':=' Expression to Expression '{' Statements '}' { la $1 (Seq (SeqIter (unLoc $ str2Name $2) $4 $6 Nothing (SimpleRng [])) $8) } + | seq str ':=' Expression to Expression by Expression '{' Statements '}' { la $1 (Seq (SeqIter (unLoc $ str2Name $2) $4 $6 (Just $8) (SimpleRng [])) $10) } + + +{ + +data Command a + = CmdDefinition (LDef a) + | CmdStatement (LStmt a) + | CmdExp (LExpr a) + + +-- Parser Functions ------------------------------------------------------------ + +parseFile :: CaoMonad m + => String -> m (Prog Name) +parseFile fn = liftIO (readFile fn) >>= parseCao + +parseCao :: CaoMonad m + => String -> m (Prog Name) +parseCao str = do + file <- getFileName + injectResult $ runAlex str (put (aus file) >> parse) + where + aus fln = alexInitUserState { filename = fln } + +parseCommand :: CaoMonad m + => [Name] -> String -> m (Command Name) +parseCommand types str = do + file <- getFileName + injectResult $ runAlex str (put (aus file) >> parseCmd) + where + aus fln = alexInitUserState { filename = fln, types = map nameStr types } + +parseCmd :: Alex (Command Name) +parseCmd = do { inp <- alexGetInput; + ust <- get; + fnm <- gets filename; + liftM CmdDefinition parseDef + `catchError` \ md -> + do alexSetInput inp + put ust + liftM CmdStatement parseStmt + `catchError` \ ms -> + do alexSetInput inp + put ust + liftM CmdExp parseExpr + `catchError` \ me -> + throwError $ mkCaoError defSrcLoc fnm + (MultipleErr [md, ms, me]::ErrorCode String) + } + +lexer :: (TokenInfo -> Alex a) -> Alex a +lexer cont = alexMonadScan >>= cont + +parseError :: TokenInfo -> Alex a +parseError info = do + flushLexer + f <- gets filename + let e = case tSymb info of + TokenError -> LexicalException (tText info) + TokenEOF -> EOFException + _ -> ParsingException (tText info) + throwError $ mkCaoError (tLoc info) f $ (ParserException e::ErrorCode Name) + {- + let throw :: ParserException -> Alex a + --let throw :: ErrorCode String -> Alex a + throw = throwError . mkCaoError (tLoc info) f . ParserException + case tSymb info of + TokenError -> throw $ LexicalException (tText info) + TokenEOF -> throw EOFException + _ -> throw $ ParsingException (tText info) + -} + +-- Auxiliary Functions --------------------------------------------------------- + +-- All vars are marked as local vars. Before returning this must be fixed +{-# INLINE str2Name #-} +str2Name :: TokenInfo -> Located Name +str2Name = str2X mkVarName + +{-# INLINE str2FName #-} +str2FName :: TokenInfo -> Located Name +str2FName = str2X mkFunName + +{-# INLINE str2SFldName #-} +str2SFldName :: TokenInfo -> Located Name +str2SFldName = str2X mkStructFldName + +{-# INLINE str2PolInd #-} +str2PolInd :: TokenInfo -> Located Name +str2PolInd = str2X mkPolIndName + +{-# INLINE str2Tv #-} +str2Tv :: TokenInfo -> Located Name +str2Tv = str2X mkTvName + +str2X :: (String -> Name) -> TokenInfo -> Located Name +str2X f t = L (tLoc t) (f $ str_value $ tSymb t) + +doTypeSynonymDecl :: SrcLoc + -> TokenInfo + -> TyDecl Name + -> Alex (Located (TyDef Name)) +doTypeSynonymDecl loc syn t = do + checkDeclType loc (str_value $ tSymb syn) + return (L loc (TySynDef (str2Tv syn) t)) + +doStructDecl :: SrcLoc + -> TokenInfo + -> [(Located Name, TyDecl Name)] + -> Alex (Located (TyDef Name)) +doStructDecl loc sid flds = do + checkDeclType loc (str_value $ tSymb sid) + return (L loc (StructDecl (str2Tv sid) flds)) + +checkDeclType :: SrcLoc -> String -> Alex () +checkDeclType loc nm = do + aus <- get + let fnm = filename aus + tys = types aus + when (nm `elem` tys) $ throwError (mkCaoError loc fnm (DeclException $ MultipleDeclException nm)) + put aus { types = nm:tys } + +checkPol :: SrcLoc -> Pol Name -> Alex (Located (Pol Name)) +checkPol s p = if isValid (monomials p) + then return (L s p) + else do fnm <- gets filename + throwError $ mkCaoError s fnm (PolynomialErr p) + +{-# INLINE nullTyp #-} +nullTyp :: LExpr id -> TLExpr id +nullTyp = annL Bullet + +{-# INLINE la #-} +la :: TokenInfo -> a -> Located a +la l = L (tLoc l) + +{-# INLINE lg #-} +lg :: Located b -> a -> Located a +lg l = L (getLoc l) + +} + diff --git a/src/Language/CAO/Parser/Tokens.hs b/src/Language/CAO/Parser/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Parser/Tokens.hs @@ -0,0 +1,94 @@ + +{- +Module : $Header$ +Description : CAO language tokens. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Parser.Tokens where + +import Language.CAO.Common.SrcLoc + +data TokenInfo + = TokenInfo + { tSymb :: Token + , tText :: !String + , tLoc :: SrcLoc + } + +data Token + = TokenDef + | TokenTypedef + | TokenConst + | TokenOfType + | TokenOf + | TokenAssign + | TokenReturn + | TokenOSB + | TokenCSB + | TokenOCB + | TokenCCB + | TokenSemiColon + | TokenComma + | TokenDoublePeriod + | TokenPeriod + | TokenTrue + | TokenFalse + | TokenVoid + | TokenUnsigned + | TokenSigned + | TokenRegister + | TokenInt + | TokenBits + | TokenBool + | TokenVector + | TokenMatrix + | TokenMod + | TokenStruct + | TokenIf + | TokenElse + | TokenWhile + | TokenSeq + | TokenTo + | TokenBy + | TokenEq + | TokenAnd + | TokenOr + | TokenGET + | TokenLET + | TokenGT + | TokenLT + | TokenNot + | TokenNotEqual + | TokenXor + | TokenPlus + | TokenMinus + | TokenTimes + | TokenDiv + | TokenPower + | TokenRemainder + | TokenBitNot + | TokenBitAnd + | TokenBitOr + | TokenBitXor + | TokenShiftUp + | TokenShiftDown + | TokenRotUp + | TokenRotDown + | TokenConcat + | TokenOB + | TokenCB + | TokenIntValue { int_value :: Integer } + | TokenUnsignedBitsValue { bit_value :: ![Bool] } + | TokenSignBitsValue { bit_value :: ![Bool] } + | TokenStr { str_value :: !String } + | TokenTypeAlias { str_value :: !String } + | TokenEOF + | TokenError + diff --git a/src/Language/CAO/Platform/Literals.hs b/src/Language/CAO/Platform/Literals.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Platform/Literals.hs @@ -0,0 +1,354 @@ + +{- | +Module : $Header$ +Description : Sizes of the representation of CAO types. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +This module provides the mechanism to verify the sizes of the representation +for CAO types. The specification file can give static bounds for the type of +the library, allowing the verification of literals before translation. +-} + +module Language.CAO.Platform.Literals where + +import Data.Bits +import Data.List (genericSplitAt, genericReplicate) + +import Language.CAO.Common.Literal +import Language.CAO.Common.Monad +import Language.CAO.Common.Polynomial +import Language.CAO.Common.Var + +import Language.CAO.Index +import Language.CAO.Index.Eval + +import Language.CAO.Type + +{- | +Size of a data type +-} +data Size + = Generic -- ^ Not defined (don't care or unbounded) + | Simple Integer -- ^ Size of types other than matrices + | MSize Integer Integer -- ^ Size of a matrix (row, column) + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- Integer usage +-- Int : 5 +-- Bits : 5 +-- Mod : 4 +data LitCheck = LitCheck { + dynamic :: Bool -- Bits, Mod (Int is always dynamic) + , splitC :: Bool + , vi1 :: Integer + , vi2 :: Integer + , vi3 :: Integer + , vi4 :: Integer + , vi5 :: Integer + {- + dynamic :: Bool, -- Bits, Mod (Int is always dynamic) + min :: Integer, -- Int (value) + max :: Integer, -- Int (value), Bits (size), Mod (module) + shiftA :: Int, -- Int, Mod + mask :: Integer, -- Int, Mod + nrChunks :: Int, -- Int, Mod, Bits + nrPadd :: Int, -- Bits + remBits :: Int, -- Bits + chunkSize :: Integer -- Bits -} + } deriving Show + + +emptyLitCheck :: LitCheck +emptyLitCheck = LitCheck False False 0 0 0 0 0 + +setDynamic :: LitCheck -> LitCheck +setDynamic l = l { dynamic = True } + +dynamicCheck :: LitCheck -> Bool +dynamicCheck = dynamic + +setSplit :: LitCheck -> LitCheck +setSplit l = l { splitC = True } + +splitLit :: LitCheck -> Bool +splitLit = splitC + +-- Integers +lowerLimSet :: Integer -> LitCheck -> LitCheck +lowerLimSet n l = l { vi1 = n } + +lowerLim :: LitCheck -> Integer +lowerLim = vi1 + +upperLimSet :: Integer -> LitCheck -> LitCheck +upperLimSet n l = l { vi2 = n } + +upperLim :: LitCheck -> Integer +upperLim = vi2 + +shiftASet :: Integer -> LitCheck -> LitCheck +shiftASet n l = l { vi3 = n } + +shiftA :: LitCheck -> Integer +shiftA = vi3 + +-- Integers and Mods +maskSet :: Integer -> LitCheck -> LitCheck +maskSet n l = l { vi4 = n } + +mask :: LitCheck -> Integer +mask = vi4 + +nrChunksSet :: Integer -> LitCheck -> LitCheck +nrChunksSet n l = l { vi5 = n } + +nrChunks :: LitCheck -> Integer +nrChunks = vi5 + +-- Mods + +maxModSet :: Integer -> LitCheck -> LitCheck +maxModSet n l = l { vi2 = n } + +maxMod :: LitCheck -> Integer +maxMod = vi2 + +-- Bit strings + +maxSizeSet :: Integer -> LitCheck -> LitCheck +maxSizeSet n l = l { vi1 = n } + +maxSize :: LitCheck -> Integer +maxSize = vi1 + +chunkBitSizeSet :: Integer -> LitCheck -> LitCheck +chunkBitSizeSet n l = l { vi2 = n} + +chunkBitSize :: LitCheck -> Integer +chunkBitSize = vi2 + +nrTypChunkSet :: Integer -> LitCheck -> LitCheck +nrTypChunkSet n l = l { vi3 = n } + +nrTypChunk :: LitCheck -> Integer +nrTypChunk = vi3 + +-- Always disjoint with nrTypChunk +nrChunkSet :: Integer -> LitCheck -> LitCheck +nrChunkSet n l = l { vi3 = n } + +nrChunk :: LitCheck -> Integer +nrChunk = vi3 + +remBitsSet :: Integer -> LitCheck -> LitCheck +remBitsSet n l = l { vi4 = n } + +remBits :: LitCheck -> Integer +remBits = vi4 + +nrPaddChunkSet :: Integer -> LitCheck -> LitCheck +nrPaddChunkSet n l = l { vi5 = n } + +nrPaddChunk :: LitCheck -> Integer +nrPaddChunk = vi5 + +-------------------------------------------------------------------------------- +type WordSize = Int +type NumberOfWords = Int +type WordsPerChunk = Int + +onlyPositiveLim :: (Num a, Bits a) => WordSize -> NumberOfWords -> a +-- shift 2 (wordSize * numberOfWords - 1) == 2 ^ (wordSize * numberOfWords) +onlyPositiveLim wordSize numberOfWords = shift 2 (wordSize * numberOfWords - 1) +-- twosComplementLim nrWr = shift 2 (wordSize * nrWr - 2) -- TODO: expand specification + +splitNum :: WordSize -> NumberOfWords -> WordsPerChunk -> LitCheck -> LitCheck +splitNum wordSize numberOfWords wordsPerChunk = let + sa = wordSize * wordsPerChunk + in shiftASet (toInteger sa) + . maskSet (shift 2 (sa - 1) - 1) + . nrChunksSet (toInteger $ numberOfWords `div` wordsPerChunk) + . setSplit + +-------------------------------------------------------------------------------- +checkInt + :: Maybe WordSize -> Maybe (NumberOfWords, Maybe WordsPerChunk) + -> Maybe LitCheck +-- Nothing case: Assume that the size is irrelevant or unlimited +checkInt Nothing = const Nothing +checkInt (Just wordSize) = fmap (flip worker emptyLitCheck) + where + worker :: (NumberOfWords, Maybe WordsPerChunk) -> LitCheck -> LitCheck + worker (numberOfWords, wordsPerChunk) = let + lim = onlyPositiveLim wordSize numberOfWords + other = maybe id (splitNum wordSize numberOfWords) wordsPerChunk + in other . upperLimSet (lim - 1) . lowerLimSet 0 . setDynamic + +-- XXX: Is there a difference between signed and unsigned bits? +checkBits + :: Maybe WordSize -> Size -> Maybe (NumberOfWords, Maybe WordsPerChunk) + -> Maybe LitCheck +-- Nothing case: Assume that the size is irrelevant or unlimited +checkBits Nothing _ = const Nothing +checkBits (Just wordSize) strLength = maybe Nothing worker + where + worker (numberOfWords, mbWrChunk) = checkStaticSize + aux + (Just . maybe id auxChunkGeneric mbWrChunk . maxSizeSet lim) + lim strLength + where + aux litcheck strLen = fmap + (\x -> auxChunkSimple x strLen litcheck) mbWrChunk + + auxChunkGeneric wordsPerChunk = + nrChunksSet (numberOfChunks wordsPerChunk) . auxChunk wordsPerChunk + auxChunkSimple wordsPerChunk strLen = let + len = chunkLength wordsPerChunk + (nrCompleteChunks, nrPaddChunks, nrPaddBits) = + bsParam (numberOfChunks wordsPerChunk) len strLen + in nrTypChunkSet nrCompleteChunks + . remBitsSet nrPaddBits + . nrPaddChunkSet nrPaddChunks + . auxChunk wordsPerChunk + auxChunk wordsPerChunk = + chunkBitSizeSet (chunkLength wordsPerChunk) . setSplit + + chunkLength = toInteger . (wordSize *) + numberOfChunks = toInteger . div numberOfWords + lim = toInteger $ wordSize * numberOfWords + +bsParam :: Integer -> Integer -> Integer -> (Integer, Integer, Integer) +bsParam numberOfChunks chunkLength strLen = let + (nrCompleteChunks, nrRemBits) = divMod strLen chunkLength + nrPaddBits = if nrRemBits == 0 then 0 else chunkLength - nrRemBits + nrPaddChunks = numberOfChunks + - nrCompleteChunks + - (if nrPaddBits == 0 then 0 else 1) + in (nrCompleteChunks, nrPaddChunks, nrPaddBits) + +checkMod + :: Maybe WordSize -> Size -> Maybe (NumberOfWords, Maybe WordsPerChunk) + -> Maybe LitCheck +checkMod Nothing _ = const Nothing +-- Nothing case: Assume that the size is irrelevant or unlimited +checkMod (Just wordSize) strLength = maybe Nothing worker + where + worker :: (NumberOfWords, Maybe WordsPerChunk) -> Maybe LitCheck + worker (numberOfWords, mbWrChunk) = let + auxChunk = splitNum wordSize numberOfWords + lim = onlyPositiveLim wordSize numberOfWords + in checkStaticSize + (\litcheck -> const $ fmap (flip auxChunk litcheck) mbWrChunk) + (Just . maybe id auxChunk mbWrChunk . maxModSet lim) + lim strLength + +{- +When the size of the type is defined statically and we have the maximum limit, +we can determine if the representation is enough to hold all the values of the +type. Otherwise, the compilation fails. +If the size is not defined, then dinamic verification is set. In this context, +dynamic does not mean during execution, but during translation, i.e., all +literal values are verified for the bounds. In the future, this can also be +used in an abstract analysis of all values. +-} +checkStaticSize + :: (LitCheck -> Integer -> Maybe LitCheck) + -> (LitCheck -> Maybe LitCheck) + -> Integer -> Size + -> Maybe LitCheck +checkStaticSize fsimple fgeneric lim strLength = + case strLength of + -- The size can be determined statically + Simple strLen -> if strLen <= lim + then fsimple emptyLitCheck strLen + else error $ "The platform type `" -- ++ nameInPlat ts ++ "' does not have \ + -- \ enough precision to hold mods with module " ++ show strLength + -- No static information about the bit strings. + -- Dynamic testing required + Generic -> fgeneric $ setDynamic emptyLitCheck + _ -> error "Not expected matrix size" + +-------------------------------------------------------------------------------- + +checkILit + :: CaoMonad m + => LitCheck -> Integer + -> m [Integer] +checkILit lspec num = + if lowerLim lspec <= num && num <= upperLim lspec + then if splitLit lspec + then return $ chopNumLit (nrChunks lspec) (mask lspec) (fromInteger $ shiftA lspec) num + else return [num] + else error $ "Literal outside of the range of representation: " ++ show num + +chopNumLit :: Integer -> Integer -> Int -> Integer -> [Integer] +chopNumLit 0 _ _ _ = [] +chopNumLit n msk shft num = let + cn = num .&. msk + num' = num `shiftR` shft + in chopNumLit (n-1) msk shft num' ++ [cn] -- Endianness + +checkBSLit :: CaoMonad m => LitCheck -> Type Var -> [Bool] -> m [[Bool]] +checkBSLit lspec (Bits sign ilen) bits = + case evalExpr ilen of + IInt len -> if dynamicCheck lspec + then if len <= maxSize lspec + then if splitLit lspec + then let chunkLength = chunkBitSize lspec + (nrCompleteChunks, nrPaddBits, nrPaddChunks) = bsParam (nrChunks lspec) chunkLength len + in return $ chopBSLit sign chunkLength nrCompleteChunks nrPaddChunks nrPaddBits bits + else return [bits] + else error $ "Literal outside of the range of representation: " -- ++ bits + -- If it is not dynamic AND the specification exists, it MUST be choked + else return $ chopBSLit sign (chunkBitSize lspec) (nrTypChunk lspec) (nrPaddChunk lspec) (nrPaddChunk lspec) bits + _ -> error $ "Not expected index" +checkBSLit _ _ _ = error $ "Not expected type" + +chopBSLit :: Sign -> Integer -> Integer -> Integer -> Integer -> [Bool] -> [[Bool]] +chopBSLit sign chunkLength nrCompleteChunks nrPaddChunks nrPaddBits bits = + worker [] bits nrCompleteChunks + where + worker acc rest 0 = padd acc rest + worker acc bstr nc = let + (pref, rest) = genericSplitAt chunkLength bstr + in worker (pref : acc) rest (nc - 1) + + padd acc bstr = let + ebit = case sign of + S -> last + U -> const False + in if nrPaddBits == 0 + then genericReplicate nrPaddChunks (blankChunk (ebit $ head acc)) ++ acc + else let + ebit' = ebit bstr + in genericReplicate nrPaddChunks (blankChunk ebit') ++ + (bstr ++ genericReplicate nrPaddBits ebit') : + acc + blankChunk = genericReplicate chunkLength + + + +checkPLit + :: CaoMonad m + => LitCheck -> Type Var -> Pol Var + -> m [Pol Var] +checkPLit lspec (Mod Nothing Nothing (Pol [Mon (CoefI idx) EZero])) + (Pol [Mon (CoefI cexp) EZero]) = + case (evalExpr idx, evalExpr cexp) of + (IInt i, IInt c) -> if dynamicCheck lspec + then if i <= maxMod lspec + then return (aux c) + else error $ "Literal outside of the range of representation" + else return (aux c) + _ -> error "checkPLit: Not literal!" + where + aux = map (\ c' -> Pol [Mon (CoefI (IInt c')) EZero]) . + chopNumLit (nrChunks lspec) (mask lspec) (fromInteger $ shiftA lspec) +checkPLit _ _ _ = error $ "Not supported literal of polynomial" + diff --git a/src/Language/CAO/Platform/Naming.hs b/src/Language/CAO/Platform/Naming.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Platform/Naming.hs @@ -0,0 +1,155 @@ + +{- +Module : $Header$ +Description : Operation codes and naming +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable () + +-} + +module Language.CAO.Platform.Naming where + +import Data.Array +import Data.List (elemIndex) + +-------------------------------------------------------------------------------- + +class Codes e where + codeOf :: e -> OpCode + +-------------------------------------------------------------------------------- +-- Operations + +type OpCode = Int +type OpName = String + +operName :: OpCode -> OpName +operName op = operationNames ! op + +-- The code of an operator maps into its position in the list/array. +-- E.g: +-- operationNames ! code_init = "init" +-- elementIndex "decl" opNames = code_decl +code_init, code_decl, code_dispose, code_assign, code_equal :: OpCode +code_nequal, code_cast, code_add, code_sub, code_mul, code_div :: OpCode +code_pow, code_sym, code_mod, code_lte, code_lt, code_gte :: OpCode +code_gt, code_or, code_and, code_xor , code_not, code_shift_up :: OpCode +code_shift_down, code_rot_up, code_rot_down, code_range_select :: OpCode +code_select, code_range_set, code_set, code_concat, code_ref :: OpCode +code_row_range_select, code_col_range_select, code_row_range_set :: OpCode +code_col_range_set, code_init_def :: OpCode + +code_init = 0 +code_decl = 1 +code_dispose = 2 +code_assign = 3 +code_equal = 4 +code_nequal = 5 +code_lte = 6 +code_lt = 7 +code_gte = 8 +code_gt = 9 +code_cast = 10 +code_add = 11 +code_sub = 12 +code_mul = 13 +code_div = 14 +code_pow = 15 +code_sym = 16 +code_mod = 17 +code_or = 18 +code_and = 19 +code_xor = 20 +code_not = 21 +code_shift_up = 22 +code_shift_down = 23 +code_rot_up = 24 +code_rot_down = 25 +code_range_select = 26 +code_select = 27 +code_range_set = 28 +code_set = 29 +code_concat = 30 +code_ref = 31 +code_row_range_select = 32 +code_col_range_select = 33 +code_row_range_set = 34 +code_col_range_set = 35 +code_init_def = 36 + +isCompCode :: OpCode -> Bool +isCompCode c = code_equal <= c && c <= code_gt + +getCode :: OpName -> Maybe OpCode +getCode w = elemIndex w opNames + +operationNames :: Array OpCode OpName +operationNames = listArray (0, 36) opNames + +opNames :: [OpName] +opNames = + [ "init" + , "decl" + , "dispose" + , "assign" + , "equal" + , "nequal" + , "lte" + , "lt" + , "gte" + , "gt" + , "cast" + , "add" + , "sub" + , "mul" + , "div" + , "pow" + , "sym" + , "mod" + , "or" + , "and" + , "xor" + , "not" + , "shift_up" + , "shift_down" + , "rot_up" + , "rot_down" + , "range_select" + , "select" + , "range_set" + , "set" + , "concat" + , "ref" + , "row_range_select" + , "col_range_select" + , "row_range_set" + , "col_range_set" + , "initD" + ] + +-------------------------------------------------------------------------------- +-- Other strings used in the translation + +caoRes, caoRef :: String +caoRes = "RES" +caoRef = "REF" + +caoOk :: String +caoOk = "CAO_OK" + +-- Variable, parameter and function names +retArgId, vjump, structRes :: String +retArgId = "_r" +vjump = "vjump" +structRes = "sRes" + +cTrueValue, cFalseValue :: Integer +cTrueValue = 1 +cFalseValue = 0 + +nullVal :: String +nullVal = "0" diff --git a/src/Language/CAO/Platform/Query.hs b/src/Language/CAO/Platform/Query.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Platform/Query.hs @@ -0,0 +1,218 @@ + +{- | +Module : $Header$ +Description : Queries about the target platform. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +Query and utility functions about the target platform. +-} + +module Language.CAO.Platform.Query where + +import Control.Monad + +import Data.Array +import Data.Maybe + +import Language.CAO.Common.Error +import Language.CAO.Common.Literal +import Language.CAO.Common.Monad +import Language.CAO.Common.Polynomial +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.Var + +import Language.CAO.Index + +import Language.CAO.Platform.Literals +import Language.CAO.Platform.Naming +import Language.CAO.Platform.Specification + +import Language.CAO.Type + +-------------------------------------------------------------------------------- +-- These are the main query function which are used to encapsulate all searches. + +queryTTS :: TypeTransSpec -> [TypeSpec] +queryTTS tts = + map snd (ubitsT tts) ++ + map snd (sbitsT tts) ++ + map snd (modT tts) ++ + map snd (vectorT tts) ++ + map snd (matrixT tts) ++ + (catMaybes $ + boolT tts : + intT tts : + rintT tts : + structT tts : + modpolT tts : + []) +{- + - Translations for matrices with just one dimension specified? + - Structs of differnt sizes + -} +query :: TranslationSpec -> Type Var -> Maybe TypeSpec +query tspec typ = + either id (uncurry sizedTypeQuery) (worker typ) $ typeTransSpec tspec + + where + worker tp = case tp of + Int -> Left intT + RInt -> Left rintT + Bool -> Left boolT + Bits sg n -> let + f = case sg of + U -> ubitsT + S -> sbitsT + in Right (f, auxIndex n) + Mod Nothing Nothing (Pol [Mon (CoefI m) EZero]) -> + Right (modT, auxIndex m) + Mod _ _ _ -> Left modpolT + -- TODO: specific polynomial + + Vector n _ -> Right (vectorT, auxIndex n) + Matrix n m _ -> Right (matrixT, combineM (auxIndex n) (auxIndex m)) + Struct {} -> Left structT + SField _ t -> worker t + Index _ _ t -> worker t + _ -> error "query: Not expectd type" + + auxIndex n = + case n of + IInt n' -> Simple n' + IInd v -> case indConst v of + Just (IInt n') -> Simple n' + _ -> Generic + _ -> Generic + + combineM (Simple n) (Simple m) = MSize n m + combineM _ _ = Generic + +sizedTypeQuery :: (TypeTransSpec -> [(Size, TypeSpec)]) -> Size -> TypeTransSpec -> Maybe TypeSpec +sizedTypeQuery typ size ttspec = let + t = typ ttspec + in maybe (lookup Generic t) Just $ lookup size t + +-------------------------------------------------------------------------------- +-- Checks the query result, and raises an exception if the type is not supported. +queryType + :: CaoMonad m + => TranslationSpec -> Type Var + -> m TypeSpec +queryType tspec typ = maybe + (caoError defSrcLoc $ NotSupportedTypeErr typ) + return + $ query tspec typ + +queryOperation + :: CaoMonad m + => TranslationSpec -> Type Var -> OpCode + -> m (OpReturn, Consts, SafetyConv) +queryOperation tspec typ op = do + m <- queryType tspec typ + maybe (caoError defSrcLoc $ NotSupportedOp (operationNames ! op) typ) + return + $ operations m ! op + +-------------------------------------------------------------------------------- + +varOrMacroDecl :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a +varOrMacroDecl tspec typ f1 f2 = queryType tspec typ >>= aux . declConv + where + aux VarDecl = f1 + aux MacroDecl = f2 + +autoOrAlloc :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a +autoOrAlloc tspec typ f1 f2 = queryType tspec typ >>= aux . memoryConv + where + aux Auto = f1 + aux AutoRef = f1 + aux Alloc = f2 + +valOrRef :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a +valOrRef tspec typ f1 f2 = queryType tspec typ >>= aux . memoryConv + where + aux Auto = f1 + aux AutoRef = f2 + aux Alloc = f2 + +valOrRefFuncReturn :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a +valOrRefFuncReturn tspec typ f1 f2 = queryType tspec typ >>= aux . funcCall + where + aux FFuncReturn = f1 + aux FFuncRef = f2 + +valOrRefOpReturn :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a +valOrRefOpReturn tspec typ op f1 f2 = queryOperation tspec typ op >>= aux + where + aux (rc, _, _) = case rc of + OMacroReturn -> f1 + OFuncReturn -> f1 + OMacroRef -> f2 + OFuncRef -> f2 + +opReturnKind' :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a -> m a -> m a +opReturnKind' tspec typ op f1 f2 f3 f4 = queryOperation tspec typ op >>= aux + where + aux (rc, _, _) = case rc of + OFuncReturn -> f1 + OFuncRef -> f2 + OMacroReturn -> f3 + OMacroRef -> f4 + +valOrRefOpMacroReturn :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a +valOrRefOpMacroReturn tspec typ op f1 f2 = queryOperation tspec typ op >>= aux + where + aux (rc, _, _) = case rc of + OMacroReturn -> f1 + OMacroRef -> f2 + _ -> caoError defSrcLoc $ NotSupportedOp (operationNames ! op) typ + +globalOrInlinedField :: CaoMonad m => TranslationSpec -> m a -> m a -> m a +globalOrInlinedField tspec f1 f2 = case structFields $ globalTransSpec tspec of + GlobalF -> f1 + InlinedF -> f2 + +safeOfUnsafe :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a -> m a +safeOfUnsafe tspec typ op f1 f2 f3 = queryOperation tspec typ op >>= aux + where + aux (_,_, saf) = case saf of + Safe -> f1 + Unsafe -> f2 + ArgSafe -> f3 + +safeOrUnsafeDefault :: CaoMonad m => TranslationSpec -> m a -> m a -> m a -> m a +safeOrUnsafeDefault tspec f1 f2 f3 = + case defaultSafety $ globalTransSpec tspec of + Safe -> f1 + Unsafe -> f2 + ArgSafe -> f3 + +checkLiteral :: CaoMonad m => TranslationSpec -> Type Var -> m a -> (LitCheck -> m a) -> m a +checkLiteral tspec typ f1 f2 = queryType tspec typ >>= maybe f1 f2 . literal + +-------------------------------------------------------------------------------- +-- Encapsulated queries + +-- How to deal with literals +operandKind :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m Consts +operandKind tspec typ op = queryOperation tspec typ op >>= aux + where + aux (_, rc, _) = return rc + +operandKindGeneral :: CaoMonad m => TranslationSpec -> Type Var -> m Consts +operandKindGeneral tspec typ = liftM operands $ queryType tspec typ + +codes :: CaoMonad m => TranslationSpec -> Type Var -> m String +codes tspec typ = liftM code $ queryType tspec typ + +typeName :: CaoMonad m => TranslationSpec -> Type Var -> m String +typeName tspec typ = liftM nameInPlat $ queryType tspec typ + +existsModWithBase :: TranslationSpec -> Integer -> Bool +existsModWithBase tspec n = maybe False (const True) $ lookup (Simple n) $ modT $ typeTransSpec tspec + diff --git a/src/Language/CAO/Platform/Specification.hs b/src/Language/CAO/Platform/Specification.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Platform/Specification.hs @@ -0,0 +1,118 @@ + +{- | +Module : $Header$ +Description : Information about the target platform. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +This file contains the specificatio of the target platform to guide the +translation process. +-} + +module Language.CAO.Platform.Specification where + +import Data.Array + +import Language.CAO.Platform.Naming +import Language.CAO.Platform.Literals + +-------------------------------------------------------------------------------- + +data TranslationSpec = TranslationSpec { + globalTransSpec :: GlobalTransSpec + , typeTransSpec :: TypeTransSpec + } deriving Show + +-- One entry for each native CAO type +data TypeTransSpec = TypeTransSpec { + boolT :: (Maybe TypeSpec) + , intT :: (Maybe TypeSpec) + , rintT :: (Maybe TypeSpec) + , ubitsT :: [(Size, TypeSpec)] + , sbitsT :: [(Size, TypeSpec)] + , modT :: [(Size, TypeSpec)] + , vectorT :: [(Size, TypeSpec)] + , matrixT :: [(Size, TypeSpec)] + , structT :: (Maybe TypeSpec) + , modpolT :: (Maybe TypeSpec) + } deriving Show + +data GlobalTransSpec = GlobalTransSpec { + initProcName :: String + , disposeProcName :: String + , tpPrefix :: String + , callPrefix :: String + , defaultHeader :: Header + , defaultSafety :: SafetyConv + , structFields :: FieldsConv + , wordSize :: (Maybe Int) + } deriving Show + +emptyTranslationSpec :: TranslationSpec +emptyTranslationSpec = TranslationSpec { + globalTransSpec = emptyGlobalTransSpec + , typeTransSpec = emptyTypeTransSpec } + +emptyGlobalTransSpec :: GlobalTransSpec +emptyGlobalTransSpec = GlobalTransSpec { + initProcName = "" + , disposeProcName = "" + , tpPrefix = "" + , callPrefix = "" + , defaultHeader = "" + , defaultSafety = Unsafe + , structFields = GlobalF + , wordSize = Nothing + } + +emptyTypeTransSpec :: TypeTransSpec +emptyTypeTransSpec = TypeTransSpec { + boolT = Nothing + , intT = Nothing + , rintT = Nothing + , ubitsT = [] + , sbitsT = [] + , modT = [] + , vectorT = [] + , matrixT = [] + , structT = Nothing + , modpolT = Nothing + } + +data TypeSpec = TypeSpec { + nameInPlat :: String -- Translation to a platform name + , headerFile :: Header -- Header file with definitions for the type + , code :: String -- Short code for the type + , declConv :: VarDeclaration + , memoryConv :: VarMemory + , funcCall :: FuncReturn + , operands :: Consts + , literal :: Maybe LitCheck + , operations :: Array OpCode (Maybe (OpReturn, Consts, SafetyConv)) -- Map of CAO operation to operations in the platform + } deriving Show + + +data VarDeclaration = VarDecl | MacroDecl + deriving Show +data VarMemory = Auto | AutoRef | Alloc + deriving Show +data FuncReturn = FFuncRef | FFuncReturn + deriving Show +data OpReturn = OMacroRef | OMacroReturn | OFuncRef | OFuncReturn + deriving Show +data SafetyConv = Safe | Unsafe | ArgSafe + deriving Show +data FieldsConv = GlobalF | InlinedF + deriving Show +-- Inlined: all operands must be literal constants inlined in the call +-- LocalV: All the operands should be stored in variables. Literals should be stored in local variables +-- GlobalV: All the operands should be stored in variables. Literals should be stored in global variables +data Consts = GlobalV | LocalV | Inlined | Mixed + deriving Show + +type Header = String + diff --git a/src/Language/CAO/Semantics/Bits.hs b/src/Language/CAO/Semantics/Bits.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Semantics/Bits.hs @@ -0,0 +1,78 @@ + +{- | +Module : $Header$ +Description : Bit operations semantics. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +Bit operations semantics. +-} + +module Language.CAO.Semantics.Bits + ( bitsOr + , bitsAnd + , bitsXor + , bitsNot + , bitsConcat + , bitsRotUp + , bitsRotDown + , bitsShiftUp + , ubitsShiftDown + , sbitsShiftDown + , ubitsToInteger + , sbitsToInteger + , stringToBits + , bitsToString + ) where + +import Data.List (foldl') + +bitsOr, bitsAnd, bitsXor :: [Bool] -> [Bool] -> [Bool] +bitsOr = zipWith (||) +bitsAnd = zipWith (&&) +bitsXor = zipWith (/=) + +bitsNot :: [Bool] -> [Bool] +bitsNot = map not + +bitsConcat :: [Bool] -> [Bool] -> [Bool] +bitsConcat = (++) + +bitsRotUp :: [Bool] -> Integer -> [Bool] +bitsRotUp l 0 = l +bitsRotUp l n = bitsRotUp (last l : init l) (n-1) + +bitsRotDown :: [Bool] -> Integer -> [Bool] +bitsRotDown l 0 = l +bitsRotDown l n = bitsRotDown (tail l ++ [head l]) (n-1) + +bitsShiftUp :: [Bool] -> Integer -> [Bool] +bitsShiftUp l 0 = l +bitsShiftUp l n = bitsShiftUp (False : init l) (n-1) + +ubitsShiftDown :: [Bool] -> Integer -> [Bool] +ubitsShiftDown l 0 = l +ubitsShiftDown l n = ubitsShiftDown (tail l ++ [False]) (n-1) + +sbitsShiftDown :: [Bool] -> Integer -> [Bool] +sbitsShiftDown l 0 = l +sbitsShiftDown l n = sbitsShiftDown (tail l ++ [last l]) (n-1) + +ubitsToInteger :: [Bool] -> Integer +ubitsToInteger = foldl' (\ r b -> if b then r * 2 + 1 else r * 2) 0 . reverse + +sbitsToInteger :: [Bool] -> Integer +sbitsToInteger bs = if last bs + then -(ubitsToInteger $ bitsNot bs) - 1 + else ubitsToInteger bs + +stringToBits :: String -> [Bool] +stringToBits = foldl' (\ r -> (:r) . (== '1')) [] + +bitsToString :: [Bool] -> String +bitsToString = foldl' (\ r b -> (if b then '1' else '0') : r) "" + diff --git a/src/Language/CAO/Semantics/Bool.hs b/src/Language/CAO/Semantics/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Semantics/Bool.hs @@ -0,0 +1,29 @@ + +{- | +Module : $Header$ +Description : Boolean operations semantics. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +Boolean operations semantics. +-} + +module Language.CAO.Semantics.Bool + ( boolOr + , boolAnd + , boolXor + , boolNot + ) where + +boolOr, boolAnd, boolXor :: Bool -> Bool -> Bool +boolOr = (||) +boolAnd = (&&) +boolXor = (/=) + +boolNot :: Bool -> Bool +boolNot = not + diff --git a/src/Language/CAO/Semantics/Casts.hs b/src/Language/CAO/Semantics/Casts.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Semantics/Casts.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ViewPatterns #-} +{- +Module : $Header$ +Description : Semantics of casts. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Semantics.Casts ( convertTo) where + +import Data.List + +import Language.CAO.Common.Literal +import Language.CAO.Common.Polynomial +import Language.CAO.Common.Var + +import Language.CAO.Semantics.Bits +import Language.CAO.Semantics.Integer + +import Language.CAO.Index +import Language.CAO.Syntax + +import Language.CAO.Type +import Language.CAO.Type.Utils + +convertTo :: Type Var -> TExpr Var -> Expr Var +convertTo Int (TyE Int e@(Lit (ILit _))) + = e +convertTo Int (TyE RInt (Lit (ILit n))) + = Lit (ILit n) +convertTo RInt (TyE RInt e@(Lit (ILit _))) + = e +convertTo RInt (TyE Int (Lit (ILit n))) + = Lit (ILit n) +convertTo Int (TyE _ (Lit (BSLit sig s))) + = case sig of + U -> Lit $ ILit $ ubitsToInteger s + S -> Lit $ ILit $ sbitsToInteger s + +convertTo Int (unTyp -> Lit (PLit (Pol [Mon (CoefI (IInt n)) EZero]))) + = Lit $ ILit n + +convertTo (Bits U (IInt k)) (unTyp -> Lit (BSLit _ s)) + = Lit $ BSLit U $ genericTake k (s ++ repeat False) +convertTo (Bits S (IInt k)) (unTyp -> Lit (BSLit _ s)) + = Lit $ BSLit S $ genericTake k (s ++ repeat (head s)) +convertTo (Bits s (IInt n)) (unTyp -> Lit (ILit i)) + = Lit $ BSLit s $ genericTake n $ integerToBits i +convertTo ty@(Bits _ _) p@(unTyp -> Lit (PLit _)) + = convertTo ty (annTyE Int (convertTo Int p)) + +convertTo ty@(Mod _ _ _) (unTyp -> l@(Lit (PLit (Pol [Mon (CoefI (IInt i)) EZero])))) = + case getModulusBase ty of + IInt n -> Lit $ PLit (Pol [Mon (CoefI $ IInt $ i `mod` n) EZero]) + _ -> l + +convertTo ty@(Mod _ _ _) (unTyp -> l@(Lit (ILit n))) = + case getModulusBase ty of + IInt i -> Lit $ PLit $ Pol [Mon (CoefI $ IInt $ n `mod` i) EZero] + _ -> l + +convertTo _ e = unTyp e diff --git a/src/Language/CAO/Semantics/Integer.hs b/src/Language/CAO/Semantics/Integer.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Semantics/Integer.hs @@ -0,0 +1,59 @@ + +{- | +Module : $Header$ +Description : Integer operations semantics. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +Integer operations semantics. +-} + +module Language.CAO.Semantics.Integer + ( integerPlus + , integerMinus + , integerTimes + , integerPower + , integerDiv + , integerMod + , integerEqual + , integerNotEqual + , integerLessThan + , integerEqualsLessThan + , integerGreaterThan + , integerEqualsGreaterThan + , integerSymmetric + , integerToBits + ) where + +integerPlus, integerMinus, integerTimes, integerPower, integerDiv, integerMod :: + Integer -> Integer -> Integer +integerPlus = (+) +integerMinus = (-) +integerTimes = (*) +integerPower = (^) +integerDiv = div +integerMod = mod + +integerEqual,integerNotEqual :: Integer -> Integer -> Bool +integerEqual = (==) +integerNotEqual = (/=) + +integerLessThan, integerEqualsLessThan, integerGreaterThan, + integerEqualsGreaterThan :: Integer -> Integer -> Bool +integerLessThan = (<) +integerEqualsLessThan = (<=) +integerGreaterThan = (>) +integerEqualsGreaterThan = (>=) + +integerSymmetric :: Integer -> Integer +integerSymmetric = negate + +integerToBits :: Integer -> [Bool] +integerToBits 0 = repeat False +integerToBits i | i < 0 = map not $ integerToBits (-i - 1) + | otherwise = (i `mod` 2 /= 0) : integerToBits (i `div` 2) + diff --git a/src/Language/CAO/Syntax.hs b/src/Language/CAO/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Syntax.hs @@ -0,0 +1,853 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE BangPatterns #-} + +{- | +Module : $Header$ +Description : CAO AST and constructors. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable () + +This module contains the definition of data types which represent the +abstract syntax of the CAO language. + +The abstract syntax is parametric on the identifier (variables), +allowing for storing different information accordingly with the phase. + +Each data type includees its respective pretty printer instance. + +-} + +module Language.CAO.Syntax where + +import Data.Foldable ( Foldable ) + +import Data.Traversable ( Traversable ) + +import Language.CAO.Common.Literal +import Language.CAO.Common.Operator +import Language.CAO.Common.Outputable +import Language.CAO.Common.Polynomial +import Language.CAO.Common.SrcLoc + +import Language.CAO.Type + +-------------------------------------------------------------------------------- +-- * Programs +-------------------------------------------------------------------------------- + +-- | A CAO program is list of definitions with source code location annotations. +-- The order of the definition is relevant since the type checking expects +-- that required symbols are in the context. +data Prog id = Prog + { unDefs :: [LDef id] + , initP :: Maybe (Fun id) } + deriving (Functor, Foldable, Traversable) + +instance PP id => PP (Prog id) where + ppr = pprProg + +pprProg :: PP id => Prog id -> CDoc +pprProg (Prog defs ini) = vsep (map ppr defs) + $+$ maybe empty ppr ini + +-- * Definitions and declarations + +-- | A CAO 'Located' definition 'Def' +-- +type LDef id = Located (Def id) + +-- | A CAO Definition +-- +data Def id + -- | Global variable definition + = VarDef (VarDecl id) + -- | Global constant definition + | ConstDef (ConstDecl id) + -- | Function/procedure definition + | FunDef (Fun id) + -- | Type definition + | TyDef (TyDef id) + deriving (Functor, Foldable, Traversable) + +instance PP id => PP (Def id) where + ppr = pprDef + +pprDef :: PP id => Def id -> CDoc +pprDef (VarDef vd) = ppr vd +pprDef (ConstDef cd) = ppr cd +pprDef (FunDef fd) = ppr fd +pprDef (TyDef td) = ppr td + +-- | There are three types of CAO variable declarations: +-- +-- 1) Simple variable declaration. +-- +-- This is a single variable declaration with an optional initialization +-- of the form: +-- +-- * Without initialization. @VarD var tydecl Nothing@ where @var@ is an +-- identifier with location information and @tydecl@ is its type. +-- +-- @def v1 : int;@ +-- +-- * With initialization. @VarD var tydecl (Just expr)@ now includes an +-- initialization expression, @expr@. +-- +-- @def v2 : int := 3;@ +-- +-- 2) Multiple variable declarations with the same type. +-- @MultiD vars tydecl@ where @vars@ is a (non-empty) list of identifiers +-- with location information and @tydecl@ is their type. +-- +-- @def v1, v2, ..., vn : int;@ +-- +-- 3) Container variable declarations with initialization. +-- @CondD var tydecl init@ where @var@ is an identifier with location +-- information, @tydecl@ is its type and @init@ is a (non-empty) list of +-- initialization expressions. Moreover, the length of the list must +-- correspond to the container size in the type declaration. +-- +-- @def v1 : vector [3] of int := { 1, 2, 3 };@ +-- +data VarDecl id + -- | Simple variable declaration + = VarD (Located id) -- Variable declared + (TyDecl id) -- Type of the variables + (Maybe (TLExpr id)) -- Initializer + -- | Multiple variable declaration + | MultiD [Located id] -- Variables declared + (TyDecl id) -- Type of the variables + -- | Container variable declaration + | ContD (Located id) -- Variable + (TyDecl id) -- Type + [TLExpr id] -- Container elems + deriving (Functor, Foldable, Traversable) + +instance PP id => PP (VarDecl id) where + ppr = pprVarDecl + +pprVarDecl :: PP id => VarDecl id -> CDoc +pprVarDecl (VarD v ty Nothing) + = text "def" <+> ppr v <+> colon <+> ppr ty <> semi +pprVarDecl (VarD v ty (Just e)) + = text "def" <+> ppr v <+> colon <+> ppr ty + <+> text ":=" <+> ppr e <> semi +pprVarDecl (MultiD vs ty) + = text "def" <+> pprElems vs <+> colon <+> ppr ty <> semi +pprVarDecl (ContD v ty es) + = text "def" <+> ppr v <+> colon <+> ppr ty + <+> text ":=" <+> braces (pprElems es) <> semi + +-- | Symbolic CAO constant declarations: +-- +-- 1) Single constant declarations. @ConstD var tydecl ann@ where @var@ is +-- an identifier with location, @tydecl@ is its type and @ann@ is an +-- additional annotation about the constant as defined in 'ConstAnn': +-- +-- * With no additional information: +-- +-- @def const c : int;@ +-- +-- * With a constant initialization: +-- +-- @def const c : int := 3;@ +-- +-- @def const c : int := 3 * a;@ +-- +-- * With a condition (invariant): +-- +-- @def const c : int { 0 < c };@ +-- +-- 2) Multiple constant declarations: +-- +-- * Without a condition: @MultiConstD vars tydecl Nothing@ where @vars@ is a +-- (non-empty) list of identifiers with location information and @tydecl@ is +-- their type: +-- +-- @def const c1, c2, ..., cn : int;@ +-- +-- * With a condition @MultiConstD vars typdecl (Just cond)@ now includes a +-- condition expression @cond@ that is an invariant: +-- +-- @def const c1, c2, ..., cn : int { c1 < c2 && c2 < cn };@ +-- +data ConstDecl id + -- | Single constant declaration + = ConstD (Located id) -- Constant declared + (TyDecl id) -- Type of the constant + (ConstAnn id) -- Additional information about constant + -- | Multiple constant declaration + | MultiConstD [Located id] -- Constants declared + (TyDecl id) -- Type of the variables + (Maybe (LExpr id)) -- Optional condition + deriving (Functor, Foldable, Traversable) + +instance PP id => PP (ConstDecl id) where + ppr = pprConstDecl + +pprConstDecl :: PP id => ConstDecl id -> CDoc +pprConstDecl (ConstD c ty an) + = text "def" <+> text "const" <+> ppr c <+> colon <+> ppr ty + <+> ppr an <> semi +pprConstDecl (MultiConstD cs ty Nothing) + = text "def" <+> text "const" <+> pprElems cs <+> colon <+> ppr ty <> semi +pprConstDecl (MultiConstD cs ty (Just cond)) + = text "def" <+> text "const" <+> pprElems cs <+> colon <+> ppr ty + <+> pprCond cond <> semi + +pprCond :: PP id => LExpr id -> CDoc +pprCond c = lbrace <+> ppr c <+> rbrace + +-- | Additional information about symbolic constants. +data ConstAnn id + -- | No additional information required. + = None + -- | Definition of the symbolic constant using other constants. + | ConstInit (LExpr id) + -- | Condition (invariant) that the symbolic constant must obey. + | ConstCond (LExpr id) + deriving (Functor, Foldable, Traversable) + +instance PP id => PP (ConstAnn id) where + ppr = pprConstAnn + +pprConstAnn :: PP id => ConstAnn id -> CDoc +pprConstAnn None = empty +pprConstAnn (ConstInit e) = text ":=" <+> ppr e +pprConstAnn (ConstCond cond) = ppr cond + +-- | A CAO Funtion definition +-- +data Fun id + = Fun { funId :: Located id -- ^ Function identifier with location + -- information. + , funArgs :: [Arg id] -- ^ List of function parameters (can be + -- empty). + , returnType :: [TyDecl id] -- ^ List of the types of returned values. + -- This can be empty in the case of + -- procedures. + , funBody :: [LStmt id] -- ^ Function body. The list of statements + -- must be non-empty. + } + deriving (Functor, Foldable, Traversable) + +instance PP id => PP (Fun id) where + ppr = pprFun + +pprFun :: PP id => Fun id -> CDoc +pprFun (Fun fn args rt stmts) + = flip pprBlock stmts $ text "def" <+> ppr fn <> parens (pprElems args) + <+> colon <+> pprRetTys_ rt + +pprRetTys_ :: PP id => [TyDecl id] -> CDoc +pprRetTys_ [] = text "void" +pprRetTys_ tys = pprElems tys + +-- | Function arguments/parameters: +-- +-- 1) Regular arguments. @Arg var tydecl@ where @var@ is an identifier with +-- location and @tydecl@ is its type: +-- +-- @(..., a : int, ...)@ +-- +-- 2) Symbolic (constant) arguments: +-- +-- * Without a condition. @ArgConst var tydecl Nothing@ where @var@ is an +-- identifier and @tydecl@ is its type: +-- +-- @(..., const a : int, ...)@ +-- +-- * With a condition. @ArgConst var tydecl (Just cond)@ now includes a +-- condition expression @cond@ which is an invariant in the body of the +-- function: +-- +-- @)(..., const a : int { 0 < a }, ...)@ +-- +data Arg id + -- | Regular argument declaration + = Arg (Located id) (TyDecl id) + -- | Symbolic argument declaration + | ArgConst (Located id) (TyDecl id) (Maybe (LExpr id)) + deriving (Functor, Foldable, Traversable) + +instance PP id => PP (Arg id) where + ppr = pprArg + +pprArg :: PP id => Arg id -> CDoc +pprArg (Arg n ty) + = ppr n <+> colon <+> ppr ty +pprArg (ArgConst n ty Nothing) + = text "const" <+> ppr n <+> colon <+> ppr ty +pprArg (ArgConst n ty (Just c)) + = text "const" <+> ppr n <+> colon <+> ppr ty <+> pprCond c + +-- | A CAO type synonym declaration or struct definition. +-- +-- 1) A type synonym, @TySynDef var tydecl@ where @var@ is an identifier +-- with location information of the type alias and @tydecl@ is the +-- definition of the type. +-- +-- @typedef V8 := vector[8] of int;@ +-- +-- 2) A structure declaration, +-- @StructDecl var [(p1, tydecl1), ... (pn, tydecln)]@ +-- where @var@ is an indentifier with location information of the structure, +-- @pi@ with @i@ in @1,...,n@, are identifier with location information of +-- the struture projections and +-- @tydecli@ with @i@ in @1,...,n@ are the respective projection types. +-- +-- @typedef S := struct [ def f1 : int; +-- def f2 : bool; ];@ +-- +data TyDef id + -- | Type synonym + = TySynDef (Located id) + (TyDecl id) + -- | Struct declaration + | StructDecl (Located id) + [(Located id, TyDecl id)] -- Struct fields + deriving (Functor, Foldable, Traversable) + +instance PP id => PP (TyDef id) where + ppr = pprTyDef + +pprTyDef :: PP id => TyDef id -> CDoc +pprTyDef (TySynDef tn ty) + = text "typedef" <+> ppr tn <+> text ":=" <+> ppr ty <> semi +pprTyDef (StructDecl sn flds) + = text "typedef" <+> ppr sn <+> text ":=" <+> text "struct" + <> pprFlds_ flds <> semi + +pprFlds_ :: PP id => [(Located id, TyDecl id)] -> CDoc +pprFlds_ flds = brackets $ sep $ map pprFld_ flds + +pprFld_ :: PP id => (Located id, TyDecl id) -> CDoc +pprFld_ (fld, ty) = text "def" <+> ppr fld <+> colon <+> ppr ty <> semi + +-- | A 'Located' 'TyDecl' +-- +type LTyDecl id = Located (TyDecl id) + +-- | A CAO type declaration. It is the type described in, for example: +-- @ +-- def x : int; +-- def y : mod [ 2 ]; +-- ... +-- @ +data TyDecl id + = IntD -- ^ Arbitrary precision integers + | RIntD -- ^ Machine (register) precision integers + | BoolD -- ^ Booleans + | BitsD Sign (LExpr id) -- ^ Bits strings with /sign/ and /length/ + | ModD (Mod id) -- ^ Modular type + | VectorD (LExpr id) + (TyDecl id) -- ^ Vectors with /size/ and /type/ of elements + | MatrixD (LExpr id) + (LExpr id) + (TyDecl id) -- ^ Matrices with /row/ and /column sizes/ and + -- /type/ of elements + | TySynD (Located id) -- ^ Type alias + deriving (Functor, Foldable, Traversable, Show, Eq, Read) + +instance PP id => PP (TyDecl id) where + ppr = pprTyDecl + +pprTyDecl :: PP id => TyDecl id -> CDoc +pprTyDecl IntD + = text "int" +pprTyDecl RIntD + = text "register" <+> text "int" +pprTyDecl BoolD + = text "bool" +pprTyDecl (BitsD snm e) + = ppr snm <+> text "bits" <> brackets (ppr e) +pprTyDecl (ModD md) + = text "mod" <> brackets (ppr md) +pprTyDecl (VectorD ln ty) + = text "vector" <> brackets (ppr ln) <+> text "of" <+> ppr ty +pprTyDecl (MatrixD rows cols ty) + = text "matrix" <> brackets (pprElems [rows,cols]) <+> text "of" <+> ppr ty +pprTyDecl (TySynD sid) + = ppr sid + +-- | A CAO Modulus +data Mod id + -- | Numeric modulus: @mod [ ]@ + = ModNum (LExpr id) + -- | Modular extention: @mod [ / ]@ + | ModPol (TyDecl id) id (Pol id) + deriving (Functor, Foldable, Traversable, Show, Eq, Read) + +instance PP id => PP (Mod id) where + ppr = pprMod + +pprMod :: PP id => Mod id -> CDoc +pprMod (ModNum n) + = ppr n +pprMod (ModPol ty n pol) + = ppr ty <> char '<' <> ppr n <> char '>' <+> char '/' <+> ppr pol + +-- * Expressions + +-- | CAO Located Expressions +-- +type LExpr id = Located (Expr id) + +-- | CAO Located Expressions with type annotations +type TLExpr id = Located (TExpr id) + +-- | CAO Expressions +data Expr id + -- | Variable + = Var id + -- | Literal + | Lit (Literal id) + -- | Function call + | FunCall (Located id) [TLExpr id] + -- | Struct projection + | StructProj (TLExpr id) id + -- | Unary operation + | UnaryOp UOp (TLExpr id) + -- | Binary operation + | BinaryOp (BinOp id) (TLExpr id) (TLExpr id) + -- | Container access + | Access (TLExpr id) (APat id) + -- | Cast + | Cast Bool [LTyDecl id] (TLExpr id) + deriving (Functor, Foldable, Traversable, Show, Eq, Read) + +-- | Unary operations +data UOp + -- | Symmetric expression (@-@) + = Sym + -- | Boolean negation (@!@) + | Not + -- | Bitwise negation (@~@) + | BNot + deriving (Eq, Show, Read) + +instance PP UOp where + ppr = pprUOp + +pprUOp :: UOp -> CDoc +pprUOp Sym = char '-' +pprUOp Not = char '!' +pprUOp BNot = char '~' + +-- | Binary operations +data BinOp id + -- | Arithmetic binary operation + = ArithOp AOp + -- | Boolean binary operation + | BoolOp BOp + -- | Bitwise operation + | BitOp BWOp + -- | Shift/rotate operation. This case is separated because the + -- second argument is an index. + | BitsSROp SROp + -- | Comparison + | CmpOp (Type id) COp + -- | Concat operation (@\@@) + | Concat + deriving (Eq, Show, Read, Functor, Foldable, Traversable) + +instance PP (BinOp id) where + ppr = pprBinOp + +pprBinOp :: BinOp id -> CDoc +pprBinOp (ArithOp op) = ppr op +pprBinOp (BoolOp op) = ppr op +pprBinOp (BitOp op) = ppr op +pprBinOp (BitsSROp op) = ppr op +pprBinOp (CmpOp _ op) = ppr op +pprBinOp Concat = char '@' + +instance PP id => PP (Expr id) where + ppr = pprExpr + +pprExpr :: PP id => Expr id -> CDoc +pprExpr (Var v) + = ppr v +pprExpr (Lit l) + = ppr l +pprExpr (FunCall fn es) + = ppr fn <> parens (pprElems es) +pprExpr ctx@(StructProj (L _ e) fi) + = pprParens_ e ctx <> char '.' <> ppr fi +pprExpr ctx@(UnaryOp op (L _ e)) + = ppr op <> pprParens_ e ctx +pprExpr ctx@(BinaryOp op (L _ l) (L _ r)) + = pprParensL_ l ctx <+> ppr op <+> pprParensR_ r ctx +pprExpr ctx@(Access (L _ l) p) + = pprParens_ l ctx <> ppr p +pprExpr ctx@(Cast True td (L _ e)) + = parens (ppr td) <> pprParens_ e ctx +pprExpr (Cast False _ e) + = ppr e + +-- | Arithmetic Operations +-- +data AOp + = Plus -- ^ Sum (@+@) + | Minus -- ^ Subtraction (@-@) + | Times -- ^ Multiplication (@*@) + | Power -- ^ Exponentiation (@**@) + | Div -- ^ Whole division (@/@) + | ModOp -- ^ Remainer of whole division (@%@) + deriving (Eq, Show, Read) + +instance PP AOp where + ppr = pprAOp + +pprAOp :: AOp -> CDoc +pprAOp Plus = char '+' +pprAOp Minus = char '-' +pprAOp Times = char '*' +pprAOp Power = text "**" +pprAOp Div = char '/' +pprAOp ModOp = char '%' + +-- | Comparision operations +-- +data COp + = Eq -- ^ Equality (@==@) + | Neq -- ^ Not equal (@!=@) + | Lt -- ^ Less than (@<@) + | Leq -- ^ Less than or equal (@<=@) + | Gt -- ^ Greater than (@>@) + | Geq -- ^ Greater than or equal (@>=@) + deriving (Eq, Show, Read) + +instance PP COp where + ppr = pprCOp + +pprCOp :: COp -> CDoc +pprCOp Eq = text "==" +pprCOp Neq = text "!=" +pprCOp Lt = char '<' +pprCOp Leq = text "<=" +pprCOp Gt = char '>' +pprCOp Geq = text ">=" + +-- | Boolean operations +-- +data BOp + = And -- ^ Boolean conjunction (@&&@) + | Or -- ^ Boolean disjunction (@||@) + | Xor -- ^ Boolean exclusive disjunction (\xor\) (@^^@) + deriving (Eq, Show, Read) + +instance PP BOp where + ppr = pprBOp + +pprBOp :: BOp -> CDoc +pprBOp And = text "&&" +pprBOp Or = text "||" +pprBOp Xor = text "^^" + +-- | Bit string operations +-- +data BWOp + = BWOr -- ^ Bitwise disjunction (@|@) + | BWAnd -- ^ Bitwise conjunction (@&@) + | BWXor -- ^ Bitwise exclusive disjunction (@^@) + deriving (Eq, Show, Read) + +instance PP BWOp where + ppr = pprBWOp + +pprBWOp :: BWOp -> CDoc +pprBWOp BWAnd = char '&' +pprBWOp BWOr = char '|' +pprBWOp BWXor = char '^' + +-- | Shifts/Rotate operations +-- +data SROp + = SUp -- ^ Shift up (left) (@<<@) + | SDown -- ^ Shift down (right) (@>>@) + | RUp -- ^ Rotate up (@<|@) + | RDown -- ^ Rotate down (@|>@) + deriving (Eq, Show, Read) + +instance PP SROp where + ppr = pprSROp + +pprSROp :: SROp -> CDoc +pprSROp SUp = text "<<" +pprSROp SDown = text ">>" +pprSROp RUp = text "<|" +pprSROp RDown = text "|>" + +-- | Vector and matrice accesses +-- +data APat id + -- | Vector access/range + = VectP (RowAPat id) + -- | Matrix access/range (row, column) + | MatP (RowAPat id) (ColAPat id) + deriving (Functor, Foldable, Traversable, Show, Eq, Read) + +instance PP id => PP (APat id) where + ppr = pprAPat + +pprAPat :: PP id => APat id -> CDoc +pprAPat (VectP r) = brackets $ ppr r +pprAPat (MatP r c) = brackets (ppr r <> comma <> ppr c) + +-- | Accesses and ranges +-- +data RowAPat id + -- | Element access using an integer expression as index + = CElem (TLExpr id) + -- | Range access using two integer expressions as limits of the range: + -- @CRange from to@. + | CRange (TLExpr id) + (TLExpr id) + deriving (Functor, Foldable, Traversable, Show, Eq, Read) + +instance PP id => PP (RowAPat id) where + ppr = pprRowAPat + +pprRowAPat :: PP id => RowAPat id -> CDoc +pprRowAPat (CElem e) = ppr e +pprRowAPat (CRange f t) = ppr f <> text ".." <> ppr t + +-- | Column access pattern. +-- +type ColAPat = RowAPat + +-- * Statements + +-- | AST Annotations. Annotations have a no semantics and +-- are not pretty-printed nor translated. They are used solely for internal +-- processing purposes. +data Annot + = EndIndex + | EndAux + | EndConsts + +-- | CAO Located Statement +-- +type LStmt id = Located (Stmt id) + +-- | CAO Statements +-- +data Stmt id + -- | Variable declaration + = VDecl (VarDecl id) + -- | Constant declaration + | CDecl (ConstDecl id) + -- | Assignment + | Assign [LVal id] [TLExpr id] + -- | Function call + | FCallS id [TLExpr id] + -- | Return statement + | Ret [TLExpr id] + -- | Conditional statement (If) + | Ite (TLExpr id) + [LStmt id] + (Maybe [LStmt id]) + -- | Sequence statement (Seq) + | Seq (SeqIter id) [LStmt id] + + -- | Iterative statement (While) + | While (TLExpr id) [LStmt id] + -- | No operation (not syntactic) + | Nop Annot + deriving (Functor, Foldable, Traversable) + +instance PP id => PP (Stmt id) where + ppr = pprStmt + +pprStmt :: PP id => Stmt id -> CDoc +pprStmt (VDecl vd) + = ppr vd +pprStmt (CDecl cd) + = ppr cd +pprStmt (Assign lvs es) + = pprElems lvs <+> text ":=" <+> pprElems es <> semi +pprStmt (FCallS fn es) + = ppr fn <> parens (pprElems es) <> semi +pprStmt (Ret es) + = text "return" <+> pprElems es <> semi +pprStmt (Ite c i me) + = pprBlock (text "if" <> parens (ppr c)) i <> pprElse me + where + pprElse Nothing = empty + pprElse (Just e) = pprBlock (text "else") e +pprStmt (Seq s b) + = pprBlock (ppr s) b +pprStmt (While e st) + = pprBlock (text "while" <> parens (ppr e)) st +pprStmt (Nop _) + = empty + +-- | Sequence iterations +data SeqIter id + = SeqIter { seqVar :: id -- ^ Bound variable identifier + , seqStart :: LExpr id -- ^ Start index + , seqEnd :: LExpr id -- ^ End index + , seqBy :: Maybe (LExpr id) -- ^ Optional increment + , seqIdx :: SeqRange -- ^ Expansion annotation + } + deriving (Functor, Foldable, Traversable) + +-- | Sequence annotations +data SeqRange + = SimpleRng [Integer] -- ^ Simple sequence indexes + | NestedRng [[Integer]] -- ^ Nested sequence indexes + deriving (Eq, Show) + +instance PP id => PP (SeqIter id) where + ppr = pprSeqIter + +pprSeqIter :: PP id => SeqIter id -> CDoc +pprSeqIter (SeqIter v s e mb _) + = text "seq" <+> ppr v <+> text ":=" + <+> ppr s <+> text "to" <+> ppr e <+> pprBy mb + where + pprBy Nothing = empty + pprBy (Just b) = text "by" <+> ppr b + +-- | CAO left value +data LVal id + -- | Simple left value @x := ...@ + = LVVar (Located id) + -- | Struct left value @s.fi := ...@ + | LVStruct (LVal id) id + -- | Containers @v[0] := ... m[1,2] := ...@ + | LVCont (Type id) (LVal id) (APat id) + deriving (Functor, Foldable, Traversable) + +instance PP id => PP (LVal id) where + ppr = pprLVal + +pprLVal :: PP id => LVal id -> CDoc +pprLVal (LVVar v) = ppr v +pprLVal (LVStruct sn fi) = ppr sn <> char '.' <> ppr fi +pprLVal (LVCont _ c p) = ppr c <> ppr p + +-- * Type annotations + +data TExpr id = TyE (Type id) (Expr id) + deriving (Show, Read, Eq, Foldable, Traversable, Functor) + +instance PP id => PP (TExpr id) where + ppr (TyE _ e) = ppr e + +{-# INLINE annTyE #-} +annTyE :: Type id -> Expr id -> TExpr id +annTyE t e = TyE t e + +{-# INLINE annL #-} +annL :: Type id -> LExpr id -> TLExpr id +annL t = fmap (annTyE t) + +{-# INLINE unTyp #-} +unTyp :: TExpr id -> Expr id +unTyp (TyE _ e) = e + +{-# INLINE unTypL #-} +unTypL :: TLExpr id -> LExpr id +unTypL = fmap unTyp + +-------------------------------------------------------------------------------- +-- UTILS +-------------------------------------------------------------------------------- + +pprBlock :: PP id => CDoc -> [LStmt id] -> CDoc +pprBlock header stmts + = header <+> lbrace $+$ nest 2 (vcat $ map ppr stmts) $+$ rbrace + +instance Operator (TExpr id) where + isSimple (TyE _ e) = isSimple e + assoc (TyE _ e) = assoc e + fixity (TyE _ e) = fixity e + prec (TyE _ e) = prec e + +instance Operator (Expr id) where + isSimple (Lit _) = True + isSimple (Var _) = True + isSimple (Cast False _ (L _ e)) = isSimple e + isSimple _ = False + + assoc (Cast False _ (L _ e)) = assoc e + assoc _ = ALeft + + fixity (UnaryOp _ _) = Prefix + fixity (Cast True _ _) = Prefix + fixity (FunCall _ _) = Postfix + fixity (StructProj _ _) = Postfix + fixity (Access {}) = Postfix + fixity (Cast False _ (L _ e)) = fixity e + fixity _ = Infix + + prec (Var _) = 200 + prec (Lit _) = 200 + prec (FunCall _ _) = 190 + prec (StructProj _ _) = 190 + prec (UnaryOp _ _) = 180 + prec (BinaryOp (ArithOp op) _ _) = prec op + prec (BinaryOp (BoolOp op) _ _) = prec op + prec (BinaryOp (BitOp op) _ _) = prec op + prec (BinaryOp (BitsSROp op) _ _) = prec op + prec (BinaryOp (CmpOp _ op) _ _) = prec op + prec (BinaryOp Concat _ _) = 150 + prec (Access {}) = 190 + prec (Cast True _ _) = 170 + prec (Cast False _ (L _ e)) = prec e + +instance Operator AOp where + isSimple _ = False + assoc _ = ALeft + fixity _ = Infix + prec Plus = 140 + prec Minus = 140 + prec Times = 150 + prec Div = 150 + prec ModOp = 150 + prec Power = 160 + +instance Operator COp where + isSimple _ = False + assoc _ = ALeft + fixity _ = Infix + prec Eq = 110 + prec Neq = 110 + prec Lt = 120 + prec Leq = 120 + prec Gt = 120 + prec Geq = 120 + +instance Operator BOp where + isSimple _ = False + assoc _ = ALeft + fixity _ = Infix + prec And = 60 + prec Or = 40 + prec Xor = 50 + +instance Operator BWOp where + isSimple _ = False + assoc _ = ALeft + fixity _ = Infix + prec BWOr = 70 + prec BWAnd = 90 + prec BWXor = 80 + +instance Operator SROp where + isSimple _ = False + assoc _ = ALeft + fixity _ = Infix + prec SUp = 130 + prec SDown = 130 + prec RUp = 130 + prec RDown = 130 + diff --git a/src/Language/CAO/Syntax/Codes.hs b/src/Language/CAO/Syntax/Codes.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Syntax/Codes.hs @@ -0,0 +1,100 @@ + +{- | +Module : $Header$ +Description : Mapping of CAO syntax to operation codes. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Syntax.Codes where + +import Language.CAO.Platform.Naming +import Language.CAO.Common.SrcLoc + +import Language.CAO.Syntax + +instance Codes a => Codes (Located a) where + codeOf (L _ e) = codeOf e + +instance Codes a => Codes (TExpr a) where + codeOf (TyE _ e) = codeOf e + +instance Codes (Expr a) where + codeOf = opCode + +-- Operation names -- +opCode :: Expr a -> OpCode +opCode (Lit _) = code_init +opCode (StructProj _ _) = code_select +opCode (UnaryOp op _) = codeOf op +opCode (BinaryOp op _ _) = codeOf op +opCode (Access _ op) = codeOf op +opCode _ = + error $ ". - Not implemented translation" + +instance Codes UOp where + codeOf = uopCode + +uopCode :: UOp -> OpCode +uopCode op = + case op of + Sym -> code_sym + Not -> code_not + BNot -> code_not + +instance Codes (BinOp id) where + codeOf = bopCode + +bopCode :: BinOp id -> OpCode +bopCode (ArithOp op) = + case op of + Plus -> code_add + Minus -> code_sub + Times -> code_mul + Power -> code_pow + Div -> code_div + ModOp -> code_mod +bopCode (BoolOp op) = + case op of + Or -> code_or + And -> code_and + Xor -> code_xor +bopCode (BitOp op) = + case op of + BWOr -> code_or + BWAnd -> code_and + BWXor -> code_xor +bopCode (BitsSROp op) = + case op of + SUp -> code_shift_up + SDown -> code_shift_down + RUp -> code_rot_up + RDown -> code_rot_down +bopCode (CmpOp _ op) = + case op of + Eq -> code_equal + Neq -> code_nequal + Leq -> code_lte + Lt -> code_lt + Gt -> code_gt + Geq -> code_gte +bopCode Concat = code_concat + +instance Codes (APat id) where + codeOf = apatCode + +apatCode :: APat id -> OpCode +apatCode pat = + case pat of + VectP (CElem _) -> code_select + VectP (CRange _ _) -> code_range_select + MatP (CElem _) (CElem _) -> code_select + MatP (CRange _ _) (CRange _ _) -> code_range_select + MatP (CRange _ _) (CElem _) -> code_row_range_select + MatP (CElem _) (CRange _ _) -> code_col_range_select + diff --git a/src/Language/CAO/Syntax/Tidy.hs b/src/Language/CAO/Syntax/Tidy.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Syntax/Tidy.hs @@ -0,0 +1,306 @@ + +{- +Module : $Header$ +Description : Tidy CAO variable names. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Syntax.Tidy + ( tidyCaoAST + , showCaoAST + , showCaoASTDebug + ) where + + +import Control.Monad.State + +import Data.Map ( Map ) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Traversable as T + +import Language.CAO.Common.Literal +import Language.CAO.Common.Outputable +import Language.CAO.Common.Polynomial +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Language.CAO.Index + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils + +import Language.CAO.Type + + +type TidyM = State TidySt + +data TidySt + = TidySt { symbolCount :: Map String Int + , seen :: Map Var Var + , globalSymbols :: Map String Int + } + +emptyState :: TidySt +emptyState + = TidySt { symbolCount = Map.empty + , seen = Map.empty + , globalSymbols = Map.empty + } + +resetLocals :: TidyM () +resetLocals = modify $ \ s -> s { symbolCount = globalSymbols s } + +showCaoAST :: Prog Var -> String +showCaoAST = showPpr . tidyCaoAST + +showCaoASTDebug :: Prog Var -> String +showCaoASTDebug = showPprDebug . tidyCaoAST + +tidyCaoAST :: Prog Var -> Prog Var +tidyCaoAST p@(Prog defs ip) = uncurry Prog (evalState tidyWorker initState) + where + tidyWorker = do + defs' <- mapM tidyLDef defs + ip' <- mapMaybeM tidyFunDef ip + return (defs', ip') + initState = emptyState { globalSymbols = Map.fromList glbs } + glbs = zip (map getSymbol $ Set.toList $ globals p) (repeat 1) + +tidyLDef :: LDef Var -> TidyM (LDef Var) +tidyLDef = tidyLoc tidyDef + +tidyDef :: Def Var -> TidyM (Def Var) +tidyDef (VarDef vd) = resetLocals >> liftM VarDef (tidyVarDecl vd) +tidyDef (FunDef vd) = resetLocals >> liftM FunDef (tidyFunDef vd) +tidyDef (TyDef vd) = resetLocals >> liftM TyDef (tidyTyDef vd) +tidyDef (ConstDef cd) = resetLocals >> liftM ConstDef (tidyConstDecl cd) + +tidyVarDecl :: VarDecl Var -> TidyM (VarDecl Var) +tidyVarDecl (VarD v td me) + = liftM3 VarD (tidyLVar v) (tidyTyDecl td) (T.mapM tidyTLExpr me) +tidyVarDecl (MultiD v td) + = liftM2 MultiD (mapM tidyLVar v) (tidyTyDecl td) +tidyVarDecl (ContD v td es) + = liftM3 ContD (tidyLVar v) (tidyTyDecl td) (mapM tidyTLExpr es) + +tidyConstDecl :: ConstDecl Var -> TidyM (ConstDecl Var) +tidyConstDecl (ConstD v td c) + = liftM3 ConstD (tidyLVar v) (tidyTyDecl td) (return c) +tidyConstDecl (MultiConstD v td c) + = liftM3 MultiConstD (mapM tidyLVar v) (tidyTyDecl td) (return c) + +tidyFunDef :: Fun Var -> TidyM (Fun Var) +tidyFunDef (Fun v args tds lstmts) + = liftM4 Fun ( tidyLVar v ) + (mapM tidyArg args ) + (mapM tidyTyDecl tds ) + (mapM tidyLStmt lstmts) + +tidyTyDef :: TyDef Var -> TidyM (TyDef Var) +tidyTyDef (TySynDef v td) = liftM2 TySynDef (tidyLVar v) (tidyTyDecl td) +tidyTyDef (StructDecl v fs) = liftM2 StructDecl (tidyLVar v) (mapM tidyFld fs) + +tidyLTyDecl :: LTyDecl Var -> TidyM (LTyDecl Var) +tidyLTyDecl = tidyLoc tidyTyDecl + +tidyTyDecl :: TyDecl Var -> TidyM (TyDecl Var) +tidyTyDecl (BitsD s e) = liftM (BitsD s) $ tidyLExpr e +tidyTyDecl (ModD md) = liftM ModD $ tidyMod md +tidyTyDecl (VectorD e td) = liftM2 VectorD (tidyLExpr e) + (tidyTyDecl td) +tidyTyDecl (MatrixD r c td) = liftM3 MatrixD (tidyLExpr r) + (tidyLExpr c) + (tidyTyDecl td) +tidyTyDecl (TySynD v) = liftM TySynD (tidyLVar v) +tidyTyDecl d = return d + +tidyArg :: Arg Var -> TidyM (Arg Var) +tidyArg (Arg v td) + = liftM2 Arg (tidyLVar v) (tidyTyDecl td) +tidyArg (ArgConst v td i) + = liftM3 ArgConst (tidyLVar v) (tidyTyDecl td) (T.mapM tidyLExpr i) + +tidyFld :: (Located Var, TyDecl Var) -> TidyM (Located Var, TyDecl Var) +tidyFld (v, td) = liftM2 (,) (tidyLVar v) (tidyTyDecl td) + +tidyLStmt :: LStmt Var -> TidyM (LStmt Var) +tidyLStmt = tidyLoc tidyStmt + +tidyStmt :: Stmt Var -> TidyM (Stmt Var) +tidyStmt (VDecl vd) + = liftM VDecl (tidyVarDecl vd) +tidyStmt (CDecl cd) + = liftM CDecl (tidyConstDecl cd) +tidyStmt (Assign lvs es) + = liftM2 Assign (mapM tidyLVal lvs) (mapM tidyTLExpr es) +tidyStmt (FCallS v es) + = liftM2 FCallS (tidyVar v) (mapM tidyTLExpr es) +tidyStmt (Ret es) + = liftM Ret (mapM tidyTLExpr es) +tidyStmt (Ite e ss mss) + = liftM3 Ite (tidyTLExpr e) + (mapM tidyLStmt ss) + (T.mapM (mapM tidyLStmt) mss) +tidyStmt (Seq iter ss) + = liftM2 Seq (tidySeqIter iter) (mapM tidyLStmt ss) +tidyStmt (While e ss) + = liftM2 While (tidyTLExpr e) (mapM tidyLStmt ss) +tidyStmt (Nop a) + = return (Nop a) + +tidyLVal :: LVal Var -> TidyM (LVal Var) +tidyLVal (LVVar v) = liftM LVVar (tidyLVar v) +tidyLVal (LVStruct lv fi) = liftM2 LVStruct (tidyLVal lv) (tidyVar fi) +tidyLVal (LVCont ty lv pat) = liftM2 (LVCont ty) (tidyLVal lv) (tidyAPat pat) + +tidySeqIter :: SeqIter Var -> TidyM (SeqIter Var) +tidySeqIter (SeqIter v s e mb is) + = liftM4 (\v' s' e' mb' -> SeqIter v' s' e' mb' is) + (tidyVar v) (tidyLExpr s) (tidyLExpr e) (T.mapM tidyLExpr mb) + +tidyAPat :: APat Var -> TidyM (APat Var) +tidyAPat (VectP rp) = liftM VectP (tidyRowAPat rp) +tidyAPat (MatP rp cp) = liftM2 MatP (tidyRowAPat rp) (tidyRowAPat cp) + +tidyRowAPat :: RowAPat Var -> TidyM (RowAPat Var) +tidyRowAPat (CElem e) = liftM CElem (tidyTLExpr e) +tidyRowAPat (CRange i j) = liftM2 CRange (tidyTLExpr i) (tidyTLExpr j) + +tidyMod :: Mod Var -> TidyM (Mod Var) +tidyMod (ModNum e) = liftM ModNum (tidyLExpr e) +tidyMod (ModPol td ind p) = liftM3 ModPol (tidyTyDecl td) + (tidyVar ind) + (tidyPol p) + +tidyLit :: Literal Var -> TidyM (Literal Var) +tidyLit (PLit pol) = liftM PLit (tidyPol pol) +tidyLit l = return l + +tidyPol :: Pol Var -> TidyM (Pol Var) +tidyPol (Pol ms) = liftM Pol (mapM tidyMon ms) + +tidyMon :: Mon Var -> TidyM (Mon Var) +tidyMon (Mon c b) = liftM2 Mon (tidyMCoef c) (tidyMBase b) + +tidyMCoef :: MCoef Var -> TidyM (MCoef Var) +tidyMCoef (CoefP p) = liftM CoefP (tidyPol p) +tidyMCoef c = return c + +tidyMBase :: MBase Var -> TidyM (MBase Var) +tidyMBase (MExpI n e) = liftM (flip MExpI e) (tidyVar n) +tidyMBase b = return b + + +tidyLExpr :: LExpr Var -> TidyM (LExpr Var) +tidyLExpr = tidyLoc tidyExpr + +tidyTLExpr :: TLExpr Var -> TidyM (TLExpr Var) +tidyTLExpr = tidyLoc (\ (TyE t e) -> liftM (TyE t) (tidyExpr e)) + +tidyExpr :: Expr Var -> TidyM (Expr Var) +tidyExpr (Var v) = liftM Var (tidyVar v) +tidyExpr (Lit lit) = liftM Lit (tidyLit lit) +tidyExpr (FunCall v es) = liftM2 FunCall (tidyLVar v) (mapM tidyTLExpr es) +tidyExpr (StructProj e fi) = liftM2 StructProj (tidyTLExpr e) (tidyVar fi) +tidyExpr (UnaryOp op e) = liftM (UnaryOp op) (tidyTLExpr e) +tidyExpr (BinaryOp op e1 e2) = liftM2 (BinaryOp op) (tidyTLExpr e1) + (tidyTLExpr e2) +tidyExpr (Access e pat) = liftM2 Access (tidyTLExpr e) (tidyAPat pat) +tidyExpr (Cast b td e) = liftM2 (Cast b) (mapM tidyLTyDecl td) + (tidyTLExpr e) + +tidyLVar :: Located Var -> TidyM (Located Var) +tidyLVar = tidyLoc tidyVar + +tidyVar :: Var -> TidyM Var +tidyVar v + | isLocal v = do + vars <- gets seen + case Map.lookup v vars of + Nothing -> do + v' <- newSymbol v + t' <- tidyType $ varType v' + let v'' = setType t' v' + modify (\s -> s { seen = Map.insert v v'' (seen s) }) + return v'' + Just v' -> return v' + | isGlobalInit v = return v + | nsTyVar v = return v + | isCCast v = return v + | isCFunction v = return v + | otherwise = do + t' <- tidyType $ varType v + return $ setSymbol (addPrefix $ getSymbol v) (setType t' v) + +newSymbol :: Var -> TidyM Var +newSymbol v = do + sc <- gets symbolCount + let vs = getSymbol v + case Map.lookup vs sc of + Nothing -> do + modify (\s -> s { symbolCount = Map.insert vs 1 (symbolCount s) }) + return $ setSymbol (addPrefix vs) v + Just i -> do + modify (\s -> s { symbolCount = Map.adjust (+1) vs (symbolCount s) }) + return $ setSymbol (addPrefix $ vs ++ '_' : show i) v + +tidyType :: Type Var -> TidyM (Type Var) +tidyType (Bits s sz) = + liftM (Bits s) $ tidyIExpr sz +tidyType (Vector n t) = + liftM2 Vector (tidyIExpr n) (tidyType t) +tidyType (Matrix n m t) = + liftM3 Matrix (tidyIExpr n) (tidyIExpr m) (tidyType t) +tidyType (Mod Nothing Nothing (Pol [Mon (CoefI i) EZero])) = do + i' <- tidyIExpr i + return $ Mod Nothing Nothing (Pol [Mon (CoefI i') EZero]) +tidyType (Mod (Just im@(Mod Nothing Nothing (Pol [Mon (CoefI _) EZero]))) + (Just i) + (Pol pol)) = do + im' <- tidyType im + pol' <- mapM aux pol + return $ Mod (Just im') (Just i) (Pol pol') + where + aux (Mon (CoefI co) e) = do + co' <- tidyIExpr co + return $ Mon (CoefI co') e + aux _ = error ": not expected case" +tidyType (TySyn v t) = do + t' <- tidyType t + let tct = TySyn newvar t' + newvar = setType tct v + return tct +tidyType (Struct s flds) = do + fldtys' <- mapM tidyFld' flds + let tct = Struct newvar flds' + newvar = setType tct s + flds' = map(\(v, ty) -> (setType (SField newvar ty) v, ty)) fldtys' + return tct + where + tidyFld' (a, sf) = tidyType sf >>= \ sf' -> return (a, sf') + +tidyType e = return e + +tidyIExpr :: IExpr Var -> TidyM (IExpr Var) +tidyIExpr (IInd v) = liftM IInd $ tidyVar v +tidyIExpr (ISum l) = liftM ISum $ mapM tidyIExpr l +tidyIExpr (IArith op e1 e2) = liftM2 (IArith op) (tidyIExpr e1) (tidyIExpr e2) +tidyIExpr (ISym e) = liftM ISym $ tidyIExpr e +tidyIExpr n@(IInt _) = return n + +{-# INLINE addPrefix #-} +addPrefix :: String -> String +addPrefix = ("c_" ++) + +{-# INLINE tidyLoc #-} +tidyLoc :: (a -> TidyM a) -> Located a -> TidyM (Located a) +tidyLoc f (L l a) = liftM (L l) (f a) + diff --git a/src/Language/CAO/Syntax/Utils.hs b/src/Language/CAO/Syntax/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Syntax/Utils.hs @@ -0,0 +1,1185 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleInstances #-} + +{- +Module : $Header$ +Description : Syntax manipulation utils. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable () + +General functions for AST manipulation or query are provided. +-} + +module Language.CAO.Syntax.Utils + (-- * Variable manipulation + FV ( fvs ) + , BV ( bvs ) + , RN ( (<|>) ) + , Renamable(..) + , Subst ( subst ) + , IsVar + + , lvname + , lvalNames + , globals + , getVars + , getLVars + , getRVars + , sameKind + + -- * Sequences + , isAscSeq + + -- * AST Queries + , isSimpleLVal + , isAssignStmt + , isLit + , isIntLit + , isSimpleVDecl + , isReturn + , defVar + , getDeclVar + , isRange + , isEqNeq + + , type2TyDecl + , Typeable(typeOf) + + ) where + +import Data.IntMap ( IntMap ) +import qualified Data.IntMap as IntMap + +import Data.List ( foldl' ) + +import Data.Map ( Map ) +import qualified Data.Map as Map + +import Data.Set ( Set ) +import qualified Data.Set as Set + +import Language.CAO.Common.Literal +import Language.CAO.Common.Outputable +import Language.CAO.Common.Polynomial +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.Utils ( mapSnd ) +import Language.CAO.Common.Var + +import Language.CAO.Index +import Language.CAO.Index.Utils + +import Language.CAO.Syntax + +import Language.CAO.Type +import Language.CAO.Type.Utils + +type family VarOf f :: * +type instance VarOf Name = Name +type instance VarOf Var = Var + +type instance VarOf (Maybe a) = VarOf a +type instance VarOf [a] = VarOf a +type instance VarOf (Located a) = VarOf a +type instance VarOf (Either a a) = VarOf a + +type instance VarOf (Prog a) = a +type instance VarOf (Def a) = a +type instance VarOf (VarDecl a) = a +type instance VarOf (ConstAnn a) = a +type instance VarOf (ConstDecl a) = a +type instance VarOf (Fun a) = a +type instance VarOf (TyDef a) = a +type instance VarOf (TyDecl a) = a +type instance VarOf (Expr a) = a +type instance VarOf (TExpr a) = a +type instance VarOf (BinOp a) = a +type instance VarOf (Stmt a) = a +type instance VarOf (Arg a) = a +type instance VarOf (Mod a) = a +type instance VarOf (Pol a) = a +type instance VarOf (Mon a) = a +type instance VarOf (MCoef a) = a +type instance VarOf (MBase a) = a +type instance VarOf (APat a) = a +type instance VarOf (RowAPat a) = a +type instance VarOf (Literal a) = a +type instance VarOf (LVal a) = a + +type instance VarOf (Type a) = a +type instance VarOf (Class a) = a + +type instance VarOf (ICond a) = a +type instance VarOf (IExpr a) = a + +type family SubstOf f :: * +type instance SubstOf Name = Name +type instance SubstOf Var = Var + +type instance SubstOf (Maybe a) = SubstOf a +type instance SubstOf [a] = SubstOf a +type instance SubstOf (Located a) = SubstOf a + +type instance SubstOf (Prog a) = Expr a +type instance SubstOf (Def a) = Expr a +type instance SubstOf (VarDecl a) = Expr a +type instance SubstOf (ConstDecl a) = Expr a +type instance SubstOf (Fun a) = Expr a +type instance SubstOf (TyDef a) = Expr a +type instance SubstOf (TyDecl a) = Expr a +type instance SubstOf (Expr a) = Expr a +type instance SubstOf (TExpr a) = Expr a +type instance SubstOf (BinOp a) = Expr a +type instance SubstOf (Stmt a) = Expr a +type instance SubstOf (Arg a) = Expr a +type instance SubstOf (Mod a) = Expr a +type instance SubstOf (Pol a) = IExpr a +type instance SubstOf (Mon a) = IExpr a +type instance SubstOf (MCoef a) = IExpr a +type instance SubstOf (MBase a) = Expr a +type instance SubstOf (APat a) = Expr a +type instance SubstOf (RowAPat a) = Expr a +type instance SubstOf (Literal a) = Expr a +type instance SubstOf (LVal a) = Expr a + +type instance SubstOf (Type a) = IExpr a +type instance SubstOf (Class a) = Expr a + +type instance SubstOf (ICond a) = IExpr a +type instance SubstOf (IExpr a) = IExpr a + +class (FV id, BV id, Ord id, PP id, RN id) => IsVar id where +instance IsVar Name where +instance IsVar Var where + +-------------------------------------------------------------------------------- +-- Free variables +-------------------------------------------------------------------------------- +-- | Free variables +class FV f where + fvs :: (Ord b, VarOf f ~ b) => f -> Set b + + fvsLst :: (Ord b, VarOf f ~ b) => [f] -> Set b + fvsLst = Set.unions . map fvs + +instance FV a => FV (Maybe a) where + fvs Nothing = Set.empty + fvs (Just a) = fvs a + +instance FV a => FV (Located a) where + fvs (L _ a) = fvs a + +instance FV a => FV [a] where + fvs = fvsLst + +instance (FV a, a ~ b) => FV (Either a b) where + fvs (Left l) = fvs l + fvs (Right r) = fvs r + +instance FV Name where + fvs = Set.singleton + +instance FV Var where + fvs = Set.singleton + +instance (IsVar a, a ~ VarOf a) => FV (Def a) where + fvs (VarDef vd) = fvs vd + fvs (FunDef fd) = fvs fd + fvs (TyDef td) = fvs td + fvs (ConstDef cd) = fvs cd + +instance (IsVar a, a ~ VarOf a) => FV (VarDecl a) where + fvs (VarD v td me) = (fvs td `Set.union` fvs me) Set.\\ fvs v + fvs (MultiD vs td) = fvs td Set.\\ fvs vs + fvs (ContD v td es) = (fvs td `Set.union` fvs es) Set.\\ fvs v + +instance (IsVar a, a ~ VarOf a) => FV (ConstAnn a) where + fvs None = Set.empty + fvs (ConstInit e) = fvs e + fvs (ConstCond c) = fvs c + +instance (IsVar a, a ~ VarOf a) => FV (ConstDecl a) where + fvs (ConstD v td i) = (fvs td `Set.union` fvs i) Set.\\ fvs v + fvs (MultiConstD vs td c) = (fvs td `Set.union` fvs c) Set.\\ fvs vs + +instance (IsVar a, a ~ VarOf a) => FV (Fun a) where + fvs (Fun v args rt body) = (fvs body `Set.union` fvs rt) + Set.\\ (fvs v `Set.union` fvs args) + +instance (IsVar a, a ~ VarOf a) => FV (Arg a) where + fvs (Arg a _) = fvs a + fvs (ArgConst a _ _) = fvs a + +instance (IsVar a, a ~ VarOf a) => FV (TyDef a) where + fvs (TySynDef v td) + = fvs td Set.\\ fvs v + fvs (StructDecl v flds) + = Set.unions (map (fvs . snd) flds) + Set.\\ Set.unions (fvs v: map (fvs . fst) flds) + +instance (IsVar a, a ~ VarOf a) => FV (TyDecl a) where + fvs IntD = Set.empty + fvs RIntD = Set.empty + fvs BoolD = Set.empty + fvs (BitsD _ e) = fvs e + fvs (ModD m) = fvs m + fvs (VectorD e td) = fvs e `Set.union` fvs td + fvs (MatrixD e1 e2 td) = fvs e1 `Set.union` fvs e2 `Set.union` fvs td + fvs (TySynD v) = fvs v + +instance (IsVar a, a ~ VarOf a) => FV (Mod a) where + fvs (ModNum e) = fvs e + fvs (ModPol td ti pol) = (fvs td `Set.union` fvs pol) Set.\\ fvs ti + +instance (IsVar a, a ~ VarOf a) => FV (TExpr a) where + fvs (TyE _ e) = fvs e + +instance (IsVar a, a ~ VarOf a) => FV (Expr a) where + fvs (Var v) = fvs v + fvs (Lit l) = fvs l + fvs (FunCall v args) = fvs v `Set.union` fvs args + fvs (StructProj e fi) = fvs e `Set.union` fvs fi + fvs (UnaryOp _ e) = fvs e + fvs (BinaryOp _ e1 e2) = fvs e1 `Set.union` fvs e2 + fvs (Access e1 pat) = fvs e1 `Set.union` fvs pat + fvs (Cast _ td e) = fvs td `Set.union` fvs e + +instance (IsVar a, a ~ VarOf a) => FV (BinOp a) where + fvs _ = Set.empty + +instance (IsVar a, a ~ VarOf a) => FV (Literal a) where + fvs (PLit p) = fvs p + fvs _ = Set.empty + +instance (IsVar a, a ~ VarOf a) => FV (APat a) where + fvs (VectP rp) = fvs rp + fvs (MatP rp cp) = fvs rp `Set.union` fvs cp + +instance (IsVar a, a ~ VarOf a) => FV (RowAPat a) where + fvs (CElem e) = fvs e + fvs (CRange e1 e2) = fvs e1 `Set.union` fvs e2 + +instance (IsVar a, a ~ VarOf a) => FV (Stmt a) where + fvs (VDecl vd) = fvs vd + fvs (CDecl cd) = fvs cd + fvs (Assign lvs es) = fvs lvs `Set.union` fvs es + fvs (FCallS n es) = fvs n `Set.union` fvs es + fvs (Ret e) = fvs e + fvs (Ite i t e) = fvs i `Set.union` fvs t `Set.union` fvs e + fvs (Seq (SeqIter v s e b _) ss) = + (fvs s `Set.union` fvs e `Set.union` fvs b `Set.union` fvs ss) + Set.\\ fvs v + fvs (While e ss) = fvs e `Set.union` fvs ss + fvs (Nop _) = Set.empty + + fvsLst [] = Set.empty + fvsLst (VDecl vd:ss) = fvs ss Set.\\ fvs vd + fvsLst (s:ss) = fvs s `Set.union` fvs ss + +instance (IsVar a, a ~ VarOf a) => FV (LVal a) where + fvs (LVVar v) = fvs v + fvs (LVStruct lv fi) = fvs lv `Set.union` fvs fi + fvs (LVCont _ lv p) = fvs lv `Set.union` fvs p + +instance (IsVar a, a ~ VarOf a) => FV (Pol a) where + fvs (Pol ms) = fvs ms + +instance (IsVar a, a ~ VarOf a) => FV (Mon a) where + fvs (Mon c b) = fvs c `Set.union` fvs b + +instance (IsVar a, a ~ VarOf a) => FV (MCoef a) where + fvs (CoefI _) = Set.empty + fvs (CoefP p) = fvs p + +instance (IsVar a, a ~ VarOf a) => FV (MBase a) where + fvs EZero = Set.empty + fvs (MExpI n _) = fvs n + +instance (IsVar a, a ~ VarOf a) => FV (Type a) where + fvs Int = Set.empty + fvs RInt = Set.empty + fvs Bool = Set.empty + fvs Bullet = Set.empty + fvs (Bits _ e) = fvs e + fvs (Indet t) = fvs t + fvs (Tuple ts) = fvs ts + fvs (Vector e t) = fvs e `Set.union` fvs t + fvs (TySyn v t) = fvs v `Set.union` fvs t + fvs (SField v t) = fvs v `Set.union` fvs t + fvs (Mod mty e p) = Set.unions [fvs mty, fvs e, fvs p] + fvs (Matrix e1 e2 t) = Set.unions [fvs e1, fvs e2, fvs t] + fvs (FuncSig ts t c) = Set.unions [fvs ts, fvs t, fvs c] + fvs (Struct v fs) = Set.unions [fvs v, fvs (map fst fs), + fvs (map snd fs)] + fvs (Index v mc t) = Set.unions [fvs v, fvs mc, fvs t] + fvs (TyVar _) = Set.empty + fvs (IntVar _) = Set.empty + fvs (ModVar _) = Set.empty + +instance (IsVar a, a ~ VarOf a) => FV (IExpr a) where + fvs (IInt _) = Set.empty + fvs (IInd v) = Set.singleton v + fvs (ISum es) = fvs es + fvs (IArith _ e1 e2) = fvs e1 `Set.union` fvs e2 + fvs (ISym e) = fvs e + +instance (IsVar a, a ~ VarOf a) => FV (ICond a) where + fvs (IBool _) = Set.empty + fvs (IBInd v) = Set.singleton v + fvs (INot c) = fvs c + fvs (IAnd cs) = fvs cs + fvs (IBoolOp _ e1 e2) = fvs e1 `Set.union` fvs e2 + fvs (ILeq e) = fvs e + fvs (IEq e) = fvs e + +instance (IsVar a, a ~ VarOf a) => FV (Class a) where + fvs _ = Set.empty + + +-------------------------------------------------------------------------------- +-- Bound variables (defs, args, etc ...) +-- * The bound variables of fun/proc definition are it's local variables +-------------------------------------------------------------------------------- + +-- | Bound variables (defs, args, etc ...) +-- The bound variables of function/procedure definition are its local variables. +class BV f where + bvs :: (Ord b, VarOf f ~ b) => f -> Set b + +instance BV a => BV (Maybe a) where + bvs Nothing = Set.empty + bvs (Just a) = bvs a + +instance BV a => BV (Located a) where + bvs (L _ a) = bvs a + +instance BV a => BV [a] where + bvs = Set.unions . map bvs + +globals :: Prog Var -> Set Var +globals = Set.filter isGlobal . bvs + +instance (IsVar a, a ~ VarOf a) => BV (Prog a) where + bvs (Prog defs ip) = bvs defs `Set.union` maybe Set.empty bvs ip + +instance (IsVar a, a ~ VarOf a) => BV (Def a) where + bvs (VarDef vd) = bvs vd + bvs (FunDef fd) = bvs fd + bvs (TyDef td) = bvs td + bvs (ConstDef cd) = bvs cd + +instance (IsVar a, a ~ VarOf a) => BV (VarDecl a) where + bvs (VarD v _ _) = fvs v + bvs (MultiD vs _) = fvs vs + bvs (ContD v _ _) = fvs v + +instance (IsVar a, a ~ VarOf a) => BV (ConstDecl a) where + bvs (ConstD v _ _) = fvs v + bvs (MultiConstD vs _ _) = fvs vs + +instance (IsVar a, a ~ VarOf a) => BV (Fun a) where + bvs (Fun v args _ body) = bvs body `Set.union` fvs v `Set.union` fvs args + +instance (IsVar a, a ~ VarOf a) => BV (TyDef a) where + bvs (TySynDef v _) + = fvs v + bvs (StructDecl v flds) + = Set.unions $ fvs v : map (fvs . fst) flds + +instance (IsVar a, a ~ VarOf a) => BV (Mod a) where + bvs (ModNum _) = Set.empty + bvs (ModPol _ ti _) = fvs ti + +instance (IsVar a, a ~ VarOf a) => BV (Stmt a) where + bvs (VDecl vd) = bvs vd + bvs (CDecl cd) = bvs cd + bvs (Ite _ t e) = bvs t `Set.union` bvs e + bvs (Seq (SeqIter v _ _ _ _) ss) = fvs v `Set.union` bvs ss + bvs (While _ ss) = bvs ss + bvs _ = Set.empty + +instance BV Name where + bvs _ = Set.empty +instance BV Var where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (Arg a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (TyDecl a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (TExpr a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (Expr a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (BinOp a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (Literal a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (APat a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (RowAPat a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (LVal a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (Pol a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (Mon a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (MCoef a) where + bvs _ = Set.empty +instance (IsVar a, a ~ VarOf a) => BV (MBase a) where + bvs _ = Set.empty + +-------------------------------------------------------------------------------- +-- Variable substitution +-------------------------------------------------------------------------------- + +infixl 7 ~> +infixl 6 +> +infixl 5 \\ +infixl 4 .$. + +infixr 4 <|> + +-- | Variable substitution +class (IsVar v1, IsVar v2) => Renamable v1 v2 where + -- | Remaning environment + data SEnv v1 v2 :: * + + -- | Capture predicate + captures :: SEnv v1 v2 -> Set v1 -> Set v1 -> Bool + -- | Empty renaming environment + emptyRN :: SEnv v1 v2 + -- | Singleton environment where substitution @v1 -> v2@ is stored + (~>) :: v1 -> v2 -> SEnv v1 v2 + -- | Returns the variable that should replace @v1@ from the remaing + -- environment + (.$.) :: SEnv v1 v2 -> v1 -> v2 + -- | (Left-biased) Union of two renaming environments + (+>) :: SEnv v1 v2 -> SEnv v1 v2 -> SEnv v1 v2 + -- | Removes a set of variables from the domain of the renaming + -- environment + (\\) :: SEnv v1 v2 -> Set v1 -> SEnv v1 v2 + +instance Renamable Name Name where + data SEnv Name Name = NN (Map Name Name) + + captures (NN s) bs + = Set.fold goC False + where goC _ True + = True + goC f False + | Just fv <- Map.lookup f s = fv `Set.member` bs + | otherwise = False + emptyRN = NN Map.empty + v1 ~> v2 = NN $ Map.insert v1 v2 Map.empty + NN s2 +> NN s1 = NN $ Map.union s1 s2 + NN s \\ v = NN $ Set.fold Map.delete s v + NN s .$. v + | Just v' <- Map.lookup v s = v' + | otherwise = v + +instance Renamable Var Var where + data SEnv Var Var = VV (IntMap Var) + + captures (VV s) bs + = Set.fold goC False + where goC _ True + = True + goC f False + | Just fv <- IntMap.lookup (varId f) s + = fv `Set.member` bs + | otherwise + = False + emptyRN = VV IntMap.empty + v1 ~> v2 = VV $ IntMap.insert (varId v1) v2 IntMap.empty + VV s2 +> VV s1 = VV $ IntMap.union s1 s2 + VV s \\ v = VV $ Set.fold (\a b -> IntMap.delete (varId a) b) s v + f@(VV s) .$. v + | Just v' <- IntMap.lookup (varId v) s = setType (varType v' <|> f) v' + | otherwise = v + +-- In substitutions from Name to Var, all variables MUST be in the renaming +-- environment +instance Renamable Name Var where + data SEnv Name Var = NV (Map Name Var) + + captures (NV s) bs + = Set.fold goC False + where goC _ True + = True + goC f False + | Just fv <- Map.lookup f s = varName fv `Set.member` bs + | otherwise = False + emptyRN = NV Map.empty + v1 ~> v2 = NV $ Map.insert v1 v2 Map.empty + NV s2 +> NV s1 = NV $ Map.union s1 s2 + NV s \\ v = NV $ Set.fold Map.delete s v + NV s .$. v + | Just v' <- Map.lookup v s = v' + | otherwise = error $ ".\ + \: Not in scope" ++ showPprDebug v + +-------------------------------------------------------------------------------- +-- Types where substitution is defined + + +type family RNTy t v :: * +type instance RNTy Name t = t +type instance RNTy Var t = t + +type instance RNTy [a] b = [RNTy a b] +type instance RNTy (Maybe a) b = Maybe (RNTy a b) +type instance RNTy (Located a) b = Located (RNTy a b) + +type instance RNTy (Prog a) b = Prog (RNTy a b) +type instance RNTy (Def a) b = Def (RNTy a b) +type instance RNTy (Fun a) b = Fun (RNTy a b) +type instance RNTy (TyDef a) b = TyDef (RNTy a b) +type instance RNTy (VarDecl a) b = VarDecl (RNTy a b) +type instance RNTy (LVal a) b = LVal (RNTy a b) +type instance RNTy (Stmt a) b = Stmt (RNTy a b) +type instance RNTy (Arg a) b = Arg (RNTy a b) +type instance RNTy (Literal a) b = Literal (RNTy a b) +type instance RNTy (Class a) b = Class (RNTy a b) +type instance RNTy (Type a) b = Type (RNTy a b) +type instance RNTy (Mod a) b = Mod (RNTy a b) +type instance RNTy (TyDecl a) b = TyDecl (RNTy a b) +type instance RNTy (APat a) b = APat (RNTy a b) +type instance RNTy (RowAPat a) b = RowAPat (RNTy a b) +type instance RNTy (Expr a) b = Expr (RNTy a b) +type instance RNTy (TExpr a) b = TExpr (RNTy a b) +type instance RNTy (BinOp a) b = BinOp (RNTy a b) +type instance RNTy (Pol a) b = Pol (RNTy a b) +type instance RNTy (Mon a) b = Mon (RNTy a b) +type instance RNTy (MCoef a) b = MCoef (RNTy a b) +type instance RNTy (MBase a) b = MBase (RNTy a b) + +type instance RNTy (ICond a) b = ICond (RNTy a b) +type instance RNTy (IExpr a) b = IExpr (RNTy a b) + +-- INVARIANT: Variable capture MUST NOT happen. +-- | Renamables for variables types +class RN t where + (<|>) :: (Renamable v0 v, VarOf t ~ v0, VarOf v0 ~ v0) + => t -> SEnv v0 v -> RNTy t v + + substLst :: (Renamable v0 v, VarOf t ~ v0, VarOf v0 ~ v0) + => [t] -> SEnv v0 v -> [RNTy t v] + substLst lst f = map (<|> f) lst + +-- Renamables for variable types +instance RN Name where + n <|> s = s .$. n + +instance RN Var where + n <|> s = s .$. n + +rnTuple :: (Renamable v0 c, + RN a, RN b, + VarOf a ~ v0, VarOf b ~ v0, VarOf v0 ~ v0) + => (a, b) -> SEnv v0 c -> (RNTy a c, RNTy b c) +rnTuple (a,b) f = (a <|> f, b <|> f) + +-- Renamables for containers +instance RN a => RN [a] where + lst <|> f = substLst lst f + +instance RN a => RN (Maybe a) where + Nothing <|> _ = Nothing + (Just v) <|> f = Just $ v <|> f + +instance RN a => RN (Located a) where + (L l v) <|> f = L l $ v <|> f + +-- Substitution of top-level variables: +-- > Substitute all variables except local vars bound +-- > by local variables. +-- +-- Example: +-- def v0 : ... +-- +-- def f ( ... v0 ...) { ... v0 ... } +-- def g ( ... ) { ... v0 ... } +-- +-- subst v0 ~> v1 +-- +-- def v1 : ... +-- +-- def f ( ... v0 ...) { ... v0 ... } +-- def g ( ... ) { ... v1 ... } +-- +instance RN a => RN (Prog a) where + Prog defs ip <|> f = Prog (defs <|> f) (ip <|> f) + +instance RN a => RN (Def a) where + VarDef vd <|> f = VarDef $ vd <|> f + FunDef vd <|> f = FunDef $ vd <|> f + TyDef vd <|> f = TyDef $ vd <|> f + _ <|> _ = error ".\ + \: Not defined!" + + substLst [] _ = [] + substLst (d:ds) f + | captures f (bvs d) (fvs ds) + = error ".\ + \: Variable capture!" + | otherwise + = (d <|> f) : substLst ds f + +instance RN a => RN (Fun a) where + Fun n args rt stmts <|> f + | captures f bs fs + = error ".\ + \: Variable capture!" + | otherwise + = Fun n' args' rt' stmts' + where n' = n <|> f' + args' = args <|> f' + rt' = rt <|> f' + stmts' = stmts <|> f' + f' = f \\ bs + fs = fvs args `Set.union` fvs stmts + bs = fvs n `Set.union` fvs args + +instance RN a => RN (TyDef a) where + TySynDef n td <|> f + = TySynDef (n <|> f') (td <|> f') + where f' = f \\ fvs n + StructDecl n flds <|> f + = StructDecl (n <|> f') (map (`rnTuple` f') flds) + where f' = f \\ fvs n `Set.union` fvs (map fst flds) + +instance RN a => RN (VarDecl a) where + VarD n td i <|> f = VarD (n <|> f') (td <|> f') (i <|> f') + where f' = f \\ fvs n + MultiD ns td <|> f = MultiD (ns <|> f') (td <|> f') + where f' = f \\ fvs ns + ContD n td is <|> f = ContD (n <|> f') (td <|> f') (is <|> f') + where f' = f \\ fvs n + +instance RN a => RN (LVal a) where + LVVar v <|> f = LVVar $ v <|> f + LVStruct lv fi <|> f = LVStruct (lv <|> f) (fi <|> f) + LVCont t lv pat <|> f = LVCont (t <|> f) (lv <|> f) (pat <|> f) + +instance RN a => RN (Stmt a) where + VDecl vd <|> f = + VDecl (vd <|> f) + Assign lvs es <|> f = + Assign (lvs <|> f) (es <|> f) + FCallS n es <|> f = + FCallS (n <|> f) (es <|> f) + Ret e <|> f = + Ret (e <|> f) + Ite i t e <|> f = + Ite (i <|> f) (t <|> f) (e <|> f) + Seq (SeqIter v s e b r) ss <|> f + | captures f (fvs v) freevs + = error ".:\ + \ variable capture!" + | otherwise + = Seq ( SeqIter (v <|> f') + (s <|> f') + (e <|> f') + (b <|> f') + r ) + ( ss <|> f' ) + where freevs = fvs s + `Set.union` fvs e + `Set.union` fvs b + `Set.union` fvs ss + f' = f \\ fvs v + While e ss <|> f = + While (e <|> f) (ss <|> f) + Nop a <|> _ = Nop a + _ <|> _ = error ".\ + \: Not defined!" + + substLst [] _ + = [] + substLst (s:ss) f + | captures f (bvs s) (fvs ss) + = error ".\ + \: Variable capture!" + | otherwise + = (s <|> f) : substLst ss f + +instance RN a => RN (Arg a) where + Arg n td <|> f = Arg (n <|> f) (td <|> f) + _ <|> _ = error ".\ + \: Not defined!" + + substLst [] _ = [] + substLst (a:as) f + | captures f (fvs a) (fvs as) + = error ".\ + \: Variable capture!" + | otherwise + = (a <|> f) : substLst as f + +instance RN a => RN (Literal a) where + ILit p <|> _ = ILit p + BLit p <|> _ = BLit p + BSLit s p <|> _ = BSLit s p + PLit p <|> f = PLit $ p <|> f + +instance RN a => RN (Class a) where + Pure <|> _ = Pure + RO <|> _ = RO + Proc lst <|> f = Proc $ lst <|> f + +instance RN a => RN (Type a) where + Index v c t <|> f = Index (v <|> f) (c <|> f) (t <|> f) + Mod ty ti p <|> f = Mod (ty <|> f) (ti <|> f) (p <|> f) + Vector i ty <|> f = Vector (i <|> f) (ty <|> f) + Matrix i j ty <|> f = Matrix (i <|> f) (j <|> f) (ty <|> f) + TySyn n ty <|> f = TySyn (n <|> f) (ty <|> f) + FuncSig args rt c <|> f = FuncSig (args <|> f) (rt <|> f) (c <|> f) + Struct n flds <|> f = Struct (n <|> f) (map (`rnTuple` f) flds) + SField n ty <|> f = SField (n <|> f) (ty <|> f) + Indet ty <|> f = Indet (ty <|> f) + Tuple tys <|> f = Tuple (tys <|> f) + Bits s n <|> f = Bits s (n <|> f) + Int <|> _ = Int + RInt <|> _ = RInt + Bool <|> _ = Bool + Bullet <|> _ = Bullet + + -- These should not be needed in the end + + TyVar n <|> _ = TyVar n + IntVar n <|> _ = IntVar n + ModVar n <|> _ = ModVar n + +instance RN a => RN (Mod a) where + ModNum e <|> f = ModNum $ e <|> f + ModPol td ti pol <|> f = ModPol (td <|> f) (ti <|> f) (pol <|> f) + +instance RN a => RN (TyDecl a) where + IntD <|> _ = IntD + RIntD <|> _ = RIntD + BoolD <|> _ = BoolD + BitsD s e <|> f = BitsD s $ e <|> f + ModD m <|> f = ModD $ m <|> f + VectorD e td <|> f = VectorD (e <|> f) (td <|> f) + MatrixD e1 e2 td <|> f = MatrixD (e1 <|> f) (e2 <|> f) (td <|> f) + TySynD v <|> f = TySynD (v <|> f) + +instance RN a => RN (APat a) where + VectP rp <|> f = VectP $ rp <|> f + MatP rp cp <|> f = MatP (rp <|> f) (cp <|> f) + +instance RN a => RN (RowAPat a) where + CElem e <|> f = CElem $ e <|> f + CRange e1 e2 <|> f = CRange (e1 <|> f) (e2 <|> f) + +instance RN a => RN (TExpr a) where + TyE ty e <|> f = TyE (ty <|> f) (e <|> f) + +instance RN a => RN (Expr a) where + Var v <|> f = Var $ v <|> f + Lit l <|> f = Lit (l <|> f) + FunCall n args <|> f = FunCall (n <|> f) (args <|> f) + StructProj e fi <|> f = StructProj (e <|> f) (fi <|> f) + UnaryOp op e <|> f = UnaryOp op $ e <|> f + BinaryOp op e1 e2 <|> f = BinaryOp (op <|> f) (e1 <|> f) (e2 <|> f) + Access td pat <|> f = Access (td <|> f) (pat <|> f) + Cast b td e <|> f = Cast b (td <|> f) (e <|> f) + +instance RN a => RN (BinOp a) where + ArithOp op <|> _ = ArithOp op + BoolOp op <|> _ = BoolOp op + BitOp op <|> _ = BitOp op + BitsSROp op <|> _ = BitsSROp op + CmpOp ty op <|> f = CmpOp (ty <|> f) op + Concat <|>_ = Concat + +-- Renaming for polynomials +instance RN a => RN (Pol a) where + Pol ms <|> f = Pol $ ms <|> f + +instance RN a => RN (Mon a) where + Mon c e <|> f = Mon (c <|> f) (e <|> f) + +instance RN a => RN (MCoef a) where + CoefP p <|> f = CoefP $ p <|> f + CoefI i <|> f = CoefI $ i <|> f + +instance RN a => RN (MBase a) where + EZero <|> _ = EZero + MExpI n e <|> f = MExpI (n <|> f) e + +-- TODO: Capture avoiding!! +instance RN a => RN (ICond a) where + IBool b <|> _ = IBool b + IBInd v <|> f = IBInd $ v <|> f + INot e <|> f = INot $ e <|> f + IAnd le <|> f = IAnd $ le <|> f + ILeq e <|> f = ILeq $ e <|> f + IEq e <|> f = IEq $ e <|> f + IBoolOp op e1 e2 <|> f = IBoolOp op (e1 <|> f) (e2 <|> f) + +instance RN a => RN (IExpr a) where + IInt n <|> _ = IInt n + IInd v <|> f = IInd $ v <|> f + ISum le <|> f = ISum $ le <|> f + ISym e <|> f = ISym $ e <|> f + IArith op e1 e2 <|> f = IArith op (e1 <|> f) (e2 <|> f) + +-- | Substitutions +class Subst f where + -- | Substitution of variable @v0@ by @v1@. + subst :: (VarOf f ~ v0, SubstOf f ~ v1) => (v0, v1) -> f -> f + substBlock :: (VarOf f ~ v0, SubstOf f ~ v1) => (v0, v1) -> [f] -> [f] + substBlock v = map (subst v) + +instance Subst a => Subst (Located a) where + subst f = fmap (subst f) + +instance Subst a => Subst (Maybe a) where + subst f = fmap (subst f) + +instance Subst a => Subst [a] where + subst = substBlock + +instance Eq a => Subst (RowAPat a) where + subst f (CElem e) = CElem $ subst f e + subst f (CRange e1 e2) = CRange (subst f e1) (subst f e2) + +instance Eq a => Subst (APat a) where + subst f (VectP e) = VectP $ subst f e + subst f (MatP e1 e2) = MatP (subst f e1) (subst f e2) + +instance Eq a => Subst (TExpr a) where + subst f (TyE ty e) = TyE ty (subst f e) + +instance Eq a => Subst (Expr a) where + subst (v0, e) v@(Var v1) + | v1 == v0 = e + | otherwise = v + subst _ l@(Lit _) = l + subst f (FunCall n es) = FunCall n $ map (subst f) es + subst f (StructProj e n) = StructProj (subst f e) n + subst f (UnaryOp op e) = UnaryOp op (subst f e) + subst f (BinaryOp op e1 e2) = BinaryOp op (subst f e1) (subst f e2) + subst f (Access e p) = Access (subst f e) (subst f p) + subst f (Cast b td e) = Cast b (subst f td) (subst f e) + +instance Eq a => Subst (BinOp a) where + subst _ c = c + +instance Eq a => Subst (TyDecl a) where + subst f (BitsD s e) = BitsD s $ subst f e + subst f (ModD m) = ModD $ subst f m + subst f (VectorD e td) = VectorD (subst f e) (subst f td) + subst f (MatrixD r c td) = MatrixD (subst f r) (subst f c) (subst f td) + subst _ d = d + +instance Eq a => Subst (Mod a) where + subst f (ModNum e) = ModNum $ subst f e + subst f (ModPol td n pol) = ModPol (subst f td) n pol + +instance Eq a => Subst (Stmt a) where + subst f (VDecl vd) = VDecl (subst f vd) + subst f (Assign lvs es) = Assign (map (subst f) lvs) (map (subst f) es) + subst f (FCallS n es) = FCallS n $ map (subst f) es + subst f (Ret es) = Ret $ map (subst f) es + subst f (Ite i t e) = Ite (subst f i) (subst f t) (subst f e) + subst f@(v0,_) sq@(Seq (SeqIter v1 s e b r) ss) + | v0 == v1 = sq + | otherwise = Seq (SeqIter v1 (subst f s) + (subst f e) + (subst f b) + r ) $ subst f ss + subst f (While e ss) = While (subst f e) (subst f ss) + subst _ (Nop a) = Nop a + subst _ _ = error ".\ + \: Not defined!" + + substBlock _ [] = [] + substBlock f@(v0, _) ss@(VDecl vd : rest) + | v0 `elem` getDeclVar vd = ss + | otherwise = VDecl (subst f vd) : substBlock f rest + substBlock f (s:ss) = subst f s : subst f ss + +instance Eq a => Subst (LVal a) where + subst _ v@(LVVar _) = v + subst f (LVStruct lv e) = LVStruct (subst f lv) e + subst f (LVCont ty lv pat) = LVCont ty (subst f lv) (subst f pat) + +instance Eq a => Subst (VarDecl a) where + subst f (VarD n td e) = VarD n (subst f td) (subst f e) + subst f (MultiD n td) = MultiD n (subst f td) + subst f (ContD n td es) = ContD n (subst f td) $ map (subst f) es + +instance Eq a => Subst (Pol a) where + subst f (Pol ps) = Pol (map (subst f) ps) + +instance Eq a => Subst (Mon a) where + subst f (Mon c b) = Mon (subst f c) b + +instance Eq a => Subst (MCoef a) where + subst f (CoefI i) = CoefI $ subst f i + subst f (CoefP p) = CoefP $ subst f p + +instance Eq a => Subst (Type a) where + subst _ Int = Int + subst _ RInt = RInt + subst _ Bool = Bool + subst f (Bits b i) = Bits b $ subst f i + subst f (Mod a b c) = Mod (subst f a) b (subst f c) + subst f (Vector n t) = Vector (subst f n) (subst f t) + subst f (Matrix n m t) = Matrix (subst f n) (subst f m) (subst f t) + subst f (TySyn v t) = TySyn v (subst f t) + subst f (FuncSig ta tr c) = FuncSig (map (subst f) ta) (subst f tr) c + subst f (Struct v t) = Struct v (map (mapSnd (subst f)) t) + subst f (SField v t) = SField v (subst f t) + subst f (Indet t) = Indet (subst f t) + subst f (Tuple t) = Tuple $ subst f t + subst _ Bullet = Bullet + subst f (Index v c t) = Index v (subst f c) (subst f t) + subst _ _ = error ".\ + \: Not defined!" + +instance Eq a => Subst (ICond a) where + subst _ v@(IBInd _) = v + subst _ l@(IBool _) = l + subst f (INot e) = INot $ subst f e + subst f (IAnd le) = IAnd $ map (subst f) le + subst f (IBoolOp op e1 e2) = IBoolOp op (subst f e1) (subst f e2) + subst f (ILeq e) = ILeq $ subst f e + subst f (IEq e) = IEq $ subst f e + +instance Eq a => Subst (IExpr a) where + subst (v0, e) v@(IInd v1) + | v1 == v0 = e + | otherwise = v + subst _ l@(IInt _) = l + subst f (ISum le) = ISum $ map (subst f) le + subst f (ISym e) = ISym $ subst f e + subst f (IArith op e1 e2) = IArith op (subst f e1) (subst f e2) + +-------------------------------------------------------------------------------- +-- General Utils +-- + +lvname :: LVal id -> id +lvname (LVVar v) = unLoc v +lvname (LVStruct lv _) = lvname lv +lvname (LVCont _ lv _) = lvname lv + +lvalNames :: Ord id => [LStmt id] -> Set id +lvalNames = foldl' lvalNames' Set.empty + where + lvalNames' vs (unLoc -> Assign lvs _) + = vs `Set.union` Set.fromList (map lvname lvs) + lvalNames' vs (unLoc -> Ite _ t e) + = vs `Set.union` lvalNames t `Set.union` maybe Set.empty lvalNames e + lvalNames' vs (unLoc -> While _ ss') + = vs `Set.union` lvalNames ss' + lvalNames' vs (unLoc -> Seq _ ss') + = vs `Set.union` lvalNames ss' + lvalNames' vs _ + = vs + +getVars :: LStmt Var -> [Var] +getVars ss = Set.toList $ Set.filter nsVar $ fvs ss + +getLVars :: Ord id => LStmt id -> [id] +getLVars ss = Set.toList $ lvalNames [ss] + +getRVars :: LStmt Var -> [Var] +getRVars ss = Set.toList $ Set.filter nsVar (fvs ss) Set.\\ lvalNames [ss] + +sameKind :: LStmt Var -> LStmt Var -> Bool +(L _ s1) `sameKind` (L _ s2) = s1 `doSK` s2 + where + doSK :: Stmt Var -> Stmt Var -> Bool + doSK (VDecl _) (VDecl _) + = True + doSK (Assign lvs1 es1) (Assign lvs2 es2) + | length lvs1 == length lvs2 && length es1 == length es2 + = all (uncurry sameKindExpr) $ zip es1 es2 + doSK (FCallS fn1 es1) (FCallS fn2 es2) + = fn1 == fn2 && all (uncurry sameKindExpr) (zip es1 es2) + doSK (Ret es1) (Ret es2) + = all (uncurry sameKindExpr) $ zip es1 es2 + doSK (Ite i1 t1 Nothing) (Ite i2 t2 Nothing) + = sameKindExpr i1 i2 && all (uncurry sameKind) (zip t1 t2) + doSK (Ite i1 t1 (Just e1)) (Ite i2 t2 (Just e2)) + = sameKindExpr i1 i2 && all (uncurry sameKind) (zip t1 t2) + && all (uncurry sameKind) (zip e1 e2) + doSK (Seq si1 ss1) (Seq si2 ss2) + | seqIdx si1 == seqIdx si2 = all (uncurry sameKind) (zip ss1 ss2) + doSK (While _ _) (While _ _) + = False -- Need to have same number of iterations + doSK _ _ + = False + +-- TODO: Review pattern: | guard = True. Is there any good reason to use this? +sameKindExpr :: TLExpr Var -> TLExpr Var -> Bool +sameKindExpr (L _ (TyE _ le1)) (L _ (TyE _ le2)) = ske le1 le2 + where + ske (Var _) (Var _) + = True + ske (Lit _) (Lit _) + = True + ske (FunCall (L _ fn1) es1) (FunCall (L _ fn2) es2) + | fn1 == fn2 && all (uncurry sameKindExpr) (zip es1 es2) + = True + ske (StructProj e1 _ ) (StructProj e2 _ ) + | sameKindExpr e1 e2 + = True + + ske (BinaryOp op1 e11 e12) (BinaryOp op2 e21 e22) + | op1 == op2 && sameKindExpr e11 e21 && sameKindExpr e12 e22 + = True + + ske (UnaryOp op1 e1) (UnaryOp op2 e2) + = op1 == op2 && sameKindExpr e1 e2 + + ske (Access e1 p1) (Access e2 p2) + = sameKindExpr e1 e2 && sameKindPat p1 p2 + ske (Cast _ _ e1) (Cast _ _ e2) + = sameKindExpr e1 e2 + ske _ _ + = False + +sameKindPat :: APat Var -> APat Var -> Bool +sameKindPat (VectP rp1) (VectP rp2) + = sameKindRP rp1 rp2 +sameKindPat (MatP rp1 cp1) (MatP rp2 cp2) + = sameKindRP rp1 rp2 && sameKindRP cp1 cp2 +sameKindPat _ _ + = False + +sameKindRP :: RowAPat Var -> RowAPat Var -> Bool +sameKindRP (CElem e1) (CElem e2) + = sameKindExpr e1 e2 +sameKindRP (CRange e11 e12) (CRange e21 e22) + = sameKindExpr e11 e21 && sameKindExpr e12 e22 +sameKindRP _ _ + = False + + +isAscSeq :: SeqIter id -> Bool +isAscSeq = maybe True aux . seqBy + where + aux :: LExpr id -> Bool + aux (L _ (Lit (ILit n))) = n > 0 + aux _ = error ": not expected case" + +{-# INLINE isSimpleLVal #-} +isSimpleLVal :: LVal id -> Bool +isSimpleLVal (LVVar _) = True +isSimpleLVal _ = False + +{-# INLINE isAssignStmt #-} +isAssignStmt :: Stmt id -> Bool +isAssignStmt (Assign _ _) = True +isAssignStmt _ = False + +{-# INLINE isLit #-} +isLit :: Expr id -> Bool +isLit (Lit _) = True +isLit _ = False + +{-# INLINE isIntLit #-} +isIntLit :: Expr id -> Bool +isIntLit (Lit (ILit _)) = True +isIntLit _ = False + +{-# INLINE isSimpleVDecl #-} +isSimpleVDecl :: Stmt id -> Bool +isSimpleVDecl (VDecl (VarD {})) = True +isSimpleVDecl (VDecl (MultiD {})) = True +isSimpleVDecl _ = False + +{-# INLINE isReturn #-} +isReturn :: Stmt a -> Bool +isReturn (Ret _) = True +isReturn _ = False + +defVar :: LDef id -> [id] +defVar = defV . unLoc + where + defV (VarDef (VarD n _ _)) = [unLoc n] + defV (VarDef (MultiD n _)) = map unLoc n + defV (VarDef (ContD n _ _)) = [unLoc n] + defV (ConstDef (ConstD n _ _)) = [unLoc n] + defV (ConstDef (MultiConstD n _ _)) = map unLoc n + defV (FunDef f) = [unLoc $ funId f] + defV (TyDef (TySynDef t _)) = [unLoc t] + defV (TyDef (StructDecl s _)) = [unLoc s] + +getDeclVar :: VarDecl id -> [id] +getDeclVar (VarD n _ _) = [unLoc n] +getDeclVar (MultiD n _) = map unLoc n +getDeclVar (ContD n _ _) = [unLoc n] + +{-# INLINE isRange #-} +isRange :: APat id -> Bool +isRange (VectP (CRange _ _)) = True +isRange (MatP (CRange _ _) _) = True +isRange (MatP _ (CRange _ _)) = True +isRange _ = False + +{-# INLINE isEqNeq #-} +isEqNeq :: COp -> Bool +isEqNeq bop = case bop of + Eq -> True + Neq -> True + _ -> False + +type2TyDecl :: Type Var -> TyDecl Var +type2TyDecl Int = IntD +type2TyDecl RInt = RIntD +type2TyDecl Bool = BoolD +type2TyDecl (Bits s n) = BitsD s (ind2Expr n) +type2TyDecl (Mod Nothing Nothing (Pol [Mon (CoefI n) EZero])) + = ModD $ ModNum $ ind2Expr n +type2TyDecl (Mod (Just b) (Just i) p) + = ModD $ ModPol (type2TyDecl b) i p +type2TyDecl (Vector k it) + = VectorD (ind2Expr k) (type2TyDecl it) +type2TyDecl (Matrix u v it) + = MatrixD (ind2Expr u) (ind2Expr v) (type2TyDecl it) +type2TyDecl (Struct sn _) + = TySynD (L genSrcLoc sn) +type2TyDecl (SField _ t) = type2TyDecl t +type2TyDecl (Index _ _ t) = type2TyDecl t +type2TyDecl t + = error $ ".: " ++ showPprDebug t + +class Typeable a where + typeOf :: a -> Type Var + +instance Typeable Var where + typeOf = varType + +instance Typeable (TExpr Var) where + typeOf (TyE t _) = t + +instance Typeable (LVal Var) where + typeOf (LVVar v) = varType $ unLoc v + typeOf (LVStruct lv fi) = fieldType fi (typeOf lv) + typeOf (LVCont ty _ _) = ty + +instance Typeable a => Typeable (Located a) where + typeOf (L _ e) = typeOf e + +instance Typeable (IExpr Var) where + typeOf = queryIndexTy + +instance Typeable (Type Var) where + typeOf = id + diff --git a/src/Language/CAO/Transformation/Eval.hs b/src/Language/CAO/Transformation/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Transformation/Eval.hs @@ -0,0 +1,412 @@ +{-# LANGUAGE ViewPatterns #-} +{- | +Module : $Header$ +Description : Expression evaluation. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +Frequently, source code may contain expressions using constant literals that +are not in their most evaluated format. For example, in cryptographic +implementations one often uses container sizes that are the explicit product +of two constants, to improve the clarity of the code. The expansion phase also +introduces literals in expressions by replacing the sequence indices by their +corresponding values. All these expression using literals are amenable to be +partially evaluated during compilation, thus resulting in simpler and more +efficient final code. + +In this phase, several reductions are performed on expressions containing +literals accordingly with the rules defined in the operational semantics. In +many cases, these are quite identical to those defined in the language +interpreter. The main difference is that the interpreter needs all the values +fully defined while the evaluator can handle a mixture of defined and undefined +(variables) values. The evaluation does not give guarantees of completeness: +there may be some expressions that could be more reduced using more +sophisticated approaches. However all the reductions have been designed to be +safe and preserve the semantics of the program. + +The following reductions on expressions are performed during this phase: + +* Whenever possible, arithmetic expressions on literals are computed. This +resorts to some extent to commutativity, associativity and distributivity of +certain operators. + +* Whenever possible, boolean expressions on literals are computed. + +* Casts of literals are evaluated by converting their value to the target type, +accordingly with the semantics. + +* Every nested range access is replaced by an equivalent non-nested range +access. This evaluation is always safe since the type checker already validated +the dimensions of the resulting ranges. +For vectors, the following rules are used, where @v@ is a vector and @l@, +@h@ and @n@ are integer literals: + +@ +v[l..h][n] → v[l + n] +v[l1..h1][l2..h2] → v[l1 + l2..l1 + h2] +@ + +For matrices, the rules are analogous using a second dimension. + + +After the evaluation of expressions, when the condition of a conditional or +iterative statement is a literal, the decision can be statically performed +without changing the meaning of the original program. Therefore, some +statements are also reduced: + +* The corresponding branch of an if statement is chosen if its condition is +a literal. + +* A while statement is removed if its condition is the false literal. +-} + +module Language.CAO.Transformation.Eval ( evalExpr) where + +import Language.CAO.Common.Literal +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.Utils +import Language.CAO.Common.Var ( Var ) +import Language.CAO.Common.Outputable + +import Language.CAO.Semantics.Bool +import Language.CAO.Semantics.Casts +import Language.CAO.Semantics.Integer + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils (isIntLit, isRange, typeOf) + +import Language.CAO.Type + +-- Consider the fusion with function checkIntExp of CaoTypeChecker +-- A more elaborated version could perform more distributivity laws +-- Can this step be fused with the remaining simplification? +evalExpr :: Prog Var -> Prog Var +evalExpr (Prog defs _) = Prog (map (fmap evalDef) defs) Nothing + +evalDef :: Def Var -> Def Var +evalDef (VarDef vd) = VarDef $ evalVD vd +evalDef (FunDef fd) = FunDef $ evalFD fd +evalDef (TyDef td) = TyDef $ evalTDF td +evalDef (ConstDef cd) = ConstDef $ evalCD cd + +evalVD :: VarDecl Var -> VarDecl Var +evalVD (VarD n td (Just e)) = VarD n td (Just $ evalLE e) +evalVD (ContD ln td es) = ContD ln td $ map evalLE es +evalVD vd = vd + +-- Casts are not allowed inside constant initialization, and the type +-- annotation is never needed. Thus, it is safe to be undefined +evalCD :: ConstDecl Var -> ConstDecl Var +evalCD (ConstD c td (ConstInit e)) = ConstD c td (ConstInit (evalL undefined e)) +evalCD cd = cd + +evalFD :: Fun Var -> Fun Var +evalFD (Fun n args rt stmts) + = Fun n (map aux args) + (map evalTD rt) + (concatMap evalLStmt stmts) + + where + aux (Arg a td) = Arg a (evalTD td) + aux (ArgConst a td e) = ArgConst a (evalTD td) e + +evalTDF :: TyDef Var -> TyDef Var +evalTDF (TySynDef n td) = TySynDef n $ evalTD td +evalTDF (StructDecl n flds) = StructDecl n $ map (mapSnd evalTD) flds + +evalLTD :: LTyDecl Var -> LTyDecl Var +evalLTD = fmap evalTD + +evalTD :: TyDecl Var -> TyDecl Var +evalTD (BitsD s e) = BitsD s (evalL RInt e) +evalTD (ModD m) = ModD $ evalMod m +evalTD (VectorD e td) = VectorD (evalL RInt e) (evalTD td) +evalTD (MatrixD e1 e2 td) = MatrixD (evalL RInt e1) (evalL RInt e2) (evalTD td) +evalTD td = td + +evalMod :: Mod Var -> Mod Var +evalMod (ModNum e) = ModNum $ evalL Int e +evalMod (ModPol td n p) = ModPol (evalTD td) n p + +evalStmt :: Stmt Var -> [Stmt Var] +evalStmt (CDecl cd) = [CDecl $ evalCD cd] +evalStmt (VDecl vd) = [VDecl $ evalVD vd] +evalStmt (Assign lvs es) = [Assign (map evalLV lvs) (map evalLE es)] +evalStmt (FCallS n es) = [FCallS n $ map evalLE es] +evalStmt (Ret es) = [Ret $ map evalLE es] +evalStmt (Ite i t me) = let + i' = evalLE i + t' = concatMap evalLStmt t + me' = fmap (concatMap evalLStmt) me + in case unTyp $ unLoc i' of + Lit (BLit True) -> map unLoc t' + Lit (BLit False) -> maybe [] (map unLoc) me' + _ -> [Ite i' t' me'] +evalStmt (Seq (SeqIter v s e b r) ss) + = [Seq (SeqIter v (evalL RInt s) + (evalL RInt e) + (fmap (evalL RInt) b) + r) $ concatMap evalLStmt ss] +evalStmt (While e ss) = let + e' = evalLE e + in case unTyp $ unLoc e' of + Lit (BLit False) -> [] + _ -> [While e' (concatMap evalLStmt ss)] +evalStmt s@(Nop _) = [s] + +evalLStmt :: LStmt Var -> [LStmt Var] +evalLStmt (L l s) = map (L l) $ evalStmt s + +evalL :: Type Var -> LExpr Var -> LExpr Var +evalL t = fmap evalE . annL t + +evalLE :: TLExpr Var -> TLExpr Var +evalLE (L loc e@(TyE tyann _)) = L loc $ TyE tyann $ evalE e + +-- Type annotations are necessary to eval casts +evalE :: TExpr Var -> Expr Var +evalE (TyE _ v@(Var _)) = v +evalE (TyE _ l@(Lit _)) = l +evalE (TyE _ (FunCall n es)) = FunCall n $ map evalLE es +evalE (TyE _ (StructProj e f)) = StructProj (evalLE e) f +evalE (TyE _ (UnaryOp Sym e)) = reduceIntExpr $ UnaryOp Sym $ evalLE e +evalE (TyE _ (UnaryOp Not e)) = reduceBoolExpr $ UnaryOp Not $ evalLE e +evalE (TyE _ (UnaryOp BNot bs)) = UnaryOp BNot $ evalLE bs +evalE (TyE _ (BinaryOp (ArithOp o) l r)) = reduceIntExpr $ + BinaryOp (ArithOp o) (evalLE l) (evalLE r) +evalE (TyE _ (BinaryOp (BoolOp o) l r)) = reduceBoolExpr $ + BinaryOp (BoolOp o) (evalLE l) (evalLE r) +evalE (TyE _ (BinaryOp op e1 e2)) = BinaryOp op (evalLE e1) (evalLE e2) +evalE (TyE _ (Access e p)) = reduceRanges $ Access (evalLE e) (evalP p) +evalE (TyE t (Cast b td e)) = + case evalLE e of + -- Needed to evaluate nested casts of literals + L _ l@(TyE _ (Lit _)) -> convertTo t l + e' -> Cast b (map evalLTD td) e' + +evalP :: APat Var -> APat Var +evalP (VectP p) = VectP $ evalAP p +evalP (MatP l r) = MatP (evalAP l) (evalAP r) + +evalAP :: RowAPat Var -> RowAPat Var +evalAP (CElem e) = CElem $ evalLE e +evalAP (CRange l r) = CRange (evalLE l) (evalLE r) + +evalLV :: LVal Var -> LVal Var +evalLV (LVStruct lv fi) = LVStruct (evalLV lv) fi +evalLV (LVCont ty lv p) + = case reduceLRanges (LVCont ty (evalLV lv) (evalP p)) of + LVCont ty' lv' p' -> LVCont ty' (evalLV lv') (evalP p') + _ -> error ".\ + \: Unexpected error in 'reduceLRanges'" +evalLV v@(LVVar _) = v + +-------------------------------------------------------------------------------- + +getTLInt :: TLExpr Var -> Either (Integer, SrcLoc, Type Var) (TLExpr Var) +getTLInt (L l (TyE t (Lit (ILit i)))) = Left (i, l, t) +getTLInt e = Right e + +getTInt :: TLExpr Var -> Either (Integer, Type Var) (TLExpr Var) +getTInt (unLoc -> TyE t (Lit (ILit i))) = Left (i, t) +getTInt e = Right e + +reduceAssoc :: AOp -> (Integer -> Integer) -> TLExpr Var -> TLExpr Var -> Expr Var +reduceAssoc op i (getTInt -> Left (j, _)) (getTInt -> Left (k, _)) + = Lit $ ILit $ i $ fInt op j k +reduceAssoc op i (getTLInt -> Left (j,l, t)) (getTInt -> Right k) + = BinaryOp (ArithOp op) (L l $ annTyE t $ Lit $ ILit $ i j) k +reduceAssoc op i (getTInt -> Right j) (getTLInt -> Left (k,l,t)) + = BinaryOp (ArithOp op) j (L l $ annTyE t $ Lit $ ILit $ i k) +reduceAssoc _ _ _ _ + = error ".: Unexpected case" + +reduceTimesPlus :: Integer -> TLExpr Var -> TLExpr Var -> Expr Var +reduceTimesPlus i (getTInt -> Left (j, _)) (getTInt -> Left (k, _)) = + Lit $ ILit $ i * (j + k) +reduceTimesPlus i (getTLInt -> Left (j, l, t)) (getTInt -> Right k) = + BinaryOp (ArithOp Plus) + (L l $ annTyE t $ Lit $ ILit $ j `integerTimes` i) + (L (getLoc k) $ annTyE t $ + BinaryOp (ArithOp Times) (genLoc $ annTyE t $ Lit $ ILit i) k) +reduceTimesPlus i (getTInt -> Right j) (getTLInt -> Left (k, l, t)) = + BinaryOp (ArithOp Plus) + (L (getLoc j) $ annTyE t $ + BinaryOp (ArithOp Times) (genLoc $ annTyE t $ Lit $ ILit i) j) + (L l $ annTyE t $ Lit $ ILit $ k `integerTimes` i) +reduceTimesPlus i (getTInt -> Right j) (getTInt -> Right k) = + BinaryOp (ArithOp Plus) + (L (getLoc j) $ annTyE tj $ BinaryOp (ArithOp Times) ei j) + (L (getLoc k) $ annTyE (typeOf k) $ BinaryOp (ArithOp Times) ei k) + where + tj = typeOf j + ei = genLoc $ annTyE tj $ Lit $ ILit i +reduceTimesPlus e1 e2 e3 = + error $ ".:\ + \ Unexpected case: (" ++ showPpr e1 ++ ") * ((" ++ showPpr e2 + ++ ") + (" ++ showPpr e3 ++ "))" + + +reduceIntExpr :: Expr Var -> Expr Var +-- Simple exprs +reduceIntExpr (BinaryOp (ArithOp (fInt -> op)) + (getTInt -> Left (b1, _)) + (getTInt -> Left (b2, _))) + = Lit $ ILit $ b1 `op` b2 +reduceIntExpr (UnaryOp Sym (getTInt -> Left (b1, _))) + = Lit $ ILit $ negate b1 + +-- Distributivity of '*' +reduceIntExpr (BinaryOp (ArithOp Times) + (getTInt -> Right (unLoc -> unTyp -> BinaryOp (ArithOp Plus) e1 e2)) + (getTInt -> Left (e3, _))) + = reduceTimesPlus e3 e1 e2 +reduceIntExpr (BinaryOp (ArithOp Times) + (getTInt -> Left (e3, _)) + (getTInt -> Right (unLoc -> unTyp -> BinaryOp (ArithOp Plus) e1 e2))) + = reduceTimesPlus e3 e1 e2 + +-- Associativity +reduceIntExpr (BinaryOp (ArithOp oop) + (getTInt -> Right (unLoc -> unTyp -> BinaryOp (ArithOp iop) e1 e2)) + (getTInt -> Left (e3, _))) + | isAssoc oop && oop == iop && (isIntLit (unTyp (unLoc e1)) || isIntLit (unTyp (unLoc e2))) + = reduceAssoc oop (flip (fInt oop) e3) e1 e2 +reduceIntExpr (BinaryOp (ArithOp oop) + (getTInt -> Left (e3, _)) + (getTInt -> Right (unLoc -> unTyp -> BinaryOp (ArithOp iop) e1 e2))) + | isAssoc oop && oop == iop && (isIntLit (unTyp (unLoc e1)) || isIntLit (unTyp (unLoc e2))) + = reduceAssoc oop (fInt oop e3) e1 e2 +-- Minus Case +-- +-- +-- reduceAssoc takes advantage also from commutativity, so +-- isAssoc now is True only for associative and commutative ops) +reduceIntExpr + (BinaryOp (ArithOp Minus) + (getTInt -> Right (unLoc -> unTyp -> BinaryOp (ArithOp Minus) + (getTInt -> Left (e1, _)) + (getTInt -> Left (e2, _)))) + (getTInt -> Left (e3, _))) + = Lit $ ILit (e1 - e2 - e3) +reduceIntExpr + (BinaryOp (ArithOp Minus) + (getTInt -> Right (unLoc -> unTyp -> BinaryOp (ArithOp Minus) + (getTInt -> Right e1) + (getTLInt -> Left (e2, l, _)))) + (getTInt -> Left (e3, t))) + = BinaryOp (ArithOp Minus) e1 (L l $ annTyE t $ Lit $ ILit (e2 - e3)) +reduceIntExpr + (BinaryOp (ArithOp Minus) + (getTInt -> Right (unLoc -> unTyp -> BinaryOp (ArithOp Minus) + (getTLInt -> Left (e1, l, _)) + (getTInt -> Right e2))) + (getTInt -> Left (e3, t))) + = BinaryOp (ArithOp Minus) (L l $ annTyE t $ Lit $ ILit (e1 - e3)) e2 +reduceIntExpr + (BinaryOp (ArithOp Minus) + (getTInt -> Left (e3, t)) + (getTInt -> Right (unLoc -> unTyp -> BinaryOp (ArithOp Minus) + (getTInt -> Right e1) + (getTLInt -> Left (e2, l, _))))) + = BinaryOp (ArithOp Minus) (L l $ annTyE t $ Lit $ ILit (e2 + e3)) e1 +reduceIntExpr + (BinaryOp (ArithOp Minus) + (getTInt -> Left (e3, t)) + (getTInt -> Right (unLoc -> unTyp -> BinaryOp (ArithOp Minus) + (getTLInt -> Left (e1, l, _)) + (getTInt -> Right e2)))) + = BinaryOp (ArithOp Plus) (L l $ annTyE t $ Lit $ ILit (e3 - e1)) e2 +-- +reduceIntExpr e + = e + + +-------------------------------------------------------------------------------- + +getBool :: TLExpr Var -> Maybe Bool +getBool (unLoc -> unTyp -> Lit (BLit b)) = Just b +getBool _ = Nothing + +reduceBoolExpr :: Expr Var -> Expr Var +reduceBoolExpr (BinaryOp (BoolOp (fBool -> op)) + (getBool -> Just b1) + (getBool -> Just b2)) + = Lit $ BLit $ b1 `op` b2 +reduceBoolExpr (UnaryOp Not (getBool -> Just b1)) + = Lit $ BLit $ boolNot b1 +reduceBoolExpr e + = e + +-------------------------------------------------------------------------------- + +reduceRanges :: Expr Var -> Expr Var +reduceRanges (Access (unLoc -> (TyE _ (Access e1 p1))) p2) | isRange p1 + = Access e1 $ reducePats p1 p2 +reduceRanges e + = e + +-- | Reduce nested ranges in LValues +-- +-- Examples: +-- m[1..5,2..3][3,1] -----> +-- m' = m[1..5,2..3] : matrix[5,2] of a' +-- m'[3,1] : a' +-- =====> reduces to m[4,3] +-- +-- m[1..5,2..3][3 .. 4,1] -----> +-- m' = m[1..5,2..3] : matrix[5,2] of a' +-- m'[3 .. 4 ,1] : matrix [2, 1] of a' +-- reduces to m[4 .. 5, 3] +-- +reduceLRanges :: LVal Var -> LVal Var +reduceLRanges (LVCont ty (LVCont _ lv' p1) p2) | isRange p1 + = LVCont ty lv' (reducePats p1 p2) +reduceLRanges lv + = lv + +reducePats :: APat Var -> APat Var -> APat Var +reducePats (VectP r1) (VectP r2) + = VectP $ reduceRngs r1 r2 +reducePats (MatP r11 r12) (MatP r21 r22) + = MatP (reduceRngs r11 r21) (reduceRngs r12 r22) +reducePats _ _ + = error $ ".\ + \: Unexpected case." + +reduceRngs :: RowAPat Var -> RowAPat Var -> RowAPat Var +reduceRngs (CRange e1 _) (CElem ei) + = CElem $ L (getLoc e1) $ annTyE RInt $ reduceIntExpr $ + BinaryOp (ArithOp Plus) e1 ei +reduceRngs (CRange e1 _) (CRange el eh) + = CRange (L (getLoc e1) $ annTyE RInt $ reduceIntExpr $ + BinaryOp (ArithOp Plus) e1 el) + (L (getLoc e1) $ annTyE RInt $ reduceIntExpr $ + BinaryOp (ArithOp Plus) e1 eh) +reduceRngs _ _ + = error $ ".\ + \: Unexpected case." + +-------------------------------------------------------------------------------- + +fInt :: AOp -> Integer -> Integer -> Integer +fInt Plus = integerPlus +fInt Minus = integerMinus +fInt Times = integerTimes +fInt Power = integerPower +fInt Div = integerDiv +fInt ModOp = integerMod + +isAssoc :: AOp -> Bool +isAssoc Plus = True +isAssoc Times = True +isAssoc _ = False + +fBool :: BOp -> Bool -> Bool -> Bool +fBool And = boolAnd +fBool Or = boolOr +fBool Xor = boolXor diff --git a/src/Language/CAO/Transformation/Expand.hs b/src/Language/CAO/Transformation/Expand.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Transformation/Expand.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE PatternGuards #-} +{-| +Module : $Header$ +Description : Sequence unrolling. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +In the expansion phase, sequential code replaces iteration in sequence +statements. This phase is optional: the sequence statements can be later +translated to iterative C code. Expansion of sequences is a trade-off between +the memory used by the machine code and the execution time. Usually expanded +code will be faster because there are no conditional jumps and some of the +expressions can be partially evaluated. However, this may not be the case if +the target machine architecture uses an intermediate cache memory that is not +enough to hold all the code. In this situation, conditional jumps may be +preferable to cache misses but this has to be determined experimentally. + +A sequence statement is an iteration instruction where the bounds and the +increment of the index (bound) variable are statically known. This means that +we can compute during compilation the number of times that the sequence body is +executed and the values that the index variable will take. To expand the +sequence, its body is replicated by that number of times and the sequence index +is replaced by its respective value. Although similar to traditional loop +unrolling, this expansion has some subtleties: + +* In nested sequences, for each value taken by the index variable of the outer +sequence, there has to be a list of index variable values for the inner +sequence. This implies that the outer sequence has to be expanded before the +inner sequence. + +* Subsequent steps rely on type annotations to generate correctly typed code, +thus type annotations in expanded code must be updated accordingly with +expansion. Since CAO has a limited form of dependent types, the type of some +expressions inside the sequence body are functions of the index variable. + +-} + +module Language.CAO.Transformation.Expand ( + expandSequences +) where + +import Control.Applicative ( (<$>) ) +import Control.Monad + +import Data.DList ( DList ) +import qualified Data.DList as DL +import Data.Set ( Set ) +import qualified Data.Set as Set + +import Language.CAO.Common.Literal +import Language.CAO.Common.Monad +import Language.CAO.Common.Polynomial +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Language.CAO.Index +import Language.CAO.Index.Eval + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils + +import Language.CAO.Type + +-- | This function expands the body sequence statements with known bounds. +-- If any limit (bounds) is not statically known, the sequence body +-- is not expanded. +expandSequences :: CaoMonad m => Prog Var -> m (Prog Var) +expandSequences (Prog defs _) = + liftM2 Prog (mapM (mapML go) defs) (return Nothing) + where + -- Simple program traversal to handle with statements + go :: CaoMonad m => Def Var -> m (Def Var) + go (FunDef (Fun n args rt ss)) = + FunDef . Fun n args rt <$> concatMapM expandStmt ss + go d = return d + +-- Since a single sequence statement can be expanded to a block of statements, +-- the resulting type is a list +-- We must also traverse statements which contain themselves blocks of +-- statements. +expandStmt :: CaoMonad m => LStmt Var -> m [LStmt Var] +expandStmt s@(L _ (Seq _ _)) = seqCase s +expandStmt (L l (Ite i t e)) = + singleton . L l <$> liftM2 (Ite i) (concatMapM expandStmt t) + (mapMaybeM (concatMapM expandStmt) e) +expandStmt (L l (While c ss)) = + singleton . L l . While c <$> concatMapM expandStmt ss +expandStmt s = return [s] + +-------------------------------------------------------------------------------- + +-- Values that the bound variable will take during the sequence execution +seqRange :: Integer -> Integer -> Integer -> [Integer] +seqRange strt final dist = enumFromThenTo strt (strt + dist) final + +seqCase :: CaoMonad m => + LStmt Var -> m [LStmt Var] +seqCase (L loc (Seq (SeqIter ivar estart eend eby rng) ss)) = do + case (unLoc estart, unLoc eend) of + -- The bounds are statically known + (Lit (ILit estart'), Lit (ILit eend')) -> do + let insts = seqRange estart' eend' (auxMBy eby) + bvars = bvs ss + -- Expands the sequence: + stmt <- expandSeq ss bvars ivar insts + -- Expands nested sequences: + concatMapM expandStmt stmt + -- The bounds are not statically knonw, but inner sequences must + -- be expanded + _ -> singleton . L loc . Seq (SeqIter ivar estart eend eby rng) <$> + concatMapM expandStmt ss + where + auxMBy Nothing = 1 + auxMBy (Just (L _ (Lit (ILit by)))) = by + auxMBy e = error $ show e +seqCase _ = error ".\ + \: unexpected case" + +expandSeq :: CaoMonad m => [LStmt Var] -> Set Var -> Var -> [Integer] -> m [LStmt Var] +expandSeq stmt bvars ivar ilst = liftM DL.toList $ foldM worker DL.empty ilst + where + worker :: CaoMonad m => DList (LStmt Var) -> Integer -> m (DList (LStmt Var)) + worker sstms i = do + -- Gets a new unique identifier to each bound variable of the sequence + -- XXX: do we need this? + rbv <- mapM (\ x -> uniqId >>= \ i' -> return (x, i')) bvsSeq + return $ sstms `DL.append` DL.fromList (renameStmt rbv i) + + -- XXX: is this definitions correct? + bvsSeq :: [Var] + bvsSeq = Set.toList bvars + + renameStmt :: [(Var, Int)] -> Integer -> [LStmt Var] + renameStmt rbv i = map (sLStmt (ivar, IInt i) + . (renamer $ retyp . renameBVs rbv)) + $ subst (ivar, Lit $ ILit i) stmt + where + + renamer :: (Var -> Var) -> LStmt Var -> LStmt Var + renamer f = fmap (fmap f) + + -- Correcting type annotations, so that the index variable is replaced by + -- its instantiation value + retyp :: Var -> Var + retyp v = setType (sType (ivar, IInt i) $ typeOf v) v + + renameBVs :: [(Var, Int)] -> Var -> Var + renameBVs bvslst v = maybe v (flip setId v) (lookup v bvslst) + +-------------------------------------------------------------------------------- +-- More boilerplate... +-- This should be replaced by a generic transformation + +sLStmt :: (Var, IExpr Var) -> LStmt Var -> LStmt Var +sLStmt s = fmap (sStmt s) + +sStmt :: (Var, IExpr Var) -> Stmt Var -> Stmt Var +sStmt s (Assign lvals es) = Assign (map (sLVal s) lvals) (map (sTLExpr s) es) +sStmt s (FCallS f es) = FCallS f (map (sTLExpr s) es) +sStmt s (Ret es) = Ret (map (sTLExpr s) es) +sStmt s (Ite e stmts mst) = Ite (sTLExpr s e) (map (sLStmt s) stmts) (fmap (map (sLStmt s)) mst) +sStmt s (While e stmts) = While (sTLExpr s e) (map (sLStmt s) stmts) +sStmt s (Seq iter stmts) = Seq iter (map (sLStmt s) stmts) +sStmt _ s = s + +sTLExpr :: (Var, IExpr Var) -> TLExpr Var -> TLExpr Var +sTLExpr s (L l (TyE t e)) = L l $ TyE (sType s t) (sExpr s e) + +sExpr :: (Var, IExpr Var) -> Expr Var -> Expr Var +sExpr s (FunCall f es) = FunCall f (map (sTLExpr s) es) +sExpr s (StructProj e fld) = StructProj (sTLExpr s e) fld +sExpr s (UnaryOp op e) = UnaryOp op (sTLExpr s e) +sExpr s (BinaryOp op e1 e2) = BinaryOp op (sTLExpr s e1) (sTLExpr s e2) +sExpr s (Access e pat) = Access (sTLExpr s e) pat +sExpr s (Cast b d e) = Cast b d (sTLExpr s e) +sExpr _ e = e + +sLVal :: (Var, IExpr Var) -> LVal Var -> LVal Var +sLVal s (LVVar (L l v)) = LVVar $ L l $ setType (sType s $ typeOf v) v +sLVal s (LVStruct lv fld) = LVStruct (sLVal s lv) fld +sLVal s (LVCont typ lv pat) = LVCont (sType s typ) (sLVal s lv) pat + +sType :: (Var, IExpr Var) -> Type Var -> Type Var +sType s (Bits sg e) = Bits sg $ evalExpr (subst s e) +sType s (Mod Nothing Nothing (Pol [Mon (CoefI m) EZero])) = + Mod Nothing Nothing (Pol [Mon (CoefI (evalExpr (subst s m))) EZero]) +sType s (Vector e t) = Vector (evalExpr (subst s e)) (sType s t) +sType s (Matrix e1 e2 t) = Matrix (evalExpr (subst s e1)) (evalExpr (subst s e2)) (sType s t) +sType s (Tuple ts) = Tuple $ map (sType s) ts +sType _ t = t +-- XXX: This definition is incomplete and may have some problems with indexes and mods diff --git a/src/Language/CAO/Transformation/Indist.hs b/src/Language/CAO/Transformation/Indist.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Transformation/Indist.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{- +Module : $Header$ +Description : Indistinguishable functions. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} +module Language.CAO.Transformation.Indist + ( mkIndistFun + , indist + ) where + +import Control.Applicative +import Data.List +import qualified Data.Map as M +import Data.Set ( Set ) +import qualified Data.Set as Set +import Data.Maybe ( catMaybes ) +import qualified Data.Traversable as T +import qualified Data.Foldable as F + +import Language.CAO.Common.Error +import Language.CAO.Common.Fresh +import Language.CAO.Common.Monad +import Language.CAO.Common.Outputable +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.State +import Language.CAO.Common.Var + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils ( getVars, getLVars, sameKind, fvs, defVar ) +import Language.CAO.Analysis.CFG +import Language.CAO.Analysis.SsaBack ( introduceDefs, rmVars ) + + +-------------------------------------------------------------------------------- +-- * Indistinguishable functions +-------------------------------------------------------------------------------- + +-- | Apply countermeasures to two function definitions +mkIndistFun :: CaoMonad m => String -> String -> [CaoCFG] -> m [CaoCFG] +mkIndistFun (mkFunName -> fn1) (mkFunName -> fn2) cfgs + | Just ((p1,p2), (cfg1, cfg2), cfgs2) <- mcfgs, valid cfg1, valid cfg2 = do + (cfg1', cfg2') <- mkIndistCfg (fn1, cfg1) (fn2, cfg2) + return $ insertPos [(p1, cfg1'), (p2, cfg2')] cfgs2 + | otherwise = indistWarn fn1 fn2 >> return cfgs + where mcfgs :: Maybe ((Int, Int),(CaoCFG, CaoCFG), [CaoCFG]) + mcfgs = do + (p1, cfg1, cfgs') <- lookupDef fn1 cfgs + (p2, cfg2, cfgs'') <- lookupDef fn2 cfgs' + return ((p1, p2), (cfg1, cfg2), cfgs'') + + -- TODO: stub + valid _ = True + +mkIndistCfg :: CaoMonad m => (Name, CaoCFG) -> (Name, CaoCFG) -> m (CaoCFG, CaoCFG) +mkIndistCfg (name1, cfg1) (name2, cfg2) + | Just ((n1, n2), (b1, b2), (c1, c2)) <- mcfgs = do + (b1', b2') <- indist b1 b2 + let cfg1' = introduceDefs $ rmVars $ cfg1 { blocks = M.insert n1 (b1', c1) bcfg1 } + cfg2' = introduceDefs $ rmVars $ cfg2 { blocks = M.insert n2 (b2', c2) bcfg2 } + mkIndistDecls cfg1' cfg2' + | otherwise = indistWarn name1 name2 >> return (cfg1, cfg2) + + where bcfg1 = blocks $ removeSsaDecl cfg1 + bcfg2 = blocks $ removeSsaDecl cfg2 + mcfgs = do + (n1, b1, c1) <- innerNode entryNode [exitNode] bcfg1 + (n2, b2, c2) <- innerNode entryNode [exitNode] bcfg2 + return ((n1,n2), (b1,b2), (c1,c2)) + +mkIndistDecls :: CaoMonad m => CaoCFG -> CaoCFG -> m (CaoCFG, CaoCFG) +mkIndistDecls cfg1 cfg2 + | Just ((n1, n2), (b1, b2), (c1, c2)) <- mcfgs = do + (b1', b2') <- indistDecls b1 b2 + return ( cfg1 { blocks = M.insert n1 (b1', c1) bcfg1 } + , cfg2 { blocks = M.insert n2 (b2', c2) bcfg2 } + ) + | otherwise = return (cfg1, cfg2) + where + bcfg1 = blocks cfg1 + bcfg2 = blocks cfg2 + mcfgs :: Maybe ((NodeId, NodeId), (BasicBlock, BasicBlock), (Connections, Connections)) + mcfgs = do + (n1, b1, c1) <- innerNode entryNode [exitNode] bcfg1 + (n2, b2, c2) <- innerNode entryNode [exitNode] bcfg2 + return ((n1, n2), (b1, b2), (c1, c2)) + + +-- Pre: all operations are already "indistinguishable". +indistDecls :: CaoMonad m => BasicBlock -> BasicBlock -> m (BasicBlock, BasicBlock) +indistDecls b1 b2 = do + (db1', db2') <- case ldb1 of + _ | ldb1 == ldb2 -> return (db1, db2) + | ldb1 > ldb2 -> do + db2'' <- mapM dummyDecl (drop ldb2 db1) + return (db1, db2 ++ db2'') + | otherwise -> do -- ldb2 > ldb1 + db1'' <- mapM dummyDecl (drop ldb1 db2) + return (db1 ++ db1'', db2) + return (db1' ++ rb1, db2' ++ rb2) + where + (db1, rb1) = partition isDecl b1 + (db2, rb2) = partition isDecl b2 + ldb1 = length db1 + ldb2 = length db2 + isDecl (L _ (VDecl _)) = True + isDecl _ = False + +dummyDecl :: CaoMonad m => LStmt Var -> m (LStmt Var) +dummyDecl (unLoc -> VDecl vd) + = genLoc . VDecl <$> T.mapM (freshVar Local . varType) vd +dummyDecl s + = error $ "Language.CAO.CaoSSA.dummyDecl: failed to create a dummy\ + \operation of this kind!" ++ showPpr s + + +innerNode :: NodeId -> [NodeId] -> M.Map NodeId (BasicBlock, Connections) + -> Maybe (NodeId, BasicBlock, Connections) +innerNode e next m + | Just (_, [n]) <- M.lookup e m -- entry + , Just (b, rest) <- M.lookup n m -- inner + , rest == next -- connections are OK, TODO:ordering + = Just (n, b, rest) + | otherwise + = Nothing + +lookupDef :: Name -> [CaoCFG] -> Maybe (Int, CaoCFG, [CaoCFG]) +lookupDef n cfgs + | ([(i,cfg)], cfgs') <- partitionPos hasName cfgs = Just (i,cfg, cfgs') + | otherwise = Nothing + where hasName = (== [n]) . map varName . defVar . definition + +partitionPos :: (a -> Bool) -> [a] -> ([(Int, a)], [a]) +partitionPos f lst = partitionPosAcc 0 ([],[]) lst + where partitionPosAcc _ r [] = r + partitionPosAcc a (ys,ns) (x:xs) + | f x = partitionPosAcc (a + 1) ((a,x):ys, ns ) xs + | otherwise = partitionPosAcc (a + 1) (ys , x:ns) xs + +insertPos :: [(Int, a)] -> [a] -> [a] +insertPos lst xs = foldl' (\b (i, x) -> insertAt i x b) xs $ sortBy compareFst lst + where compareFst (i1,_) (i2,_) = compare i1 i2 + +insertAt :: Int -> a -> [a] -> [a] +insertAt 0 x lst = x:lst +insertAt _ x [] = [x] +insertAt n x (y:ys) = y:insertAt (n - 1) x ys + +indistWarn :: CaoMonad m => Name -> Name -> m () +indistWarn v1 = caoWarning defSrcLoc . IndistFail v1 + +-- | Turn two CFG basic blocks into indistinguishable +-- +-- Notes: (b1', b2') <- b1 `indist` b2 +indist :: CaoMonad m => BasicBlock -> BasicBlock -> m (BasicBlock, BasicBlock) +indist b1 b2 = mkIndist (mkStmtGraph b1) (mkStmtGraph b2) + +-- | Algorithm for indistinguishable functions +-- TODO: check best place for dummy ops +mkIndist :: CaoMonad m => StmtGraph -> StmtGraph + -> m (BasicBlock, BasicBlock) +mkIndist g1 g2 = do + tr <- doMkSTree [SN { cost = 0 + , stmt1 = [] + , stmt2 = [] + , rest1 = g1 + , rest2 = g2 + }] + let (r:_) = sortBy (\(c1,_,_) (c2,_,_) -> compare c1 c2) tr + return $ (\(_,x,y) -> (x,y)) r + +-------------------------------------------------------------------------------- +-- ** Solution +-------------------------------------------------------------------------------- + +data SNode = SN { cost :: Int + , stmt1 :: BasicBlock + , stmt2 :: BasicBlock + , rest1 :: StmtGraph + , rest2 :: StmtGraph + } + +fCost :: SNode -> Int +fCost sn = cost sn + fDist (rest1 sn) + fDist (rest2 sn) + +cmpNd :: SNode -> SNode -> Ordering +cmpNd sn1 sn2 = compare (fCost sn1) (fCost sn2) + +{- +Not used but can be useful in the future +nextNode :: SNode -> SNode -> SNode +nextNode (SN sc b1 b2 _ _) (SN sc2 s1 s2 g1' g2') + = SN (sc + sc2) (s1 ++ b1) (s2 ++ b2) g1' g2' +-} + +doMkSTree :: CaoMonad m => [SNode] -> m [(Int, BasicBlock, BasicBlock)] +doMkSTree [] = return [] +doMkSTree es@(sn:xs) + | nullG g1 && nullG g2 = do + rs <- doMkSTree xs + return $ (cost sn, reverse $ stmt1 sn, reverse $ stmt2 sn):rs + | otherwise = do + alts <- sortBy cmpNd . concat <$> mapM nextNodes es + doMkSTree (take 200 alts) --- $ concatMap (\e -> map (nextNode e) alts) es + where g1 = rest1 sn + g2 = rest2 sn + +fDist :: StmtGraph -> Int +fDist (SGraph w _) = w + +nextNodes :: CaoMonad m => SNode -> m [SNode] +nextNodes sn = (sn' ++) <$> dummys + where g1 = rest1 sn + g2 = rest2 sn + altsG1 = anyStmt g1 + altsG2 = anyStmt g2 + sn' = map mkAlt $ combinations altsG1 altsG2 + mkAlt ((s1,g1'),(s2,g2')) + = sn { stmt1 = s1:(stmt1 sn) + , stmt2 = s2:(stmt2 sn) + , rest1 = g1' + , rest2 = g2' + } + dummys = do + d1 <- mapM addDL $ filter (not . isRet . fst) altsG1 + d2 <- mapM addDR $ filter (not . isRet . fst) altsG2 + return $ d1 ++ d2 + addDL (s, g) + | not (needsDummy s) = + return $ sn { stmt1 = s :(stmt1 sn) + , rest1 = g + } + | otherwise = do + (n, vs, s') <- mkDummyOp s + F.mapM_ storeTmpVar vs + return $ sn { cost = (cost sn) + n + , stmt1 = s :(stmt1 sn) + , stmt2 = s':(stmt2 sn) + , rest1 = g + } + addDR (s, g) + | not (needsDummy s) = + return $ sn { stmt2 = s :(stmt2 sn) + , rest2 = g + } + | otherwise = do + (n, vs, s') <- mkDummyOp s + F.mapM_ storeTmpVar vs + return $ sn { cost = (cost sn) + n + , stmt2 = s :(stmt2 sn) + , stmt1 = s':(stmt1 sn) + , rest2 = g + } + -- TODO: Refactor + isRet (L _ (Ret _)) = True + isRet _ = False + needsDummy (L _ (Assign _ _)) = True + needsDummy _ = False + + +combinations :: [(LStmt Var, StmtGraph)] -> [(LStmt Var, StmtGraph)] + -> [((LStmt Var, StmtGraph),(LStmt Var, StmtGraph))] +combinations l1 l2 = [ ((s1, g1), (s2, g2)) | (s1, g1) <- l1 + , (s2, g2) <- l2 + , sameKind s1 s2 ] + +-------------------------------------------------------------------------------- +-- ** Dependency graphs +-------------------------------------------------------------------------------- +type LOC = Int +type Weight = Int + +-- a := b; +-- b := c; +-- r := s; +-- z := b + r; +-- +-- 1 -> (a := b, []) +-- 2 -> (b := c, [1]) +-- 3 -> (r := s, []) +-- 4 -> (z := b + r, [2,3]) +-- Statement dependency graph. Array of statements and list of dependencies +data StmtGraph = SGraph Weight (M.Map LOC (LStmt Var, [LOC])) + +instance PP StmtGraph where + ppr (SGraph _ m) = vsep $ map (\(l, s) -> ppr l <+> text "->" <+> ppr s) $ M.assocs m + +-- | Check if dependency graph is null +nullG :: StmtGraph -> Bool +nullG (SGraph _ m) = M.null m + +{- +Not used but useful in the future. +-- | emptyGraph +emptyGraph :: StmtGraph +emptyGraph = SGraph 0 M.empty +-} + +-- | Create a dependency graph from a basicblock +mkStmtGraph :: BasicBlock -> StmtGraph +mkStmtGraph ss = SGraph w $! lssDeps + where lss = zip [1..] ss {--} -- zip [length ss, length ss -1..1] $ ss + (w, lssDeps) = calculateDeps M.empty M.empty lss + + calculateDeps :: M.Map Var LOC -> M.Map Var LOC -> [(LOC, LStmt Var)] + -> (Weight, M.Map LOC (LStmt Var, [LOC])) + calculateDeps _ _ [] + = (0, M.empty) + calculateDeps lvars vars ((loc, stmt):rest) + = (w' + stmtCost stmt, mm `seq` M.insert loc (stmt, nub $ deps1 ++ deps2) mm) + where lvs = getLVars stmt + vs = getVars stmt + nlvs = foldl' (\m v -> M.insert v loc m) lvars lvs + nvs = foldl' (\m v -> M.insert v loc m) vars vs + deps1 = catMaybes $ map (`M.lookup` lvars) $ vs + deps2 = catMaybes $ map (`M.lookup` vars) $ lvs + (w', mm) = calculateDeps nlvs nvs rest + +{- +Not used but useful in the future +takeBlock :: StmtGraph -> (BasicBlock, StmtGraph) +takeBlock (SGraph w a) = ng `seq` (stmts, SGraph w' ng) + where noDeps = M.filter (null . snd) a + stmts = map fst $ M.elems noDeps + locs = M.keys noDeps + (w',ng) = M.foldWithKey fAdjDeps (w,a) a + fAdjDeps :: LOC -> (LStmt Var, [LOC]) + -> (Weight, M.Map LOC (LStmt Var, [LOC])) + -> (Weight, M.Map LOC (LStmt Var, [LOC])) + fAdjDeps k (stmt, deps) (wgt, mp) + | k `elem` locs = (wgt - stmtCost stmt, mp `seq` M.delete k mp) + | otherwise = (wgt, mp `seq` M.insert k (stmt, deps \\ locs) mp) +-} +anyStmt :: StmtGraph -> [(LStmt Var, StmtGraph)] +anyStmt (SGraph w a) = map fGetAlts ndlst + where ndlst = M.assocs $ M.filter (null . snd) a + + fGetAlts :: (LOC, (LStmt Var, [LOC])) -> (LStmt Var, StmtGraph) + fGetAlts (k, (s, _)) = (s, SGraph (w - stmtCost s) + $! M.foldWithKey (fAdjDeps k) a a) + + fAdjDeps :: LOC -> LOC -> (LStmt Var, [LOC]) + -> M.Map LOC (LStmt Var, [LOC]) + -> M.Map LOC (LStmt Var, [LOC]) + fAdjDeps toDel k (stmt, deps) mp + | k == toDel = mp `seq` M.delete k mp + | otherwise = mp `seq` M.insert k (stmt, filter (/= toDel) deps) mp + +{- +Not used but useful in the future +-- | Traverse StmtGraph +toStmtList :: StmtGraph -> [LStmt Var] +toStmtList g + | nullG g = [] + | otherwise = s' ++ toStmtList g' + where (s', g') = takeBlock g + +stmtsOf :: StmtGraph -> [LStmt Var] +stmtsOf (SGraph _ a) = map fst $ M.elems a +-} + +-------------------------------------------------------------------------------- +-- ** Operations +-------------------------------------------------------------------------------- + +---- | Compare two statement blocks. +---- +---- The result is an integer whose value denotes the cost of introducing the +---- necessary dummy ops to turn both blocks indistinguishable +--compareBlocks :: BasicBlock -> BasicBlock -> Int +--compareBlocks = undefined + +-- | Create dummy op +mkDummyOp :: CaoMonad m => LStmt Var -> m (Int, Set Var, LStmt Var) +mkDummyOp (unLoc -> Assign lvs es) = do + (vs' ,lvs') <- unzip <$> mapM mkDummyLv lvs + (ns, vs'',es') <- unzip3 <$> mapM mkDummyLExpr es + return (sum ns, Set.unions $ vs' ++ vs'', genLoc $ Assign lvs' es') +mkDummyOp (unLoc -> FCallS fn es) = do + (ns, vs, es') <- unzip3 <$> mapM mkDummyLExpr es + return (sum ns, Set.unions vs, genLoc $ FCallS fn es') +mkDummyOp s + = error $ "Language.CAO.CaoSSA.mkDummyOp: failed to create a dummy\ + \operation of this kind!" ++ showPpr s +-- mkDummyOp (Ret es) = Ret <$> mapM mkDummyLExpr es +-- mkDummyOp (Ite i t me) = +-- mkDummyOp (Seq (SeqIter id) [LStmt id] +-- mkDummyOp (While e1 ss) +-- mkDummyOp (VDecl vd) + +mkDummyLv :: CaoMonad m => LVal Var -> m (Set Var, LVal Var) +mkDummyLv (LVVar (L _ v)) = lvvar <$> freshVar Local (varType v) + where + lvvar v' = (Set.singleton v', LVVar $ genLoc v') +mkDummyLv (LVStruct lv n) = fixT2 (flip LVStruct n) (mkDummyLv lv) +mkDummyLv (LVCont t lv p) = fixT2 (flip (LVCont t) p) (mkDummyLv lv) + +mkDummyLExpr :: CaoMonad m => TLExpr Var -> m (Int, Set Var, TLExpr Var) +mkDummyLExpr (L l e) = fixT3 (L l) (mkDummyExpr e) + +fixT2 :: CaoMonad m => (a -> b) -> m (c, a) -> m (c, b) +fixT2 f m = (\(a, b) -> (a, f b)) <$> m +fixT3 :: CaoMonad m => (a -> b) -> m (r, s, a) -> m (r, s, b) +fixT3 f m = (\(a, b, c) -> (a, b, f c)) <$> m + +-- TODO: complete with other exprs, fix cost of ops +mkDummyExpr :: CaoMonad m => TExpr Var -> m (Int, Set Var, TExpr Var) +mkDummyExpr (TyE t e@(BinaryOp (ArithOp op) _ _)) = do + e' <- T.mapM (freshVar Local . varType) e + return (costAOp op, fvs e', TyE t e') +mkDummyExpr e = do + e' <- T.mapM (freshVar Local . varType) e + return (0 , fvs e', e') -- TODO: Complete!!! + +{- +Not used but useful in the future +-- | BasicBlock cost +blockCost :: BasicBlock -> Int +blockCost = sum . map stmtCost +-} + +-- | Stmt cost +stmtCost :: LStmt Var -> Int +stmtCost (unLoc -> Assign _ es) + = sum $ map costLExpr es +stmtCost (unLoc -> FCallS _ es) + = sum $ map costLExpr es +stmtCost _ + = 0 + +costLExpr :: TLExpr Var -> Int +costLExpr (L _ (TyE _ e)) = costExpr e + +-- TODO: complete with other exprs, fix cost of ops +costExpr :: Expr Var -> Int +costExpr (BinaryOp (ArithOp op) _ _) = costAOp op +costExpr _ = 0 + +costAOp :: AOp -> Int +costAOp Plus = 1 +costAOp Minus = 1 +costAOp Times = 10 +costAOp Div = 10 +costAOp ModOp = 10 +costAOp Power = 100 + +-- TODO: create dependency funcs. Place statements with no dependencies. Check +-- all possible reorderings with the cost of the necessary dummy instructions +-- and pick the lowest. Remove dependencies from graph and continue. diff --git a/src/Language/CAO/Transformation/Simplify.hs b/src/Language/CAO/Transformation/Simplify.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Transformation/Simplify.hs @@ -0,0 +1,985 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{- | +Module : $Header$ +Description : CAO program simplification. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +The simplification step aims at reducing the mismatch between CAO and C or, +more precisely, the C backend. Compilers that generate assembly code +traditionally use an intermediate representation known as three-address code, +in which every instruction is in its simpler form with two operand addresses +and one result address. Since we are targeting a software API as a backend, our +format is quite different but shares some of the same principles. Operations +in the backend expect variables or constants as parameters and a variable as +result. This means that nested expressions must be extracted and replaced by +an auxiliary variable. For instance, the following assignment of an arithmetic +expression: + +> a := 3 * b + 2 * c - 4; + +should be transformed to: + +@ +def t0 : int; +def t1 : int; +def t2 : int; +t0 := 3 * b; +t1 := 2 * c; +t2 := t0 + t1; +a := t2 - 4; +@ + +In general, for assignments of results from binary and unary operations, we +must obey the following format in which @op2@ is a binary operator, @op1@ is an +unary operator, @var@ is a variable and @e1@ and @e2@ are either variables or +constants: + +@ + := + / \ + var op2 + / \ + e1 e2 +@ + +@ + := + / \ + var op1 + | + e1 +@ + +Similar formats were defined for the other operations, leading to a normalized +code format, ready to be translated to C. This normalization process also +includes the following actions: + +* The initialization of global variables is removed from their declaration and +put in a global init procedure. + +* Simultaneous variable declarations are transformed to multiple simple variable +declarations. + +* The initializations of variable declarations are removed from declarations +and added as independent statements, except for container initializations +(vectors and matrices). Here, the natural way of simplifying this kind of +initializations would be a position-wise assignment. However, this would +invalidate block initialization during translation. Therefore, only expressions +inside container initializations are simplified. + +* Parallel assignments are transformed to several simple assignments +(except parallel assignments from multiple function results which can only be +resolved during translation with the introduction of references). + +* All other expressions are simplified in order that operands may be either +variables or constants. + +-} +module Language.CAO.Transformation.Simplify ( + simplifyCaoAST + ) where + +import Control.Monad.State +import Data.DList () +import qualified Data.DList as DL +import qualified Data.List as Lst +import Data.Maybe +import Data.Set () +import qualified Data.Set as Set + +import Language.CAO.Common.Error +import Language.CAO.Common.Fresh +import Language.CAO.Common.Monad +import Language.CAO.Common.Polynomial +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.State +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Language.CAO.Index +import Language.CAO.Index.Utils +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils +import Language.CAO.Type +import Language.CAO.Type.Utils + +-- +--The left value code is not correctly handled during the translation: +-- seq i := 1 to 30 { +-- vec[i+3-n][n*3*i+i] := vec[i+3-n][n*3*i+i]; +-- } +-- +--Without renaming this temporary variable generation schema fails if there +--is any identifier of the form "t0", "t1", ... on the code + +type SS = LStmt Var +type ConstDef = LStmt Var +type VarDeclaration = LStmt Var + +-- CaoAST ---------------------------------------------------------------------- + +-- | Applies the simplification step to the AST. Takes as parameter, the name +-- of the global inititialization procedure. +simplifyCaoAST :: CaoMonad m => String -> Prog Var -> m (Prog Var) +simplifyCaoAST initProcName (Prog defs _) = withSimplifyST $ do + (defs', stmts, cdecl, vdecl) <- concatMapAndUnzip4M simplifyDef defs + -- The global initialization procedure is only necessary if there is + -- something to initialize. + let initDef = if null stmts && null cdecl && null vdecl + then Nothing + else let + -- Written global variables inside the init procedure, i.e., + -- initialization of global variables. + -- Testing for assignments is necessary [See note 8] + wvars = Set.toList $ Set.filter isGlobalVar $ + fvs $ filter (isAssignStmt . unLoc) stmts + fName = globalInit initProcName wvars + body = funcBody cdecl vdecl stmts + in Just $ Fun (genLoc fName) [] [] body + return $ Prog defs' initDef + +-- Definition ------------------------------------------------------------------ +{- +This function returns: +* A list of global definitions. Since multiple variable definitions are +transformed into several individual declarations, as list is needed. +* A list of assignments used as initialization of global declarations in the +global initialization procedure. We should notice that besides assign +statements, also container declarations are used [See note 8]. +* A list of auxiliary constant definitions (declaration + initialization) +to be used in the global initialization procedure. +* A list of auxiliary variable declarations to be used in the global +initialization procedure. + +-} +simplifyDef + :: CaoMonad m + => LDef Var + -> m ( [LDef Var] + , [SS] + , [ConstDef] + , [VarDeclaration] + ) +simplifyDef (L l (VarDef vd)) = do + (vd', stmts, index, decl) <- simplifyVarDeclaration vd + return (map (L l . VarDef) vd', stmts, index, decl) +simplifyDef (L l (FunDef f)) = do + f' <- simplifyFunc f + return (L l (FunDef f') : [], [], [], []) +simplifyDef d@(L _ (TyDef _)) = return (d : [], [], [], []) +simplifyDef (L l (ConstDef cd)) = do + (cd', index) <- simplifyConstDeclaration cd True + return (L l (ConstDef cd') : [], [], DL.toList index, []) + + +-- Func ------------------------------------------------------------------------ +{- +Note 1: +The introduction of depedent types implies that type expression have to be +simplified, too. For instance, the index of type: +@vector[3 * n + 1] of int@ +must be broken down to simple expressions: + +@ +t0 := 3 * n; +t1 := t0 + 1; +vector [t1] of int; +@ + +To simplify this process, a environment was introduced to hold new types for +variables. This means that the simplification process is done only once and +then all uses of the same variable are immediately retyped. This environment +has to be reset everytime a function body is processed. +-} +simplifyFunc :: CaoMonad m => + Fun Var -> m (Fun Var) +simplifyFunc (Fun fname args rtype body) = do + resetSimplifyST -- [See Note 1] + (body', index, decl) <- simplifyStatements body + let body'' = funcBody' index decl body' + return (Fun fname args rtype body'') + +{- +Note 2: +The order of statements inside a function is important since there are +dependencies between declarations, definitions and assignments. Thus, the +body is divided in logical blocks, marked by annotations. The overall schema +is the following: + +[ Index (simbolic variable) declarations ] + Nop EndIndex +[ Auxiliary variable declarations ] + Nop EndAux +[ Assignemnts to variables ] + +This schema is needed because +- indexes may be used in the declaration of variables. +- subsequent phases of the compiler pipeline must know where each block ends. +(better explain this point). +-} +funcBody :: [ConstDef] -> [VarDeclaration] -> [SS] -> [LStmt Var] +funcBody index decl body = fBody (++) (:) index decl body + +funcBody' :: DL.DList ConstDef + -> DL.DList VarDeclaration + -> DL.DList SS -> [LStmt Var] +funcBody' index decl body = DL.toList $ + fBody DL.append DL.cons index decl body + +fBody :: (t -> t1 -> t2) + -> (Located (Stmt id) -> t2 -> t1) + -> t -> t -> t2 -> t2 +fBody append cons index decl body = + index + `append` + ((genLoc $ Nop EndIndex) `cons` (decl + `append` + ((genLoc $ Nop EndAux) `cons` body))) + +-- Statement ------------------------------------------------------------------- + +-- For statements, this is mostly traversal code. + +simplifyStatements + :: CaoMonad m + => [LStmt Var] + -> m (DL.DList (LStmt Var), DL.DList ConstDef, DL.DList VarDeclaration) +simplifyStatements = concatMapAndUnzip3MD simplifyStatement + +simplifyStatement + :: CaoMonad m + => LStmt Var + -> m (DL.DList (LStmt Var), DL.DList ConstDef, DL.DList VarDeclaration) +simplifyStatement (L l s) = simplifyStmt l s + +simplifyStmt + :: CaoMonad m + => SrcLoc -> Stmt Var + -> m (DL.DList (LStmt Var), DL.DList ConstDef, DL.DList VarDeclaration) + +simplifyStmt l (VDecl vd) = simplifyLocalVarDeclaration l vd +simplifyStmt l (CDecl cd) = do + (cd', cdecls) <- simplifyConstDeclaration cd False + return (DL.empty, cdecls `DL.snoc` L l (CDecl cd') , DL.empty) + +simplifyStmt l (Assign lv' e') = + case (lv', e') of + (lv:[], e:[] ) -> simplifyAssignment l lv e + (_:_:_, e:[] ) -> simplifyTupleAssignment l lv' e + (_:_:_, _:_:_) -> simplifyMultipleAssignment l lv' e' + _ -> error ".\ + \: unexpected case in assignment" + +-- XXX: Is it necessary to update type annotations? +simplifyStmt l (FCallS fid exps) = do + (exps', stmts, cdecl, vdecl) <- simplifyExps exps + return (stmts `DL.snoc` L l (FCallS fid (DL.toList exps')), cdecl, vdecl) + +simplifyStmt l (Ret exps) = do + (exps', stmts, cdecl, vdecl) <- simplifyExps exps + return (stmts `DL.snoc` L l (Ret (DL.toList exps')), cdecl, vdecl) + +simplifyStmt l (Ite i t e) = do + (cond', stmts, cdecl1, vdecl1) <- simplifyExpChoice i + (i', cdecl2, vdecl2) <- simplifyStatements t + (e', cdecl3, vdecl3) <- simplifyM e + return ( stmts `DL.snoc` L l (Ite cond' (DL.toList i') e') + , cdecl1 `DL.append` cdecl2 `DL.append` cdecl3 + , vdecl1 `DL.append` vdecl2 `DL.append` vdecl3) + where + simplifyM Nothing = return (Nothing, DL.empty, DL.empty) + simplifyM (Just s) = do + (e'', cdecl, vdecl) <- simplifyStatements s + return (Just (DL.toList e''), cdecl, vdecl) + +simplifyStmt l (While cond wstms) = do + (cond', stmts, cdecl1, vdecl1) <- simplifyExpChoice cond + (wstms', cdecl2, vdecl2) <- simplifyStatements wstms + -- The condition has to be added to the end of the body [See Note 3] + let wbody = DL.toList $ wstms' `DL.append` stmts + return ( stmts `DL.snoc` L l (While cond' wbody) + , cdecl1 `DL.append` cdecl2 + , vdecl1 `DL.append` vdecl2) + +--- XXX: type annotations +-- The simplification of the bound values can make pointer from integers +-- depending of the backend +simplifyStmt l (Seq (SeqIter v s e b r) sstms) = do + -- A type annotation was added because 'simplifyExpChoice' expects it. + -- The bounds must always be of type RInt + (s', st1, cdecl1, vdecl1) <- simplifyExpChoice (annL RInt s) + (e', st2, cdecl2, vdecl2) <- simplifyExpChoice (annL RInt e) + (b', st3, cdecl3, vdecl3) <- simplifyM b + (sstms' , cdecl4, vdecl4) <- simplifyStatements sstms + -- All variables/constants that do not depend on the index may be declared + -- only once outside the body of the sequence. + -- Otherwise, they have to be declared inside the body of the function + let (cdeclS, cdeclO) = innerConsts v $ DL.toList cdecl4 -- [See Note] + (vdeclS, vdeclO) = innerVars (v : declaredConsts cdeclS) $ DL.toList vdecl4 + sstms'' = cdeclS ++ vdeclS ++ DL.toList sstms' + cdeclO' = DL.fromList cdeclO + vdeclO' = DL.fromList vdeclO + return ( st1 `DL.append` st2 `DL.append` st3 `DL.snoc` + L l ( Seq (SeqIter v (unTypL s') (unTypL e') b' r) sstms'' ) + , cdecl1 `DL.append` cdecl2 `DL.append` cdecl3 `DL.append` cdeclO' + , vdecl1 `DL.append` vdecl2 `DL.append` vdecl3 `DL.append` vdeclO') + where + simplifyM Nothing = return (Nothing, DL.empty, DL.empty, DL.empty) + simplifyM (Just mb) = do + (b', st3, cdecl, vdecl) <- simplifyExpChoice (annL RInt mb) + return (Just (unTypL b'), st3, cdecl, vdecl) + +simplifyStmt l (Nop a) = return (DL.singleton (L l (Nop a)), DL.empty, DL.empty) + +{- +Note: +Declarations inside sequences can depend on the iteration variable. Moreover, +declarations can also depend on constants which depend themselves on the +iteration variable. +This way, we have to compute the transitive closure of dependencies starting +in the iteration variable. After having the set of all constants, we can also +determine the list of all variables which have dependencies. +All variables whose type dependends on the iteration variable must remain +inside the body of the sequence. All other can be removed to outside the body +and shared between all iterations. +-} +declaredConsts + :: [ConstDef] + -> [Var] +declaredConsts = catMaybes . map (constDecl . unLoc) + where + constDecl (CDecl (ConstD (L _ cd) _ _)) = Just cd + constDecl _ = Nothing + +innerConsts + :: Var -> [ConstDef] + -> ([ConstDef], [ConstDef]) +innerConsts i cdecls = let + -- The base case are the constants that depend on the index variable + (base, rest) = Lst.partition (Set.member i . fvs) cdecls + in fixpoint rest base + where + fixpoint rest [] = ([], rest) + fixpoint rest base = let + (base' , rest' ) = innerVars (declaredConsts base) rest + (base'', rest'') = fixpoint rest' base' + in (base ++ base'', rest'') + +innerVars + :: [Var] -> [VarDeclaration] + -> ([VarDeclaration], [VarDeclaration]) +innerVars consts vdecls = Lst.partition (mbr . fvs) vdecls + where + mbr vs = any (\c -> Set.member c vs) consts + +{- +Note 3: +If we face a condition on a while statement which is not in the simplified form, + we must simplify it to basic operations. However, unlike if statements, it +is not enough to add them before the beginning of the cycle. We have also to +add this to the end of the body of the cycle, because the condition has to be +calculated in every iteration. Otherwise, we just have an infinit loop whenever +the condition is true for the first values. + +For instance: +@ + while (3 * i + j < i * j) { + ... + i := i + 1; + j := j + 1; +} +@ +must be simplified to: +@ + t0 := 3 * i; + t1 := t0 + j; + t2 := i * j; + cond := t1 < t2; + while (cond) { + ... + i := i + 1; + j := j + 1; + t0 := 3 * i; + t1 := t0 + j; + t2 := i * j; + cond := t1 < t2; +} +@ +-} + +-- LValue ---------------------------------------------------------------------- + +simplifyLValue + :: CaoMonad m + => LVal Var + -> m ( LVal Var + , DL.DList SS + , DL.DList ConstDef + , DL.DList VarDeclaration) +simplifyLValue (LVVar (L l v)) = do + (v', cdecl) <- simplifyVar v + return (LVVar (L l v'), DL.empty, cdecl, DL.empty) +simplifyLValue (LVStruct lv fld) = do + (lv', stmts, cdecl, vdecl) <- simplifyLValue lv + -- XXX: type annotation of fld + return (LVStruct lv' fld, stmts, cdecl, vdecl) +simplifyLValue (LVCont ty lv p) = do + (ty', cdeclt) <- simplifyType ty + (lv', stmts1, cdecl1, vdecl1) <- simplifyLValue lv + (p' , stmts2, cdecl2, vdecl2) <- simplifyPat p + return ( LVCont ty' lv' p' + , stmts1 `DL.append` stmts2 + , cdeclt `DL.append` cdecl1 `DL.append` cdecl2 + , vdecl1 `DL.append` vdecl2) + +-- Assignments ----------------------------------------------------------------- + +simplifyAssignment + :: CaoMonad m + => SrcLoc -> LVal Var -> TLExpr Var + -> m ( DL.DList (LStmt Var) + , DL.DList ConstDef + , DL.DList VarDeclaration) +simplifyAssignment loc lv e = do + (lv', stmts1, cdecl1, vdecl1) <- simplifyLValue lv + (e', stmts2, cdecl2, vdecl2) <- +-- When we have a simple left variable, we just have to simplify the assigned +-- expression, and add a new assignment in the end. The use of 'simplifyExp' +-- guarantees that, for instance, 3 + v, is not further simplified. + if' (isSimpleLVal lv') simplifyExp simplifyExpChoice e + return ( stmts1 `DL.append` stmts2 `DL.snoc` L loc (Assign (lv':[]) (e':[])) + , cdecl1 `DL.append` cdecl2 + , vdecl1 `DL.append` vdecl2) + +{- + +Note 6: +The simplification of parallel assignments is trickier because of +its semantics. The assigned value is always the value before the +assignment. Thus, the following example: +@ a, b := b, a; @ +is, in fact, the swap of the values between variables 'a' and 'b'. +This has to be expanded to: +@ + t0 := b; + t1 := a; + b := t1; + a := t0; +@ +to maintain the semantics. However, the code is more complex +and more variables are introduced. +-} + +-- Precondition: |lvs| > 1, |exps| > 1, |lvs| = |exps| +simplifyMultipleAssignment + :: CaoMonad m + => SrcLoc -> [LVal Var] -> [TLExpr Var] + -> m (DL.DList (LStmt Var), DL.DList ConstDef, DL.DList VarDeclaration) +simplifyMultipleAssignment _ [] [] = return (DL.empty, DL.empty, DL.empty) +simplifyMultipleAssignment loc (lv:lvs) (e:exps) = do + (lv', vdecl) <- newLVar (typeOf lv) + -- "Frozzing" the values + (stmt1, cdecl1, vdecl1) <- simplifyAssignment loc lv' e + -- Handling the rest of the variables + (stmt2, cdecl2, vdecl2) <- simplifyMultipleAssignment loc lvs exps + -- Assigning the values + (stmt3, cdecl3, vdecl3) <- simplifyAssignment loc lv (toExp lv') + return ( stmt1 `DL.append` stmt2 `DL.append` stmt3 + , cdecl1 `DL.append` cdecl2 `DL.append` cdecl3 + , vdecl `DL.cons` (vdecl1 `DL.append` vdecl2 `DL.append` vdecl3)) +simplifyMultipleAssignment _ _ _ = caoError defSrcLoc $ mkUnknownErr + ".\ + \: not expected case" + + +-- Precondition: |lvs| > 1 |e| = 1, e is a function call +simplifyTupleAssignment + :: CaoMonad m + => SrcLoc -> [LVal Var] -> TLExpr Var + -> m (DL.DList (LStmt Var), DL.DList ConstDef, DL.DList VarDeclaration) +-- We need a special case for simultaneous casts of function results, since +-- this cannot be handled by 'simplifyExp'. +simplifyTupleAssignment loc lvs expr = + case expr of + L lc (TyE _ (Cast b tds@(_:_:_) ex@(L _ (TyE _ (FunCall _ _))))) -> do + (ex' , stmts , cdecl1, vdecl1) <- simplifyExp ex + (lvs', assign, cdecl2, vdecl2) <- + concatMapAndUnzip4MD (auxCast lc b) $ + zip3 tds lvs (fromTuple $ typeOf ex) + return ( stmts `DL.append` (genLoc (Assign (DL.toList lvs') [ex']) + `DL.cons` assign) + , cdecl1 `DL.append` cdecl2 + , vdecl1 `DL.append` vdecl2) + e -> do + (e' , stmts , cdecl1, vdecl1) <- simplifyExp e + (lvs', assign, cdecl2, vdecl2) <- concatMapAndUnzip4MD auxLv lvs + return ( stmts `DL.append` (genLoc (Assign (DL.toList lvs') [e']) + `DL.cons` assign) + , cdecl1 `DL.append` cdecl2 + , vdecl1 `DL.append` vdecl2) + where + auxCast lc b (td, lv, te) = let + tlv = typeOf lv + -- TODO: The sintactic equalify is too weak + -- The typechecker could provide an annotation + in if tlv == te + then auxLv lv + else do + (lv', ldecl) <- newLVar te + (assign, cdecl, vdecl) <- simplifyAssignment loc lv $ + annL tlv $ L lc $ Cast b [td] (toExp lv') + return (DL.singleton lv', assign, cdecl, ldecl `DL.cons` vdecl) + + auxLv lv = if isSimpleLVal lv + then return (DL.singleton lv, DL.empty, DL.empty, DL.empty) + else do + (lv', ldecl) <- newLVar $ typeOf lv + (assign, cdecl, vdecl) <- simplifyAssignment loc lv (toExp lv') + return (DL.singleton lv', assign, cdecl, ldecl `DL.cons` vdecl) + +-- ConstDef -------------------------------------------------------------------- + +simplifyConstDeclaration + :: CaoMonad m + => ConstDecl Var -> Bool + -> m (ConstDecl Var, DL.DList ConstDef) +simplifyConstDeclaration (ConstD (L l n) b ce) _ = + case ce of + ConstInit _ -> do + let Just e = indConst n + (index, cdecl) <- simplifyIndexChoice e + let n' = setIndConst index n + return (ConstD (L l n') b (ConstInit (ind2Expr index)), cdecl) + _ -> return (ConstD (L l n) b None, DL.empty) +simplifyConstDeclaration _ _ = internalError + "simplifyConstDeclaration" "Not expected multiple constant declarations" + +-- VarDeclaration -------------------------------------------------------------- + +{- +Note 8: +The declaration of variables, may include an optional definition, that should +not appear in the simplified form. + +The type of variables must also be simplified so that later usage may benifit +of an already simplified type. + + +In global variables which are containers, the declaration, is like an +assignment, and the order has to be preserved: +- declaration of auxiliary variables +- simplification of values +- declaration of an auxiliary container of the same type, initialized with + the simplified values +- assignment of the auxiliary container to the global container + +For instance, in the declaration: +@ def v3 : vector[3] of register int := { a, b, v1[a] }; @ + +we have this generated code in the body of the init procedure: +@ + def c_t53 : register int; + c_b := 3; + c_t53 := c_v1[c_a]; + def c_t54 : vector[3] of register int := {c_a, c_b, c_t53}; + c_v3 := c_t54; +@ + +Putting the declaration next to the other declarations, we would obtain: +@ + def c_t53 : register int; + def c_t54 : vector[3] of register int := {c_a, c_b, c_t53}; + c_b := 3; + c_t53 := c_v1[c_a]; + c_v3 := c_t54; +@ +This uses variables before their definition, namely 'c_b' and 'c_t53'. +-} +-- Global Variables +-- XXX: b -> type2TypeDecl? +simplifyVarDeclaration + :: CaoMonad m + => VarDecl Var + -> m ( [VarDecl Var] + , [SS] + , [ConstDef] + , [VarDeclaration] + ) +simplifyVarDeclaration (VarD (L l n) d Nothing) = do + (n', cdecl) <- simplifyVar n + return ([VarD (L l n') d Nothing], [], DL.toList cdecl, []) +simplifyVarDeclaration (VarD (L l x) b (Just e)) = do + (x', cdecl1) <- simplifyVar x + (e', ss, cdecl2, vdecl) <- simplifyExpChoice e + let assign = genLoc $ Assign [LVVar (L l x')] [e'] + return ( VarD (L l x') b Nothing : [] + , DL.toList $ ss `DL.snoc` assign + , DL.toList $ cdecl1 `DL.append` cdecl2 + , DL.toList vdecl) +simplifyVarDeclaration (MultiD xs b) = + concatMapAndUnzip4M (\ x -> simplifyVarDeclaration (VarD x b Nothing)) xs + +simplifyVarDeclaration (ContD (L l lx) b es) = do + let ty = varType lx + (ty', cdecl1) <- simplifyType ty + let lx' = L l $ setType ty' lx + (es', ss, cdecl2, vdecl) <- simplifyExps es + tv <- freshVar Local ty' + return ( VarD lx' b Nothing : [] + , DL.toList $ ss + `DL.snoc` + -- Declaration used as assignment [See note 8] + (genLoc $ VDecl $ ContD (genLoc tv) b (DL.toList es')) + `DL.snoc` + (genLoc $ Assign [LVVar lx'] [genLoc $ annTyE ty' $ Var tv ]) + , DL.toList $ cdecl1 `DL.append` cdecl2 + , DL.toList vdecl + ) + +-- Local Variables +simplifyLocalVarDeclaration + :: CaoMonad m + => SrcLoc -> VarDecl Var + -> m (DL.DList (LStmt Var), DL.DList ConstDef, DL.DList VarDeclaration) +simplifyLocalVarDeclaration loc (VarD (L l n) _ Nothing) = do + (n', cdecl) <- simplifyVar n + --- XXX: reTypVar?? + reTypVar n' + return (DL.singleton $ L loc $ VDecl $ VarD (L l n') (type2TyDecl (varType n')) Nothing + , cdecl + , DL.empty) +simplifyLocalVarDeclaration loc (VarD (L l x) _ (Just e)) = do + (x', cdecl) <- simplifyVar x + (e', ss, cdecl2, vdecls) <- simplifyExpChoice e + let assign = genLoc $ Assign [LVVar (L l x')] [e'] + reTypVar x' + return (L loc (VDecl $ VarD (L l x') (type2TyDecl (varType x')) Nothing) + `DL.cons` (ss `DL.snoc` assign) + , cdecl `DL.append` cdecl2 + , vdecls) +simplifyLocalVarDeclaration loc (MultiD xs b) = do + concatMapAndUnzip3MD + (\ x -> simplifyLocalVarDeclaration loc (VarD x b Nothing)) xs +simplifyLocalVarDeclaration loc (ContD (L l x) _ es) = do + (x', cdecl) <- simplifyVar x + (es', ss, cdecl2, vdecls) <- simplifyExps es + reTypVar x' + return ( ss `DL.snoc` + (L loc $ VDecl $ ContD (L l x') (type2TyDecl (varType x')) (DL.toList es')) + , cdecl `DL.append` cdecl2 + , vdecls) + +-- Exp ------------------------------------------------------------------------- + +simplifyExps + :: CaoMonad m + => [TLExpr Var] + -> m ( DL.DList (TLExpr Var) + , DL.DList SS + , DL.DList ConstDef + , DL.DList VarDeclaration + ) +simplifyExps = fold4M + simplifyExpChoice + DL.cons DL.append DL.append DL.append + (DL.empty, DL.empty, DL.empty, DL.empty) + +{- +Note 4: +There are two simplification functions to expressions, with a little different +behavior: (the naming is not the better one) +- simplifyExp: Expressions are only simplified if they are operations on other + operations. This means that variables and constants as operands are left + as they are. +- simplifyExpChoice: Only constants and variables are left as they are; + all other expressions are assigned to a new variable. +-} +simplifyExp + :: CaoMonad m + => TLExpr Var + -> m (TLExpr Var, DL.DList SS, DL.DList ConstDef, DL.DList VarDeclaration) +simplifyExp (L l e) = do + (e', as, cdecl, vdecl) <- simplExp e + return (L l e', as, cdecl, vdecl) + +-- XXX: should the type annotation be modified using simplifyType? +simplExp + :: CaoMonad m + => TExpr Var + -> m (TExpr Var, DL.DList SS, DL.DList ConstDef, DL.DList VarDeclaration) +simplExp (TyE t l@(Lit _)) = do + (t', cdecl) <- simplifyType t + return (TyE t' l, DL.empty, cdecl, DL.empty) +simplExp (TyE _ (Var v)) = do + (v', cdecl) <- simplifyTVar v + return (v', DL.empty, cdecl, DL.empty) +simplExp (TyE t (FunCall f es)) = do +-- XXX: annotation on f? + (t', cdecl) <- simplifyType t + (es', stmts, cdecls, vdecls) <- simplifyExps es + return ( TyE t' (FunCall f (DL.toList es')) + , stmts + , cdecl `DL.append` cdecls + , vdecls) +simplExp (TyE t (StructProj ea n)) = do +-- XXX: annotation on n + (t', cdecl) <- simplifyType t + (ea', stmts, cdecls, vdecls) <- simplifyExpChoice ea + return (TyE t' (StructProj ea' n), stmts, cdecl `DL.append` cdecls, vdecls) +simplExp (TyE t (UnaryOp op e)) = do + (t', cdecl) <- simplifyType t + (e', ss, cdecls, vdecls) <- simplifyExpChoice e + return (TyE t' (UnaryOp op e'), ss, cdecl `DL.append` cdecls, vdecls) +simplExp (TyE t (BinaryOp op l r)) = do + (t', cdecl) <- simplifyType t + ((l',r'), ss, cdecls, vdecls) <- simplifyBinaryExp l r + return (TyE t' (BinaryOp op l' r'), ss, cdecl `DL.append` cdecls, vdecls) +simplExp (TyE ty (Access e p)) = do + (ty', cdecl) <- simplifyType ty + (e', ss1, cdecls1, vdecls1) <- simplifyExpChoice e + (p', ss2, cdecls2, vdecls2) <- simplifyPat p + return (TyE ty' (Access e' p') + , ss1 `DL.append` ss2 + , cdecl `DL.append` cdecls1 `DL.append` cdecls2 + , vdecls1 `DL.append` vdecls2) +-- XXX: update type declaration +simplExp (TyE ty (Cast b td e)) = do + (ty', cdecl) <- simplifyType ty + (e', stmts, cdecls, vdecl) <- simplifyExpChoice e + return ( TyE ty' (Cast b td e') + , stmts + , cdecl `DL.append` cdecls + , vdecl) + +-- Simplifies both operands of a binary expression +simplifyBinaryExp :: CaoMonad m => TLExpr Var -> TLExpr Var + -> m ((TLExpr Var, TLExpr Var) + , DL.DList SS + , DL.DList ConstDef + , DL.DList VarDeclaration) +simplifyBinaryExp l r = do + (l', stmts1, index1, decl1) <- simplifyExpChoice l + (r', stmts2, index2, decl2) <- simplifyExpChoice r + return ((l', r') + , stmts1 `DL.append` stmts2 + , index1 `DL.append` index2 + , decl1 `DL.append` decl2) + +simplifyExpChoice + :: CaoMonad m + => TLExpr Var + -> m (TLExpr Var, DL.DList SS, DL.DList ConstDef, DL.DList VarDeclaration) +-- Literals: there is no need to introduce a new variable +simplifyExpChoice (L loc (TyE t l@(Lit _))) = do + (t', cdecl) <- simplifyType t + return (L loc (TyE t' l), DL.empty, cdecl, DL.empty) +-- Variables: there is no need to introduce a new variable. Type annotations +-- are updated. +simplifyExpChoice (L l (TyE _ (Var v))) = do + (v', cdecl) <- simplifyTVar v + return (L l v', DL.empty, cdecl, DL.empty) +simplifyExpChoice e = do + (e', stmts, cdecl, decl1) <- simplifyExp e + (ve, assign, decl2) <- assignToNewVar e' + return (ve, stmts `DL.snoc` assign, cdecl, decl1 `DL.snoc` decl2) + + +-------------------------------------------------------------------------------- +-- Accesses: just boilerplate + +simplifyPat + :: CaoMonad m => APat Var + -> m (APat Var, DL.DList SS, DL.DList ConstDef, DL.DList VarDeclaration) +simplifyPat (VectP r) = do + (r', ss, cdecls, vdecls) <- simplifyRowPat r + return (VectP r', ss, cdecls, vdecls) +simplifyPat (MatP r c) = do + (r', ss1, cdecls1, vdecls1) <- simplifyRowPat r + (c', ss2, cdecls2, vdecls2) <- simplifyRowPat c + return ( MatP r' c' + , ss1 `DL.append` ss2 + , cdecls1 `DL.append` cdecls2 + , vdecls1 `DL.append` vdecls2) + +simplifyRowPat + :: CaoMonad m + => RowAPat Var + -> m (RowAPat Var, DL.DList SS, DL.DList ConstDef, DL.DList VarDeclaration) +simplifyRowPat (CElem e) = do + (e', ss, cdecls, vdecls) <- simplifyExpChoice e + return (CElem e', ss, cdecls, vdecls) +simplifyRowPat (CRange e1 e2) = do + (e1', ss1, cdecls1, vdecls1) <- simplifyExpChoice e1 + (e2', ss2, cdecls2, vdecls2) <- simplifyExpChoice e2 + return ( CRange e1' e2' + , ss1 `DL.append` ss2 + , cdecls1 `DL.append` cdecls2 + , vdecls1 `DL.append` vdecls2) + +-------------------------------------------------------------------------------- +-- Types + +simplifyVar + :: CaoMonad m + => Var + -> m (Var, DL.DList ConstDef) +simplifyVar v = do + mv <- lookupReTypVar v + case mv of + Nothing -> do + (t, cdecl) <- simplifyType $ varType v + return (setType t v, cdecl) + Just v' -> return (v', DL.empty) + +simplifyTVar + :: CaoMonad m + => Var + -> m (TExpr Var, DL.DList ConstDef) +simplifyTVar v = do + (v', cdecl) <- simplifyVar v + return (annTyE (varType v') $ Var v', cdecl) + + +simplifyType + :: CaoMonad m + => Type Var + -> m (Type Var, DL.DList ConstDef) +simplifyType (Tuple tlst) = do + (tlst', cdecls) <- fold2M' simplifyType (flip DL.snoc) DL.append (DL.empty, DL.empty) tlst + return (Tuple $ DL.toList tlst', cdecls) +simplifyType (Bits s n) = do + (n', cdecls) <- simplifyIndexChoice n + return (Bits s n', cdecls) +simplifyType (Vector n t) = do + (n', cdecls1) <- simplifyIndexChoice n + (t', cdecls2) <- simplifyType t + return (Vector n' t', cdecls1 `DL.append` cdecls2) +simplifyType (Matrix n m t) = do + (n', cdecls1) <- simplifyIndexChoice n + (m', cdecls2) <- simplifyIndexChoice m + (t', cdecls3) <- simplifyType t + return (Matrix n' m' t', cdecls1 `DL.append` cdecls2 `DL.append` cdecls3) + +simplifyType (Mod Nothing Nothing (Pol [Mon (CoefI m) EZero])) = do + (m', cdecls) <- simplifyIndexChoice m + return (Mod Nothing Nothing (Pol [Mon (CoefI m') EZero]), cdecls) + +simplifyType t = return (t, DL.empty) + +simplifyIndex + :: CaoMonad m + => IExpr Var + -> m (IExpr Var, DL.DList ConstDef) +simplifyIndex n@(IInt _) = return (n, DL.empty) +simplifyIndex v@(IInd _) = return (v, DL.empty) +simplifyIndex (IArith op e1 e2) = do + (e1', stmts1) <- simplifyIndexChoice e1 + (e2', stmts2) <- simplifyIndexChoice e2 + return (IArith op e1' e2', stmts1 `DL.append` stmts2) +simplifyIndex (ISym e) = do + (e', stmts) <- simplifyIndexChoice e + return (ISym e', stmts) +simplifyIndex (ISum slst) = simplifySum slst + +-- This function takes a sum of terms and returns a tree of binary additions. +simplifySum + :: CaoMonad m + => [IExpr Var] -- List of terms + -> m (IExpr Var, DL.DList ConstDef) +simplifySum [] = internalError "simplifySum" "Empty sum!" +-- When we have the sum of just one term, we can remove the sum +simplifySum [e] = simplifyIndex e +-- The general base case has two terms +simplifySum [e1, e2] = do + (e1', stmts1) <- simplifyIndexChoice e1 + (e2', stmts2) <- simplifyIndexChoice e2 + return (ISum [e1', e2'], stmts1 `DL.append` stmts2) +simplifySum (e:lest) = do + (e', stmts1) <- simplifyIndexChoice e + (lest', stmts2) <- simplifySum lest + (iv, cdecl) <- newIndexDef lest' + return (ISum [e', iv], stmts1 `DL.append` stmts2 `DL.snoc` cdecl) + +simplifyIndexChoice + :: CaoMonad m + => IExpr Var + -> m (IExpr Var, DL.DList ConstDef) +simplifyIndexChoice n@(IInt _) = return (n, DL.empty) +simplifyIndexChoice v@(IInd _) = return (v, DL.empty) +simplifyIndexChoice e = do + (e', cdecls) <- simplifyIndex e + (iv, cdecl) <- newIndexDef e' + return (iv, cdecls `DL.snoc` cdecl) + +-------------------------------------------------------------------------------- +-- Variable generation + +-- Generates a new local variable with the respective declaration. +newVariable :: CaoMonad m => Type Var -> m (Var, VarDeclaration) +newVariable typ = do + tv <- freshVar Local typ + let decl = genLoc $ VDecl $ VarD (genLoc tv) (type2TyDecl typ) Nothing + return (tv, decl) + +-- New left variable with the respective declaration +newLVar :: CaoMonad m => Type Var -> m (LVal Var, VarDeclaration) +newLVar = liftM (mapFst (LVVar . genLoc)) . newVariable + +-- Given an expression, returns a new variable with the same type, together with +-- its declaration and an assignment of the expression. +-- E.g. +-- Literal 3 of type int +-- assignToNewVar 3 -> (t0, def t0 : int, t0 := 3) +-- Sum of two integers +-- assignToNewVar (3+i) -> (t0, def t0: int, t0 := 3 + i) +-- Here, SS introduces an assignment +assignToNewVar :: CaoMonad m => TLExpr Var -> m (TLExpr Var, SS, VarDeclaration) +assignToNewVar e = do + let ty = typeOf e + (tv, decl) <- newVariable ty + let assign = genLoc $ Assign [LVVar (genLoc tv)] [e] + return (genLoc $ TyE ty $ Var tv, assign, decl) + +{- +Note 7: +The first version of this functions was introducing ordinary variables to +simplify type expression. Altough this would generate valid C code (because +the static library does not know anything about index constants), this breaks +the correctness of the intermediate CAO code. Moreover, the optimization stage +loses this important meta-information. + +To maintain the correctness of the intermediate CAO program, a new local index +constant has to be declared and defined. Since, by definition, constants cannot +be assigned, their value has to be set during declaration (declaration and +definition are simultaneous), and can only depend on other constants. +-} + +newIndexDef :: CaoMonad m => IExpr Var -> m (IExpr Var, ConstDef) +newIndexDef e = do + let ty = typeOf e + tv <- freshIndex Local ty + let decl = genLoc $ CDecl $ + ConstD (genLoc tv) (type2TyDecl ty) (ConstInit (ind2Expr e)) + return (IInd tv, decl) + +-------------------------------------------------------------------------------- +-- Auxiliary functions + +toExp :: LVal Var -> TLExpr Var +toExp (LVVar (L l v)) = L l $ annTyE (varType v) $ Var v +toExp _ = error ".\ + \: undefined case" + +moduleName :: String +moduleName = "" + +internalError :: String -> String -> a +internalError funcName msg = error $ + moduleName ++ ".<" ++ funcName ++ ">: " ++ msg diff --git a/src/Language/CAO/Transformation/Target.hs b/src/Language/CAO/Transformation/Target.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Transformation/Target.hs @@ -0,0 +1,721 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-| +Module : $Header$ +Description : CAO target. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +The first phase of the translation mostly handles constant literals according +to the specification. This introduces additional variables when the +specification is not 'inlined' or 'mixed'. When 'inlined' is required but it is +not possible to accomplish (variables are used) the translation fails. The +following cases are considered: + +* Constants as operands to CAO operations. + +* Constants in function calls and return statements. + +* Indices in accesses to vectors, matrices or bit strings. + +* Indices in shift, rotate and exponentiation operations. + +* When inlining is not possible, the initialization of vectors or matrices is +expanded to a position by position assignment. This requires the introduction +of additional indices to access the positions of the container. + +Moreover, this phase also performs the following tasks: + +* When not using sequence expansion, @seq@ statements are translated to an +equivalent @while@ loop. + +* Creates a global init procedure if one does not already exist. + +* Introduces the initialization of additional global constants in the init +procedure. + +-} + +module Language.CAO.Transformation.Target ( + targetCaoAST + ) where + +import Control.Applicative ( (<$>) ) +import Control.Monad + +import Language.CAO.Common.Error +import Language.CAO.Common.Fresh +import Language.CAO.Common.Literal +import Language.CAO.Common.Monad +import Language.CAO.Common.Polynomial +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.State +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Language.CAO.Index + +import Language.CAO.Platform.Naming +import Language.CAO.Platform.Query +import Language.CAO.Platform.Specification + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils(isAscSeq, isLit, type2TyDecl, typeOf) + +import Language.CAO.Translation.Names() + +import Language.CAO.Type +import Language.CAO.Type.Utils(innerType) + +-------------------------------------------------------------------------------- +-- CaoAST + +targetCaoAST + :: CaoMonad m + => TranslationSpec -> Prog Var + -> m (Prog Var) +targetCaoAST tspec (Prog defs ip) = withTargetST $ do + defs' <- concatMapM (targetDefinition tspec) defs + ip' <- mapMaybeM (targetFunc tspec) ip + cs <- allConsts + cs' <- mapM aux cs + let cdecls = map (genLoc . VarDef . varDecl . fst) cs' + ip'' = updateInitDecls tspec ip' cs' + return $ Prog (cdecls ++ defs') (Just ip'') + + where + aux :: CaoMonad m => (Var, Literal Var) -> m (Var, Literal Var) + aux (v, l) = do + v' <- constIndVar tspec v + return (v', l) + +{- +Note 1: +Constants have to come first, before indexes. Why? +[EndConsts] +-} +updateInitDecls + :: TranslationSpec -> Maybe (Fun Var) -> [(Var, Literal Var)] + -> Fun Var +updateInitDecls tspec ip vars = case ip of + Just f -> + f { funBody = gConsts ++ (genLoc $ Nop EndConsts) : (funBody f) } + Nothing -> let + fName = globalInit (initProcName $ globalTransSpec tspec) [] + in Fun (genLoc fName) [] [] $ gConsts ++ + genLoc (Nop EndConsts) : + genLoc (Nop EndIndex) : + genLoc (Nop EndAux) : [] + where + gConsts = map initGlobalConsts vars + initGlobalConsts (v, l) = genLoc $ Assign + [LVVar (genLoc v)] [genLoc $ annTyE (varType v) $ Lit l] + +-------------------------------------------------------------------------------- +-- Definition + +targetDefinition + :: CaoMonad m + => TranslationSpec -> LDef Var + -> m [LDef Var] +targetDefinition tspec (L l d) = liftM (map (L l)) $ targetDef tspec d + +targetDef + :: CaoMonad m + => TranslationSpec -> Def Var + -> m [Def Var] +targetDef tspec (VarDef vd) = + -- In global variable declarations, the 'simplify' stage ensures that the declaration with + -- initialization of container variables is always removed and replaced with the + -- VarD _ Nothing case. Thus, the second return value of 'targetVarDeclarations' can + -- be safely ignored. + liftM (map VarDef . fst) $ targetVarDeclaration tspec vd +targetDef tspec (FunDef f) = + liftM (singleton . FunDef) $ targetFunc tspec f +targetDef _ d@(TyDef _) = + return [d] +targetDef tspec (ConstDef cd) = + liftM (map ConstDef . fst) $ targetConstDeclaration tspec cd + +-------------------------------------------------------------------------------- +-- Func + +{- +Note 2: +The state of the module stores ... +-} +targetFunc + :: CaoMonad m + => TranslationSpec -> Fun Var + -> m (Fun Var) +targetFunc tspec (Fun (L loc fn) args rtype body) = do + resetTargetST -- [See Note 2] + args' <- mapM aux args + fn' <- constIndVar tspec fn + body' <- targetStatements tspec body + tmpvs <- getTmpVars + let vars = map (genLoc . VDecl . varDecl) tmpvs + body'' = vars ++ genLoc (Nop EndConsts) : body' + return (Fun (L loc fn') args' rtype body'') + + where + aux (Arg (L l v) t) = do + v' <- constIndVar tspec v + return (Arg (L l v') t) + aux (ArgConst (L l v) t e) = do + v' <- constIndVar tspec v + return (ArgConst (L l v') t e) + +-------------------------------------------------------------------------------- +-- Statement + +targetStatements + :: CaoMonad m + => TranslationSpec -> [LStmt Var] + -> m [LStmt Var] +targetStatements tspec = + concatMapM (uncurry (targetStmt tspec) . split getLoc unLoc) + +targetStmt + :: CaoMonad m + => TranslationSpec -> SrcLoc -> Stmt Var + -> m [LStmt Var] +targetStmt tspec l (VDecl vd) = do + (vd', stmts) <- targetVarDeclaration tspec vd + return (map (L l . VDecl) vd' ++ stmts) +targetStmt tspec l (CDecl cd) = do + (cd', stmts) <- targetConstDeclaration tspec cd + return (map (L l . CDecl) cd' ++ stmts) + +targetStmt tspec l (Assign lv' e') = + case (lv', e') of + (lv:[], e:[]) -> targetAssignment tspec l lv e + (_:_:_, e:[]) -> targetTupleAssignment tspec lv' e + _ -> internalError + "targetStmt" "Unexpected case in assignment" + +targetStmt tspec l (FCallS fid exps) = do + (exps', stmts) <- targetExps tspec "" exps + fid' <- constIndVar tspec fid + return (stmts ++ L l (FCallS fid' exps') : []) +targetStmt tspec l (Ret exps) = do + -- Initialy, this was leaving the expressions unchanged. However, this may cause inconsistency + -- when returning values, with calls to '_init' in platforms which use constants as global + -- variables. + (exps', stmts) <- targetExps tspec "" exps + return (stmts ++ L l (Ret exps') : []) +targetStmt tspec l (Ite i t e) = do + -- The condition of an 'if' statement is always a variable + t' <- targetStatements tspec t + e' <- mapMaybeM (targetStatements tspec) e + return $ L l (Ite i t' e') : [] + +targetStmt tspec l (While cond wstms) = do + -- The condition of a 'while' is a variable or the constant 'true'. + -- This will be treated as a special case because referenced constants can + -- cause problems in the translation. + wstms' <- targetStatements tspec wstms + return $ L l (While cond wstms') : [] + +-- The sequence statement is transformed in an equivalent while loop. +-- Pre-condition: the bounds and increment values can only be variables or +-- literals +targetStmt tspec l (Seq i@(SeqIter v start end b _) sstms) = do + let -- c = defaultOperands $ globalTransSpec tspec + -- The bound variable is only implicitly declared in the sequence + -- Now, we have to declare it explicitly. + vd = genLoc $ VDecl $ varDecl v + -- Initialization with starting value + init_v = genLoc $ Assign (LVVar (genLoc v) : []) (annL RInt start : []) + -- Condition: sequence iteration always uses register integers. + -- TODO: what about constants??? They must be processed by target + cond = genLoc $ annTyE Bool $ BinaryOp (CmpOp RInt cmpOp) + (genLoc $ annTyE RInt (Var v)) + (annL RInt end) + cmpOp = if isAscSeq i then Leq else Geq + -- Increment value + b' = maybe (rintLit 1) (annL RInt) b + -- Incrementing the bound variable. The operations are always + -- on register integers. + step = genLoc $ Assign + [LVVar $ genLoc v] + [genLoc $ annTyE RInt $ BinaryOp (ArithOp Plus) + (genLoc $ annTyE RInt $ Var v) + b'] + sstms' <- targetStatements tspec sstms + -- NEW seq translation + cond_v <- freshTmpVar Bool + storeTmpVar cond_v + -- Condition + let condStmt = genLoc $ Assign [LVVar $ genLoc cond_v] [cond] + return $ vd + : init_v + : condStmt + : L l (While (genLoc $ annTyE Bool $ Var cond_v) + (sstms' ++ step : condStmt : [])) + : [] + +targetStmt _ l (Nop a) = return [L l $ Nop a] + + +-------------------------------------------------------------------------------- +{- +Note: + +The first idea was to use the kind of operand of '_init' (fInitCall) +However, this is not correct because '_init' must ALWAYS get a literal +constant. Therefore, the correct way is to use the default value of the +platform. If this is 'inline', the literal constants are left and +the assignment will be replaced by an '_init' in the following steps. +If this is 'vars_*' instead, the constant is replaced by a variable +and an '_assign' operation is introduced in the following steps. + +-} +-- Precondition: |lv| = 1 |e| = 1 +targetAssignment + :: CaoMonad m + => TranslationSpec -> SrcLoc -> LVal Var -> TLExpr Var + -> m [LStmt Var] + +-- [See Note ?] +targetAssignment tspec l lv@(LVVar _) le@(unLoc -> unTyp -> Lit _) = do + (lv', _) <- targetLValue tspec lv + (e', stmts) <- targetExpChoiceGeneral tspec "" le + return (stmts ++ [L l $ Assign [lv'] [e']]) +targetAssignment tspec l lv@(LVVar _) e = do + (lv', _) <- targetLValue tspec lv + (e', stmts) <- targetExp tspec e + return (stmts ++ [L l $ Assign [lv'] [e']]) +targetAssignment tspec l lv le@(unLoc -> TyE _ (Lit _)) = do + -- Unlike the previous case of assignment of a literal constant, here + -- the operation will be always an assignment. Moreover, we have to + -- distinguish the left value case and the assignment case. + (lv', stmts1) <- targetLValue tspec lv + (e',stmts2) <- targetExpChoice tspec code_assign le + return (stmts1 ++ stmts2 ++ [L l $ Assign [lv'] [e']]) +targetAssignment tspec l lv (L loc (TyE _ (Var v))) = do + (lv', stmts) <- targetLValue tspec lv + v' <- constIndTVar tspec v + return (stmts ++ [L l $ Assign [lv'] [L loc v']]) +targetAssignment _ _ _ _ = + internalError "targetAssignment" "not expected case" + +-- Precondition: |lvs| > 1 |e| = 1 +-- Precondition: it is assumed that 'lvs' only contains variables +targetTupleAssignment + :: CaoMonad m + => TranslationSpec -> [LVal Var] -> TLExpr Var + -> m [LStmt Var] +targetTupleAssignment tspec lvs e = do + (e', stmts) <- targetExp tspec e + -- Assuming that we have only 'LVVar' in the list + lvs' <- mapM (liftM fst . targetLValue tspec) lvs + return $ stmts ++ [genLoc $ Assign lvs' [e']] + +-------------------------------------------------------------------------------- + +targetLValue + :: CaoMonad m + => TranslationSpec -> LVal Var + -> m (LVal Var, [LStmt Var]) +targetLValue tspec (LVVar (L l v)) = do + v' <- constIndVar tspec v + return (LVVar (L l v'), []) +targetLValue tspec (LVStruct lv fld) = do + (lv', stmts) <- targetLValue tspec lv + return (LVStruct lv' fld, stmts) +targetLValue tspec (LVCont ty lv p) = do + ty' <- constIndType tspec ty + (lv', stmts1) <- targetLValue tspec lv + return (LVCont ty' lv' p, stmts1) + +-------------------------------------------------------------------------------- + +targetConstDeclaration + :: CaoMonad m + => TranslationSpec -> ConstDecl Var + -> m ([ConstDecl Var], [LStmt Var]) +targetConstDeclaration tspec (ConstD (L l c) d e) = do + (e'', stmts) <- case e of + ConstInit e' -> liftM (mapFst (ConstInit . unTypL)) $ + targetExp tspec (annL (typeOf c) e') + _ -> return (e, []) + return ([ConstD (L l c) d e''], stmts) +targetConstDeclaration _ _ = internalError + " TranslationSpec -> VarDecl Var + -> m ( [VarDecl Var] + , [LStmt Var]) +targetVarDeclaration tspec (VarD (L l v) d Nothing) = do + t <- constIndType tspec $ varType v + return ([VarD (L l (setType t v)) d Nothing], []) +targetVarDeclaration tspec c@(ContD (L l v) d ex) = do + ci <- operandKind tspec (varType v) code_init -- TODO: Verify this!! Before this was indexKind + t' <- constIndType tspec (varType v) + let v' = setType t' v + case ci of + GlobalV -> do + ini <- zipWithSeqM auxGlobal ex + return ([VarD (L l v') d Nothing], ini) + LocalV -> do + ini <- zipWithSeqM auxLocal ex + return ([VarD (L l v') d Nothing], ini) + Inlined -> if all (isLit . unTyp . unLoc) ex + then return ([], [genLoc $ VDecl c]) + else caoError l $ NotSupportedVar (operName code_init) (varType v) + Mixed -> return ([], [genLoc $ VDecl c]) -- This maintains the order since there may be dependencies + + where + + -- TODO: Replace these types + auxGlobal n e@(unLoc -> unTyp -> Lit _) = do + ind <- arrayIndex (L l v) n + e' <- introGlobalLitVar tspec e + return $ genLoc $ Assign [ind] [e'] + auxGlobal n e@(unLoc -> unTyp -> Var _) = do + ind <- arrayIndex (L l v) n + return $ genLoc $ Assign [ind] [e] + auxGlobal _ _ = internalError + "targetVarDeclaration" "Not expected case" + + -- This does not really require the introduction of additional variables. + -- The assignment will always result in the use a call to an _init function + -- during the translation + auxLocal n e = do + ind <- arrayIndex (L l v) n + return $ genLoc $ Assign [ind] [e] + + +targetVarDeclaration _ _ = internalError + "targetVarDeclaration" "Not expected case" + +arrayIndex + :: CaoMonad m + => Located Var -> Integer + -> m (LVal Var) +arrayIndex v n = case typ of + Vector _ _ -> do + let e = rintLit n + return $ LVCont (head $ innerType typ) (LVVar v) $ VectP $ CElem e + Matrix _ (IInt m) _ -> do + let (i, j) = divMod n m + ei = rintLit i + ej = rintLit j + return $ LVCont (head $ innerType typ) (LVVar v) $ MatP (CElem ei) (CElem ej) + Matrix _ _ _ -> internalError "arrayIndex" "<>: not literal" + _ -> internalError + "arrayIndex" "Unexpected container type" + where + typ = varType (unLoc v) + +-------------------------------------------------------------------------------- +-- Expression + +targetExps + :: CaoMonad m + => TranslationSpec -> String + -> [TLExpr Var] -> m ( [TLExpr Var] + , [LStmt Var] + ) +targetExps tspec nm = concatMap2M (targetExpChoiceGeneral tspec nm) + +targetExp + :: CaoMonad m + => TranslationSpec -> TLExpr Var + -> m (TLExpr Var, [LStmt Var]) +targetExp tspec (L l e) = do + (e', as) <- tagExp tspec e + return (L l e', as) + +tagExp + :: CaoMonad m + => TranslationSpec -> TExpr Var + -> m (TExpr Var, [LStmt Var]) +tagExp tspec (TyE typ l@(Lit _)) = do + typ' <- constIndType tspec typ + return (annTyE typ' l, []) +tagExp tspec (TyE _ (Var v)) = do + v' <- constIndTVar tspec v + return (v', []) +tagExp tspec (TyE _ (FunCall (L l f) es)) = do + f' <- constIndVar tspec f + (es', stmts) <- targetExps tspec "" es + return (annTyE (typeOf f') $ FunCall (L l f') es', stmts) +tagExp tspec (TyE t e@(StructProj ea n)) = do + (ea', stmts) <- targetExpChoice tspec (codeOf e) ea + return (TyE t $ StructProj ea' n, stmts) -- TODO: need to process t +-- TODO: replace codeOf with a more specific function +tagExp tspec (TyE t eu@(UnaryOp op e)) = do + (e', ss) <- targetExpChoice tspec (codeOf eu) e + return (TyE t $ UnaryOp op e', ss) +tagExp tspec (TyE t e@(BinaryOp (BitsSROp op) l r)) = do + (l', ss) <- targetExpChoice tspec (codeOf e) l + return (TyE t $ BinaryOp (BitsSROp op) l' r, ss) +tagExp tspec (TyE t e@(BinaryOp op l r)) = do + ((l', r'), ss) <- targetBinaryExp tspec (codeOf e) l r + return (TyE t (BinaryOp op l' r'), ss) +tagExp tspec (TyE ty ae@(Access e p)) = do + (e', ss1) <- targetExpChoice tspec (codeOf ae) e + ty' <- constIndType tspec ty + return (annTyE ty' (Access e' p), ss1) +tagExp tspec (TyE ty (Cast b td (L l (unTyp -> (Var v))))) = do + -- The first version used the kind of operand of operation 'fCastName'. + -- However, this operation must always receive a variable, since all + -- literal constants casts were already evaluated statically. Using + -- the kind of operand causes problems if the user specifies 'inlined' + -- which will cause the compilation to fail because a constant was + -- expected + ty' <- constIndType tspec ty + tv <- constIndTVar tspec v + return (annTyE ty' $ Cast b td (L l tv), []) +tagExp _ _ = internalError "tagExp" "Not expected expression" + + +targetBinaryExp + :: CaoMonad m + => TranslationSpec -> OpCode -> TLExpr Var -> TLExpr Var + -> m ((TLExpr Var, TLExpr Var), [LStmt Var]) +targetBinaryExp tspec op l r = do + c <- operandKind tspec (typeOf l) op + let opn = operName op + (l', stmts1) <- targetExpChoice' tspec c opn l + (r', stmts2) <- targetExpChoice' tspec c opn r + return ((l', r'), stmts1 ++ stmts2) + +-------------------------------------------------------------------------------- +-- Exp choice + +{- +Note: +It is here that happens all the magic! +-} + +targetExpChoiceGeneral + :: CaoMonad m + => TranslationSpec -> OpName -> TLExpr Var + -> m (TLExpr Var, [LStmt Var]) +targetExpChoiceGeneral tspec op e = do + c <- operandKindGeneral tspec (typeOf e) + targetExpChoice' tspec c op e + +targetExpChoice + :: CaoMonad m + => TranslationSpec -> OpCode -> TLExpr Var + -> m (TLExpr Var, [LStmt Var]) +targetExpChoice tspec op e = do + c <- operandKind tspec (typeOf e) op + targetExpChoice' tspec c (operName op) e + +targetExpChoice' + :: CaoMonad m + => TranslationSpec -> Consts -> OpName -> TLExpr Var + -> m (TLExpr Var, [LStmt Var]) +targetExpChoice' tspec c _ e@(L loc (TyE t l@(Lit _))) = case c of + GlobalV -> liftM (split id (const [])) $ introGlobalLitVar tspec e + LocalV -> introLocalLitVar tspec e + _ -> do + t' <- constIndType tspec t + return (L loc (annTyE t' l), []) +targetExpChoice' tspec c op (L l (unTyp -> (Var v))) = case c of + Inlined -> caoError l $ NotSupportedVar op $ varType v + _ -> do + v' <- constIndTVar tspec v + return (L l v', []) +targetExpChoice' _ _ _ _ = internalError + "targetExpChoice'" "Not expected case" + +{- +Gets a literal and returns: +* A new variable with the same type +* The declarations of the variable +* The assignment of the literal to the new variable (definition) +-} +introLocalLitVar + :: CaoMonad m + => TranslationSpec -> TLExpr Var + -> m (TLExpr Var, [LStmt Var]) +introLocalLitVar tspec (L loc (TyE typ l@(Lit _))) = do + typ' <- constIndType tspec typ + tv <- freshVar Local typ' -- TODO: consider using tmpvar + let decl = genLoc $ VDecl $ varDecl tv + assign = genLoc $ Assign [LVVar (genLoc tv)] [L loc (annTyE typ' l)] + return (genLoc $ annTyE typ' $ Var tv, decl : assign : []) +introLocalLitVar _ _ = internalError + "introLocalLitVar" "Getting something that is not a literal" + +{- +The function returns a variable which denotes the constant value. +HOW??? getConst? +-} +introGlobalLitVar + :: CaoMonad m + => TranslationSpec -> TLExpr Var + -> m (TLExpr Var) +introGlobalLitVar tspec (L loc (TyE t (Lit l))) = do + v <- getConst t l + t' <- constIndType tspec t + return (L loc $ annTyE t' $ Var (setType t' v)) +introGlobalLitVar _ _ = internalError "introGlobalLitVar" "not expected case" + + +-------------------------------------------------------------------------------- +-- Constanst in type declarations + +constIndVar :: CaoMonad m => TranslationSpec -> Var -> m Var +constIndVar tspec v = do + t <- constIndType tspec $ varType v + return (setType t v) + +constIndTVar :: CaoMonad m => TranslationSpec -> Var -> m (TExpr Var) +constIndTVar tspec v = do + t <- constIndType tspec $ varType v + return $ annTyE t $ Var (setType t v) + +-- TODO: what if an inner type requires it? +constIndType + :: CaoMonad m + => TranslationSpec -> Type Var + -> m (Type Var) +constIndType _ Bullet = return Bullet +constIndType tspec (Tuple tlst) = do + t <- mapM (constIndType tspec) tlst + return (Tuple t) +constIndType tspec (FuncSig ta tr c) = do + ta' <- mapM (constIndType tspec) ta + tr' <- constIndType tspec tr + return (FuncSig ta' tr' c) +constIndType tspec typ = constIndType' tspec GlobalV typ {-do + c <- operandKind tspec typ fDeclCall + case c of + GlobalV -> constIndType' c typ + LocalV -> error ": Not supported local vars" + _ -> return typ-} + +constIndType' :: CaoMonad m => TranslationSpec -> Consts -> Type Var -> m (Type Var) +constIndType' tspec c typ = case typ of + Vector n t -> do + t' <- indType tspec c t + return (Vector n t') + Matrix n m t -> do + t' <- indType tspec c t + return (Matrix n m t') + Struct s tlst -> do + fldtys' <- mapM (\(v,sf) -> (v,) <$> indType tspec c sf) tlst + let tct = Struct newvar tlst' + newvar = setType tct s + tlst' = map (\(v, ty) -> (setType (SField newvar ty) v, ty)) fldtys' + return tct + Mod Nothing Nothing (Pol [Mon (CoefI _) EZero]) -> indType tspec c typ + Mod (Just (Mod Nothing Nothing (Pol [Mon (CoefI _) EZero]))) (Just _) p@(Pol _) -> polDegree p >> indType tspec c typ + TySyn v t -> do + t' <- indType tspec c t + let tct = TySyn newvar t' + newvar = setType tct v + return tct + _ -> return typ + +polDegree :: CaoMonad m => Pol id -> m () +polDegree (Pol ((Mon _ (MExpI _ e)):_)) = getConst Int (ILit e) >> return () +polDegree _ = internalError "polDegree" "Not expected case" + +indType + :: CaoMonad m + => TranslationSpec -> Consts -> Type Var + -> m (Type Var) +indType _ _ Bullet = return Bullet +indType _ _ Int = return Int +indType _ _ RInt = return RInt +indType _ _ Bool = return Bool +indType _ c (Bits s sz) = do + sz' <- targetIndChoice c sz + return (Bits s sz') +indType tspec _ m'@(Mod Nothing Nothing (Pol [Mon (CoefI m) EZero])) = case m of + IInt n -> do + if existsModWithBase tspec n then return m' else do + v <- getConst Int (ILit n) + return (Mod Nothing Nothing (Pol [Mon (CoefI (IInd v)) EZero])) + _ -> return m' +indType tspec c (Mod (Just im@(Mod Nothing Nothing (Pol [Mon (CoefI _) EZero]))) (Just i) p@(Pol pol)) = do + polDegree p + im' <- indType tspec c im + pol' <- mapM aux pol + return (Mod (Just im') (Just i) (Pol pol')) + where + aux m@(Mon co e) = case co of + CoefI (IInt n) -> do + v <- getConst Int (ILit n) + return (Mon (CoefI (IInd v)) e) + CoefI _ -> return m + CoefP _ -> error ": Polynomial extension" +indType _ _ (Mod _ _ _) = error "<>: Mod" +indType tspec c (Vector n t) = do + n' <- targetIndChoice c n + t' <- indType tspec c t + return (Vector n' t') +indType tspec c (Matrix n m t) = do + n' <- targetIndChoice c n + m' <- targetIndChoice c m + t' <- indType tspec c t + return (Matrix n' m' t') +indType _ _ (SField _ _) = error "<>: SField" +indType tspec c (TySyn v t) = do + t' <- indType tspec c t + let tct = TySyn newvar t' + newvar = setType tct v + return tct +indType tspec c (Struct s flds) = do + fldtys' <- zip (map fst flds) <$> mapM indFld flds + let tct = Struct newvar flds' + newvar = setType tct s + flds' = map (\(v, ty) -> (setType (SField newvar ty) v, ty)) fldtys' + return tct + where indFld (_, sf) = indType tspec c sf +indType tspec c (Tuple l) = liftM Tuple $ mapM (indType tspec c) l +indType _ _ _ = error "<>: other type" + +{- +Precondition: It expected that simplification has left only constants and +index variables in index expressions. +-} +targetIndChoice + :: CaoMonad m + => Consts -> IExpr Var + -> m (IExpr Var) +targetIndChoice c e@(IInt n) = case c of + GlobalV -> do + v <- getConst RInt (ILit n) + return (IInd v) + LocalV -> internalError "targetIndChoice" "Not supported local vars" + Inlined -> return e + Mixed -> return e +targetIndChoice c e@(IInd _) = case c of + Inlined -> caoError defSrcLoc $ mkUnknownErr $ + ".\ + \: not expected case" + _ -> return e +targetIndChoice _ _ = internalError + "targetIndChoice" "not expected composed expression" + +-------------------------------------------------------------------------------- +-- Auxiliary + +varDecl :: Var -> VarDecl Var +varDecl v = VarD (genLoc v) (type2TyDecl (varType v)) Nothing + +moduleName :: String +moduleName = "" + +internalError :: String -> String -> a +internalError funcName msg = error $ + moduleName ++ ".<" ++ funcName ++ ">: " ++ msg + +rintLit :: Integer -> TLExpr Var +rintLit = genLoc . annTyE RInt . Lit . ILit diff --git a/src/Language/CAO/Translation/C.hs b/src/Language/CAO/Translation/C.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Translation/C.hs @@ -0,0 +1,974 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : $Header$ +Description : CAO to C translation. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +CAO to C translation. + +Flexible contexts may be dropped. +-} + +module Language.CAO.Translation.C ( + cao2c + ) where + +import Control.Monad +import Data.List (intercalate, genericLength, partition) +import qualified Data.Set as Set +import Language.C.Syntax +import Language.C +import Text.PrettyPrint + +import Language.CAO.Common.Error +import Language.CAO.Common.Fresh +import Language.CAO.Common.Literal +import Language.CAO.Common.Monad +import Language.CAO.Common.Outputable +import Language.CAO.Common.Polynomial +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.State +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Language.CAO.Index + +import Language.CAO.Platform.Naming +import Language.CAO.Platform.Query +import Language.CAO.Platform.Specification + +import Language.CAO.Semantics.Bits + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils +import Language.CAO.Syntax.Tidy + +import Language.CAO.Translation.Names +import Language.CAO.Translation.C.Wrappers + +import Language.CAO.Type +import Language.CAO.Type.Utils + +{- +- The representation of Boolean must be compatible with C integers, or, if a +pointer is used, this must be castable to integers. +-} +-------------------------------------------------------------------------------- +------------------------------------- Prog ------------------------------------- +-- Top level translation function +cao2c + :: CaoMonad m + => TranslationSpec -> Prog Var + -> m String +cao2c tspec ast = withCST $ do + cprog <- mapProg tspec $ tidyCaoAST ast + fnm <- getFileName + let header = moduleHeader fnm tspec + return $ header ++ render (pretty cprog) + + +-- Precondition: +-- The list of definitions is not empty. +mapProg + :: CaoMonad m + => TranslationSpec -> Prog Var + -> m CTranslUnit' +mapProg tspec (Prog defs (Just ip)) = do + let gvars = filter isGlobalVar $ Set.toList $ bvs defs + defs' <- concatMapM (mapDefinition tspec) defs + ip' <- initProc tspec ip gvars + disp <- disposeProc tspec gvars + return $ CTranslUnit' (defs' ++ ip' : disp : []) undefNode +mapProg _ _ = internalError "mapProg" "Init procedure not found" + +-------------------------------------------------------------------------------- +-- Init precedure +initProc + :: CaoMonad m + => TranslationSpec -> Fun Var -> [Var] + -> m CExtDecl' +initProc tspec f = liftM (CED . CFDefExt) . mapInit tspec f + +-- Init procedure generation: +-- Gets the body of the init procedure and the list of global variables +mapInit + :: CaoMonad m + => TranslationSpec -> Fun Var -> [Var] + -> m CFunDef +mapInit tspec (Fun fn _ _ body) gvs = do + resetCST + let (gc, gvs') = partition indVar gvs + gvs'' = map varDecl gvs' + body''' = mergeDecls gc gvs'' body + body' <- mapStatements tspec body''' + disp <- disposeAlloc tspec + let body'' = body' ++ disp + return $ cProc tspec (getSymbol $ unLoc fn) body'' + where + varDecl v = genLoc $ VDecl $ VarD (genLoc v) undefined Nothing + + mergeDecls gc vs b = insertConstDecls gc (insertVarDecls vs b) + + -- XXX: This is not very efficient... + insertConstDecls [] b = b + insertConstDecls (v:vs) b = insertConstDecls vs (insertConst v b) + + insertConst v (L l (Nop EndConsts):slst) = varDecl v : L l (Nop EndConsts) : slst + insertConst v (s@(L _ (Assign [LVVar (L _ a)] [L _ (TyE _ (FunCall _ _))])):slst) + | v == a = varDecl v : s : slst + insertConst v (s:slst) = s : insertConst v slst + insertConst _ _ = internalError "insertConst" "Not expected case" + + insertVarDecls vs [] = vs + insertVarDecls vs (L l (Nop EndAux): slst) = (L l $ Nop EndAux) : vs ++ slst + insertVarDecls vs (s:slst) = s : insertVarDecls vs slst + +-------------------------------------------------------------------------------- +-- Dispose procedure + +disposeProc + :: CaoMonad m + => TranslationSpec -> [Var] + -> m CExtDecl' +disposeProc tspec = + liftM (CED . CFDefExt . cProc tspec (disposeName tspec)) + . disposeVars tspec + +-- Gets the allocated variables and disposes them +disposeAlloc + :: CaoMonad m + => TranslationSpec + -> m [CBlockItem] +disposeAlloc tspec = getAllocVars >>= disposeVars tspec + +disposeAllAlloc + :: CaoMonad m + => TranslationSpec + -> m [CBlockItem] +disposeAllAlloc tspec = getAllAllocVars >>= disposeVars tspec + +disposeVars + :: CaoMonad m + => TranslationSpec -> [Var] + -> m [CBlockItem] +disposeVars tspec = concatMapM $ \ v -> let + typ = typeOf v + in autoOrAlloc tspec typ + (return []) + (do tname <- typeName tspec typ + let fcall = fCall tspec tname code_dispose + return $ cFuncCallStmt fcall (cVar' v : []) : [] + ) + +-------------------------------------------------------------------------------- +-- Definitions + +mapDefinition + :: CaoMonad m + => TranslationSpec -> LDef Var + -> m [CExtDecl'] +mapDefinition tspec d = case unLoc d of + VarDef vd -> liftM (singleton . declOrMacro) $ mapVarDefinition tspec vd + ConstDef cd -> liftM (singleton . declOrMacro) $ mapConstDefinition tspec cd + FunDef fd -> liftM (singleton . CED . CFDefExt) $ mapFunc tspec fd + TyDef td -> mapTypeDef tspec td + +-------------------------------------------------------------------------------- +-- Constants + +mapConstDefinition + :: CaoMonad m + => TranslationSpec -> ConstDecl Var + -> m (Either CDecl CBlockItem) +mapConstDefinition tspec (ConstD (unLoc -> n) _ _) = mapVar tspec n +mapConstDefinition _ _ = internalError "" "Not expected case." + +-------------------------------------------------------------------------------- +-- Variables + +mapVarDefinition + :: CaoMonad m + => TranslationSpec -> VarDecl Var + -> m (Either CDecl CBlockItem) +mapVarDefinition tspec (VarD (unLoc -> n) _ Nothing) = mapVar tspec n +mapVarDefinition _ _ = + internalError "mapVarDefinition" "Not expected case." + +-- Preconditions: +-- 1 - Simplification removes all initializations and multiple declarations +-- in the global setting, so they are not expected as arguments of this +-- function. +-- 2 - Variable/constant initialization is provided elsewhere, namely in the +-- 'init' function. +mapVar :: CaoMonad m + => TranslationSpec -> Var + -> m (Either CDecl CBlockItem) +mapVar tspec n = + varOrMacroDecl tspec tn auxVar auxMacro + where + tn = varType n + auxVar = liftM (Left . cVarDecl (getSymbol n) . tPrefix tspec) $ typeName tspec tn + auxMacro = valOrRefOpMacroReturn tspec tn code_decl + (caoError defSrcLoc $ mkUnknownErr $ ".:\ + \ Not expecting macro variable declaration returning a value") + (do typ <- typeName tspec tn + (p, _) <- extractParams' tspec tn -- TODO: Verify what happens with global mod variables + let fdcall = fCall tspec typ code_decl + return $ Right $ cFuncCallStmt fdcall (cVar' n : p)) + +-------------------------------------------------------------------------------- +----------------------------------------- Func --------------------------------- + +mapFunc + :: CaoMonad m + => TranslationSpec -> Fun Var + -> m CFunDef +mapFunc tspec (Fun (L _ fn) args _ body) = do + let FuncSig _ rtype _ = varType fn + rtype' = fromTuple rtype + resetCST + body' <- mapBlocks tspec body + + tmpvs <- getTmpVars + decls <- concatMapM (mapVarDecl tspec . varDecl) tmpvs + + args' <- mapM (mapArg tspec) args + (cr, rargs) <- mapReturnType tspec rtype' + + let exitFunc = if null rtype' then cReturn caoOk : [] else [] + body'' = decls <<+> (body' <+>> exitFunc) + return $ cFuncDefinition (getSymbol fn) (rargs ++ args') (tPrefix tspec cr) body'' + + where + varDecl v = VarD (genLoc v) (type2TyDecl (varType v)) Nothing + +mapReturnType + :: CaoMonad m + => TranslationSpec -> [Type Var] + -> m (String, [CDecl]) +mapReturnType _ [] = return (caoRes, []) +mapReturnType tspec tps@(t:tl) = do + (t', tl') <- if isStruct t && aux t + then return (getSymbol $ getStructName t, tl) + else valOrRefFuncReturn tspec t (liftM (split id (const tl)) $ typeName tspec t) (return (caoRes, tps)) + tl'' <- zipWithSeqM byReference tl' + return (t', tl'') + + where + + -- [See note] + byReference n ty = do + let retArg = retArgId ++ show n + (_, ty') <- mapType tspec ty + valOrRef tspec ty (return $ cPointerDecl retArg) (return $ cParamDecl retArg) `apM` ty' + + aux (Struct sname _) = varType sname == Bullet -- HACK + aux _ = False + +-------------------------------------------------------------------------------- + +mapArg + :: CaoMonad m + => TranslationSpec -> Arg Var + -> m CDecl +mapArg tspec (Arg (L _ an) td) = cArgs tspec (getSymbol an) td $ varType an +mapArg tspec (ArgConst (L _ an) td _) = cArgs tspec (getSymbol an) td $ varType an + +-------------------------------------------------------------------------------- +--------------------------------------- TypeDef -------------------------------- + +mapTypeDef + :: CaoMonad m + => TranslationSpec -> TyDef Var + -> m [CExtDecl'] +mapTypeDef tspec td = case td of + TySynDef sn _ -> do + let nm = getSymbol $ unLoc sn + (tname, typ) <- mapType tspec $ synType $ varType $ unLoc sn -- TODO: HACK: get a more elegante way to deal with type synonyms + if nm == tname then return [] + else return [CED $ CDeclExt $ cTypedefDecl (tPrefix tspec nm) typ] + StructDecl sname lFields -> do + let tname = tPrefix tspec $ getSymbol (unLoc sname) + lFields' <- mapM (aux . fst) lFields + return [ CStructExt tname (tname ++ "_struct") lFields' ] + where + aux :: CaoMonad m => Located Var -> m CDecl' + aux v = do + let typ = sfType $ varType $ unLoc v + fldName = getSymbol $ unLoc v + tname <- typeName tspec typ + varOrMacroDecl tspec typ + (declD fldName tname) + (declM fldName tname typ) + + declD fn tn = return $ cParamDecl' fn (cType (tPrefix tspec tn)) + declM fn tn typ = valOrRefOpMacroReturn tspec typ code_decl + (caoError defSrcLoc $ mkUnknownErr $ ".:\ + \ Not expecting macro variable declaration returning a value") + (do (p, _) <- extractParams' tspec typ + let ffldcall = fCall tspec tn code_decl + return $ CFld $ cFuncCallStmt ffldcall (cVar fn : p)) + +-------------------------------------------------------------------------------- +--------------------------------------- TypeDecl ------------------------------- + +mapType + :: CaoMonad m + => TranslationSpec -> Type Var + -> m (String, CDeclSpec) +mapType tspec t = case t of + TySyn v _ -> return (getSymbol v, cType (tPrefix tspec $ getSymbol v)) + _ -> do + nm <- typeName tspec t + return (nm, cType (tPrefix tspec nm)) + +-------------------------------------------------------------------------------- +-------------------------------------- Statement ------------------------------- + +{- +The copy of values to ensure safeness may require types which are dependent +on the sequence index (this only happens with sequences which were translated +to while loops). Thus, they cannot be handled like ordinary variables and +taken outside the loop (done in PreC module), so they are initialized and +dealocked in the body of the loop to ensure dependencies. + +Since PreC declares those variables 'in place', this means that C scope rules +applies and we have to dealock them in the exit of any kind of block +(while, if, function) +-} + +-- Maps a block of CAO statements into a block of C statements +mapBlocks + :: CaoMonad m + => TranslationSpec -> [LStmt Var] + -> m CStat +mapBlocks tspec stmt = allocScope $ do + stmt' <- mapStatements tspec stmt + iDisp <- if isReturn $ unLoc $ last stmt then return [] else disposeAlloc tspec + return $ CCompound [] (stmt' ++ iDisp) undefNode + +mapStatements + :: CaoMonad m + => TranslationSpec -> [LStmt Var] + -> m [CBlockItem] +mapStatements tspec = concatMapM (mapStatement tspec . unLoc) + +mapStatement + :: CaoMonad m + => TranslationSpec -> Stmt Var + -> m [CBlockItem] + +mapStatement tspec (VDecl vd) = mapVarDecl tspec vd + +mapStatement tspec (Language.CAO.Syntax.CDecl cd) = mapConstDecl tspec cd + +mapStatement tspec (Assign lv [unLoc -> unTyp -> FunCall fn args]) = + mapFunCall tspec lv fn args + +mapStatement _ (Assign _ _) = + internalError "mapStatement" "Unexpected assignment case" + +mapStatement tspec (FCallS pn ex) = do + liftM singleton $ mapFCallS tspec pn ex + +mapStatement tspec (Ret re) = mapReturn tspec re + +mapStatement tspec (Ite ex ifBlock elseBlock) = do + cond <- mapExp tspec ex + let ex' = typeOf ex + cond' <- valOrRef tspec ex' (return id) (return cPointedExpr) `apM` cond + ifBlock' <- mapBlocks tspec ifBlock + elseBlock' <- mapMaybeM (mapBlocks tspec) elseBlock + return [ CBlockStmt (CIf cond' ifBlock' elseBlock' undefNode) ] + +mapStatement tspec (While ex whileBlock) = do + cond <- mapExp tspec ex + let ex' = typeOf ex + cond' <- valOrRef tspec ex' (return id) (return cPointedExpr) `apM` cond + whileBlock' <- mapBlocks tspec whileBlock + return [ CBlockStmt (CWhile cond' whileBlock' False undefNode) ] + +mapStatement _ (Nop _) = return [] +mapStatement _ _ = internalError "mapStatement" "Not expected!" + +-------------------------------------------------------------------------------- +{- +Note + +If the type is declared as a reference there is nothing left to do +If the type is declared as a value, then a pointer is being used, +thus we have to deference it +-} +{- +Return can be of the form: +* struct, ref1, ref2, ... +* constant, ref1, ref2, ... +* variable, ref1, ref2, ... +* ref1, ref2, ... +-} +mapReturn + :: CaoMonad m + => TranslationSpec -> [TLExpr Var] + -> m [CBlockItem] +mapReturn tspec [] = disposeAllAlloc tspec +mapReturn tspec exps@(expr:el) = do + e' <- mapExp tspec expr + (e'', el') <- if isCStructExpr $ unTyp $ unLoc expr + then return (e', el) + else valOrRefFuncReturn tspec (typeOf expr) (return (e', el)) (return (cVar caoOk, exps)) + assign <- zipWithSeqM byReference el' + disp <- disposeAllAlloc tspec + return $ assign ++ disp ++ [ cReturnExpr e'' ] + + where + byReference n ex = do + let op = if isLit (unTyp $ unLoc ex) then code_init else code_assign + typ = typeOf ex + tname <- typeName tspec typ + let fop = fCall tspec tname op + ex' <- mapExp tspec ex + -- [See note] + retArg <- valOrRef tspec typ (return cIndirection) (return id) `apM` cVar (retArgId ++ show n) + opReturnKind' tspec typ op + (return $ cAssignStmt retArg (cFuncCall fop [ex'])) + (return $ cFuncCallStmt fop [retArg, ex']) + (do (p, _) <- composedCase typ + return $ cAssignStmt retArg (cFuncCall fop (ex' : p))) + (do (p, _) <- composedCase typ + return $ cFuncCallStmt fop (retArg : ex' : p)) + + composedCase typ = if isComposed typ then extractParams' tspec typ else return ([], []) + +-------------------------------------------------------------------------------- +-- Procedure calls + +mapFCallS + :: CaoMonad m + => TranslationSpec -> Var -> [TLExpr Var] + -> m CBlockItem +mapFCallS tspec pn = liftM (cFuncCallStmt (getSymbol pn)) . mapExps tspec + +-------------------------------------------------------------------------------- +-- Function calls +mapFunCall + :: CaoMonad m + => TranslationSpec -> [LVal Var] -> Located Var -> [TLExpr Var] + -> m [CBlockItem] +-- Particular case when a global refrence extraction has to be called from the +-- static library +mapFunCall tspec lv (unLoc -> fn) ex@(e:_) | isCGlobalRef fn = do + e' : exps' <- mapExps tspec ex + (_, constArray) <- freshSmb + tname <- typeName tspec RInt + ccode <- cTypeCodeRedux tspec (typeOf e) + let lv' = mapLVal (head lv) -- TODO: verify that lv has only one value by pattern matching + len = genericLength exps' + cdecl = cTypeArrayDecl constArray (tPrefix tspec tname) exps' + return [cdecl, cFuncCallStmt (getSymbol fn) [ cExprAddr lv', e', cCharExpr ccode, cVar constArray, cIntExpr len] ] + +-- Call to a function of the static library +mapFunCall tspec lv (unLoc -> fn) ex | isCFunction fn = do + ex' <- mapExps tspec ex + let typ = varType fn + opReturnKind' tspec typ (getOpName fn) + (do lv' <- auxFR lv -- OFuncReturn + return [ cAssignStmt lv' (cFuncCall (getSymbol fn) ex' )]) + (do lv' <- auxFA lv -- OFuncRef + return [ cFuncCallStmt (getSymbol fn) (lv' : ex') ]) + (do lv' <- auxFR lv -- OMacroReturn + (p, d) <- composedCase typ + return $ d ++ [ cAssignStmt lv' (cFuncCall (getSymbol fn) (ex' ++ p) )]) + (do lv' <- auxM1 typ lv -- OMacroRef + (p, d) <- composedCase typ + return $ d ++ [ cFuncCallStmt (getSymbol fn) (lv' ++ ex' ++ p) ]) + where + composedCase typ = if isComposed typ && (isCAssign fn || isCComp fn) then extractParams' tspec typ else return ([], []) + + auxFR = return . mapLVal . head +{- +Note: + +A macro "returns" a value in a different way than a function. +For instance, in macro(a, b) we can: +- make it return a value +#define macro(a,b) a+b +v = macro(a,b) +- return the value by 'a' (we call this by "reference", although this is not +completely correct): +#define macro(a,b) a=b +macro(v,b) + +Thus, what we pass as "return" argument depends on if the type is used by value +or by reference. +However, there is a special case: when we have a reference to a type used by +value. In this case, we have to cast it to a pointer to the type and the use +an indirection to pass a value. + +-} + auxM1 :: CaoMonad m => Type Var -> [LVal Var] -> m [CExpr] + auxM1 tp [LVVar (unLoc -> v)] + | isCRef v = do + tname <- typeName tspec tp + valOrRef tspec tp (return $ singleton . cIndirection) (return singleton) `apM` cPointerCast (tPrefix tspec tname) (cVar' v) + | otherwise = return [cVar' v] + auxM1 _ [LVStruct (LVVar (unLoc -> v)) fld] = return [mapProj v fld] + auxM1 _ _ = caoError defSrcLoc $ mkUnknownErr $ "Not expected function call result" + + + auxFA [LVVar (unLoc -> v)] = case varType v of + Bullet -> (return $ cVar $ getSymbol v) + t -> valOrRef tspec t + (return $ cExprAddr $ cVar $ getSymbol v) + (return $ cVar $ getSymbol v) + auxFA [LVStruct (LVVar (unLoc -> v)) fld] = case varType v of + Bullet -> + (return $ mapProj v fld) + t -> valOrRef tspec t + (return $ cExprAddr $ mapProj v fld) + (return $ mapProj v fld) + auxFA _ = caoError defSrcLoc $ mkUnknownErr $ "Not expected function call result" + +-- TODO: Left values were tested againt Bullet type. This is a HACK and was +-- removed. However, some code that dependend on this hack may fail. + +-- Call to a function +mapFunCall tspec lv (unLoc -> fn) args = do + ex' <- mapExps tspec args + (lv', re) <- auxLV lv + let call = cFuncCall (getSymbol fn) (re ++ ex') + return $ singleton $ maybe (cExprStmt call) (flip cAssignStmt call) lv' + where + + auxLV :: CaoMonad m => [LVal Var] -> m (Maybe CExpr, [CExpr]) + auxLV (r:rt) = do + (r', rt') <- if isCStruct' r + then return (Just $ mapLVal r, rt) + else valOrRefFuncReturn tspec (typeOf r) (return (Just $ mapLVal r, rt)) (return (Nothing, r:rt)) + rt'' <- mapM auxFA rt' + return (r', rt'') + auxLV _ = caoError defSrcLoc $ mkUnknownErr $ "Not expected function call result" + + auxFA :: CaoMonad m => LVal Var -> m CExpr + auxFA l = valOrRef tspec (typeOf l) (return cExprAddr) (return id) `apM` mapLVal l +-------------------------------------------------------------------------------- +-- Constant declaration +mapConstDecl + :: CaoMonad m + => TranslationSpec -> ConstDecl Var + -> m [CBlockItem] +mapConstDecl tspec c = case c of + ConstD (unLoc -> n) _ _ -> varMemory tspec n >> constDeclaration tspec n + _ -> caoError defSrcLoc $ mkUnknownErr $ ".:\ + \ precondition violation:\n" ++ showPpr c + +constDeclaration + :: CaoMonad m + => TranslationSpec -> Var + -> m [CBlockItem] +constDeclaration tspec v = varOrMacroDecl tspec (varType v) auxVar auxMac + -- TODO: This definitions are equal to varDeclaration + where + auxVar = do + decl <- if isGlobalVar v then return [] else liftM (singleton . cVarDeclStmt (getSymbol v) . tPrefix tspec) . cTypeName tspec $ v + alloc <- autoOrAlloc tspec (varType v) (return []) (do + typ <- cTypeName tspec v + (args, d) <- extractParams tspec v + (targs, decl') <- cTypeCodeArgs tspec (typeOf v) + let fcall = fCall tspec typ code_decl + n = cVar' v + valOrRefOpReturn tspec (varType v) code_decl + (return (decl' ++ d ++ [ cAssignStmt n $ cFuncCall fcall $ args ++ targs ])) + (return (decl' ++ d ++ [ cFuncCallStmt fcall (cExprAddr n : args ++ targs) ]))) + return $ decl ++ alloc + auxMac = do + tname <- cTypeName tspec v + (p, d) <- extractParams tspec v + let n = cVar' v + fdcall = fCall tspec tname code_decl + decl <- if isGlobalVar v then return [] else valOrRefOpMacroReturn tspec (varType v) code_decl + (caoError defSrcLoc $ mkUnknownErr $ ".:\ + \ Not expecting macro variable declaration returning a value") + (return [ cFuncCallStmt fdcall (n : p) ]) + let ficall = fCall tspec tname code_init_def + vini <- valOrRefOpMacroReturn tspec (varType v) code_init_def + (return [ cAssignStmt n $ cFuncCall ficall p ]) + (return [ cFuncCallStmt ficall (n : p) ]) + return (d ++ decl ++ vini) + +-------------------------------------------------------------------------------- +-- Variable declaration +mapVarDecl + :: CaoMonad m + => TranslationSpec -> VarDecl Var + -> m [CBlockItem] +mapVarDecl tspec v = case v of + VarD (unLoc -> n) _ Nothing -> varMemory tspec n >> varDeclaration tspec n + ContD (unLoc -> n) _ e -> varMemory tspec n >> varDeclInit tspec n e + _ -> caoError defSrcLoc $ mkUnknownErr $ ".:\ + \ precondition violation:\n" ++ showPpr v + +varDeclaration + :: CaoMonad m + => TranslationSpec -> Var + -> m [CBlockItem] +varDeclaration tspec v + | isCRef v = return [ cVarDeclStmt (getSymbol v) (tPrefix tspec caoRef) ] + | isCStruct v = return [ cVarDeclStmt (getSymbol v) (tPrefix tspec (getTName v)) ] + | otherwise = varOrMacroDecl tspec (varType v) auxVar auxMacro + where + auxVar = do + decl <- if isGlobalVar v then return [] else liftM (singleton . cVarDeclStmt (getSymbol v) . tPrefix tspec) . cTypeName tspec $ v + alloc <- autoOrAlloc tspec (varType v) (return []) (do + typ <- cTypeName tspec v + (args, d) <- extractParams tspec v + (targs, decl') <- cTypeCodeArgs tspec (typeOf v) + let fcall = fCall tspec typ code_decl + n = cVar' v + valOrRefOpReturn tspec (varType v) code_decl + (return (decl' ++ d ++ [ cAssignStmt n $ cFuncCall fcall $ args ++ targs ])) + (return (decl' ++ d ++ [ cFuncCallStmt fcall (cExprAddr n : args ++ targs) ]))) + return $ decl ++ alloc + auxMacro = do + tname <- cTypeName tspec v + (p, d) <- extractParams tspec v + let n = cVar' v + fdcall = fCall tspec tname code_decl + decl <- if isGlobalVar v then return [] else valOrRefOpMacroReturn tspec (varType v) code_decl + (caoError defSrcLoc $ mkUnknownErr $ ".:\ + \ Not expecting macro variable declaration returning a value") + (return [ cFuncCallStmt fdcall (n : p) ]) + let ficall = fCall tspec tname code_init_def + vini <- valOrRefOpMacroReturn tspec (varType v) code_init_def + (return [ cAssignStmt n $ cFuncCall ficall p ]) + (return [ cFuncCallStmt ficall (n : p) ]) + return (d ++ decl ++ vini) + +varDeclInit + :: CaoMonad m + => TranslationSpec -> Var -> [TLExpr Var] + -> m [CBlockItem] +varDeclInit tspec v exps = do + let typ = varType v + intyp = head $ innerType typ + (_, constArray) <- freshSmb + tname <- typeName tspec typ + vdecl <- varDeclaration tspec v + exps' <- mapExps tspec exps + cdecl <- autoOrAlloc tspec intyp + (return $ cIntArrayDecl constArray exps') + (return $ cCharArrayDecl constArray exps') + let fcall = fCall tspec tname code_init + adecl <- opReturnKind' tspec typ code_init + (return [ cAssignStmt (cVar' v) $ cFuncCall fcall [cVar constArray] ]) + (return [ cFuncCallStmt fcall [cVar' v, cVar constArray ] ]) + (do (p, d) <- extractParams' tspec typ + return $ d ++ [ cAssignStmt (cVar' v) $ cFuncCall fcall $ [cVar constArray] ++ p]) + (do (p, d) <- extractParams' tspec typ + return $ d ++ [ cFuncCallStmt fcall $ [cVar' v, cVar constArray] ++ p]) + + return $ cdecl : vdecl ++ adecl + +-------------------------------------------------------------------------------- +-------------------------------------------- Exp ------------------------------- + +mapExps + :: CaoMonad m + => TranslationSpec -> [TLExpr Var] + -> m [CExpr] +mapExps tspec = mapM (mapExp tspec) + +mapExp + :: CaoMonad m + => TranslationSpec -> TLExpr Var + -> m CExpr +mapExp tspec e = case unTyp $ unLoc e of + Lit l -> mapLiteral tspec (typeOf e) l + Var v -> return $ cVar' v + StructProj (unLoc -> unTyp -> Var v) fld -> return $ mapProj v fld + _ -> internalError + "mapExp" "Not expected case" + +-------------------------------------------------------------------------------- +-- Left values + +mapLVal + :: LVal Var + -> CExpr +mapLVal (LVVar (unLoc -> v)) = cVar' v +mapLVal (LVStruct (LVVar (unLoc -> v)) fld) = mapProj v fld +mapLVal _ = internalError "mapLVal" "Not expected case." + +mapProj :: Var -> Var -> CExpr +mapProj v fld = CMember (cVar' v) (internalIdent (getSymbol fld)) False undefNode + +-------------------------------------------------------------------------------- +------------------------------ Literals ---------------------------------------- + +mapLiteral + :: CaoMonad m + => TranslationSpec -> Type Var -> Literal Var + -> m CExpr +mapLiteral tspec i l = case l of + BLit b -> let + b' = mapBoolLiteral b + in autoOrAlloc tspec i + (return $ cIntExpr b') + (return $ cStringExpr $ show b') + ILit v -> + autoOrAlloc tspec i + (return $ cIntExpr v) + (return $ cStringExpr $ show v) + BSLit s bits -> let + v = mapBitString s bits + in autoOrAlloc tspec i + (return $ cIntExpr v) + (return $ cStringExpr $ show v) + PLit p -> + autoOrAlloc tspec i + (return $ cIntExpr $ mapSimplePolynomial p) + (return $ cStringExpr $ showMonomials $ mapPolynomial p) + +mapBoolLiteral :: Bool -> Integer +mapBoolLiteral b = if b then cTrueValue else cFalseValue + +mapBitString :: Sign -> [Bool] -> Integer +mapBitString s bs = case s of + U -> ubitsToInteger bs + S -> sbitsToInteger bs + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +----------------------------- Polynomial --------------------------------------- + +mapPolynomial :: Pol Var -> [IExpr Var] +mapPolynomial p = case p of + Pol [Mon (CoefI i) EZero] -> [i] + Pol mlst -> mapMonomials mlst + +mapSimplePolynomial :: Pol Var -> Integer +mapSimplePolynomial p = case p of + Pol [Mon (CoefI (IInt i)) EZero] -> i + Pol [Mon (CoefI _) EZero] -> internalError "mapSimplePolynomial" "<>: non literal" + Pol _ -> internalError "mapSimplePolynomial" "Unexpected polynomial literal" + +-------------------------------------------------------------------------------- +----------------------------- Monomials ---------------------------------------- + +showMonomials :: [IExpr Var] -> String +showMonomials = intercalate ";" . map (show . getInteger) + +getInteger :: IExpr Var -> Integer +getInteger (IInt n) = n +getInteger _ = internalError "getInteger" "Not expected non-literal" + +mapMonomials :: [Mon Var] -> [IExpr Var] +mapMonomials lm = case lm of + [] -> error ".: precondition violation: empty list" + Mon (CoefP _) _: _ -> error $ ".:\n" + ++ concatMap showPpr lm + Mon (CoefI _) _: _ -> + uncurry mapMonomial $ split (getMonExp . head) id lm + -- Invariant: The list of monomials is ordered by decresing degree + +mapMonomial :: Integer -> [Mon Var] -> [IExpr Var] +mapMonomial 0 [] = IInt 0 : [] +mapMonomial 0 (Mon (CoefI i) _ : _) = i : [] +mapMonomial n [] = IInt 0 : mapMonomial (n-1) [] +mapMonomial n ml@(Mon (CoefI _) EZero : _) = IInt 0 : mapMonomial (n-1) ml +mapMonomial n ml@(Mon (CoefI icoef) (MExpI _ n'): mlst) + | n == n' = icoef : mapMonomial (n-1) mlst + | otherwise = IInt 0 : mapMonomial (n-1) ml +mapMonomial _ _ = internalError "mapMonomial" "Not expected case" + +-------------------------------------------------------------------------------- +-- + +varMemory :: CaoMonad m => TranslationSpec -> Var -> m () +varMemory tspec v + | isCStruct v || isCRef v || isGlobalVar v = return () + | otherwise = autoOrAlloc tspec (varType v) (return ()) (storeAllocVar v) + +-- Wrapper for creating C declarations from pairs string/type +cArgs :: CaoMonad m => + TranslationSpec -> String -> TyDecl Var -> Type Var -> m CDecl +cArgs tspec nm (TySynD n) _ = + return $ cParamDecl nm $ cType (tPrefix tspec $ getSymbol (unLoc n)) +cArgs tspec nm _ typ = liftM (cParamDecl nm . snd) (mapType tspec typ) + +-------------------------------------------------------------------------------- +-- Auxiliary functions + +cVar' :: Var -> CExpr +cVar' = cVar . getSymbol + +mapIndex :: IExpr Var -> CExpr +mapIndex (IInt n) = cIntExpr n +mapIndex (IInd v) = cVar' v +mapIndex _ = internalError "mapIndex" "Not expected index." + +-------------------------------------------------------------------------------- + +cTypeCodeArgs :: CaoMonad m => TranslationSpec -> Type Var -> m ([CExpr], [CBlockItem]) +cTypeCodeArgs tspec i + | isSimpleType i = return ([], []) + | otherwise = do + let i' = innerType i + ctc <- concatMapM (cTypeCode tspec) i' + (ilst, d) <- concatMapAndUnzipM (cTypeParams tspec) i' + (param, decl) <- if null ilst + then return ([ cIntExpr 0 ], []) + else do + (_, paramArray) <- freshSmb + let decl = cPointerArrayDecl paramArray ilst + return ([ cVar paramArray ], [decl]) + return (cStringExpr ctc : param, d ++ decl) + +---------------------------------------- CAOType ------------------------------- + +cTypeCode :: CaoMonad m => TranslationSpec -> Type Var -> m String +cTypeCode tspec = cTypeCode' + where + cTypeCode' :: CaoMonad m => Type Var -> m String + cTypeCode' t = do + c <- codes tspec t + c' <- case t of + Int -> return [] + RInt -> return [] + Bool -> return [] + Bits _ _ -> return [] + Mod Nothing Nothing (Pol [Mon (CoefI _) EZero]) -> return [] + Mod (Just b) _ _ -> + if isModInt b + then return [] + else caoError defSrcLoc $ NestedModpolErr t + Vector _ t' -> cTypeCode' t' + Matrix _ _ t' -> cTypeCode' t' + Struct _ flds -> concatMapM (cTypeCode' . snd) flds + _ -> caoError defSrcLoc $ NotSupportedTypeErr t + return $ c ++ c' + +cTypeParams :: CaoMonad m => TranslationSpec -> Type Var -> m ([CExpr], [CBlockItem]) +cTypeParams tspec = worker + where + worker :: CaoMonad m => Type Var -> m ([CExpr], [CBlockItem]) + worker t = do + i <- cTypeCode' t + concatMap2M aux i + + aux [] = return (cIntExpr 0, []) + aux [IInd v] = do + v' <- valOrRef tspec (varType v) (return cExprAddr) (return id) + `apM` cVar' v + return (v', []) + aux [IInt n] = do + (_, paramArray) <- freshSmb + ctc <- typeName tspec RInt + let decl = cTypeArrayDecl paramArray (tPrefix tspec ctc) [ cIntExpr n ] + return ( cVar paramArray, [decl] ) + aux [i, j] = do + (_, paramArray) <- freshSmb + ctc <- typeName tspec RInt + let a = mapIndex i : mapIndex j : [] + decl = cTypeArrayDecl paramArray (tPrefix tspec ctc) a + return ( cVar paramArray, [decl]) + + aux _ = internalError "cTypeCode.aux" "Not expected value" + + cTypeCode' :: CaoMonad m => Type Var -> m [[IExpr Var]] + cTypeCode' t = + case t of + Int -> return [[]] + RInt -> return [[]] + Bool -> return [[]] + Bits _ n -> return [[n]] + Mod Nothing Nothing (Pol [Mon (CoefI m) EZero]) -> return [[m]] + Mod (Just b) _ _ -> + if isModInt b + then return [[]] + else caoError defSrcLoc $ NestedModpolErr t + Vector n t' -> do + ilst <- cTypeCode' t' + return ([n] : ilst) + Matrix n m t' -> do + ilst <- cTypeCode' t' + return ([n , m] : ilst) + Struct _ flds -> do + liftM ([IInt $ genericLength flds] : ) $ concatMapM (cTypeCode' . snd) flds + _ -> caoError defSrcLoc $ NotSupportedTypeErr t + +extractParams :: CaoMonad m => TranslationSpec -> Var -> m ([CExpr], [CBlockItem]) +extractParams tspec = extractParams' tspec . varType + +extractParams' :: CaoMonad m => TranslationSpec -> Type Var -> m ([CExpr], [CBlockItem]) +extractParams' tspec i = case i of + Bits _ m -> + return (mapIndex m : [], []) + Vector m _ -> do + return (mapIndex m : [], []) + Matrix m n _ -> do + return (mapIndex m : mapIndex n : [], []) + Mod Nothing Nothing (Pol [Mon (CoefI m) EZero]) -> do + return (mapIndex m : [], []) + Mod (Just (Mod Nothing Nothing (Pol [Mon (CoefI m) EZero]))) (Just _) pol + -> polyParams tspec m pol + Mod (Just _) (Just _) _ + -> caoError defSrcLoc $ NestedModpolErr i + Struct _ flds -> return ([cIntExpr $ genericLength flds], []) + _ -> return ([], []) + +polyParams :: CaoMonad m => TranslationSpec -> IExpr Var -> Pol Var -> m ([CExpr], [CBlockItem]) +polyParams tspec m pol = do + (_, paramArray) <- freshSmb + ctc <- typeName tspec Int + let m' = mapIndex m + pol' = map mapIndex (mapPolynomial pol) + decl = cTypeArrayDecl paramArray (tPrefix tspec ctc) pol' + return ([ dg (degree pol), m', cVar paramArray ], [decl]) + --return ([ cIntExpr (degree pol), m', cVar paramArray ], [decl]) + + where + -- XXX: This should be improved since it may not work in all cases + dg n = cVar $ "c_const_int_" ++ show n + +-------------------------------------------------------------------------------- +isComposed :: Type Var -> Bool +isComposed t = isVector t || isMatrix t + +cTypeCodeRedux :: CaoMonad m => TranslationSpec -> Type Var -> m Char +cTypeCodeRedux tspec = liftM head . codes tspec + +isCStruct' :: LVal Var -> Bool +isCStruct' (LVVar (unLoc -> v)) = isCStruct v +isCStruct' (LVStruct (LVVar (unLoc -> v)) _) = isCStruct v +isCStruct' _ = error "Not expected function call result" + +isCStructExpr :: Expr Var -> Bool +isCStructExpr (Var e) = isCStruct e +isCStructExpr _ = False + +-- Translation of type names +cTypeName :: CaoMonad m => TranslationSpec -> Var -> m String +cTypeName tspec = typeName tspec . varType + +cProc :: TranslationSpec -> String -> [CBlockItem] -> CFunDef +cProc tspec name body = cFuncDefinition name [] (tPrefix tspec caoRes) $ + CCompound [] (body ++ cReturn caoOk : []) undefNode + +tPrefix :: TranslationSpec -> String -> String +tPrefix tspec = ((typePrefix tspec ++ "_") ++) + +moduleName :: String +moduleName = "" + +internalError :: String -> String -> a +internalError funcName msg = error $ + moduleName ++ ".<" ++ funcName ++ ">: " ++ msg + diff --git a/src/Language/CAO/Translation/C/Wrappers.hs b/src/Language/CAO/Translation/C/Wrappers.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Translation/C/Wrappers.hs @@ -0,0 +1,269 @@ + +{- | +Module : $Header$ +Description : C generation patterns. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +C generation patterns. +-} + +module Language.CAO.Translation.C.Wrappers + ( CExtDecl'(..) + , CTranslUnit'(..) + , CDecl'(..) + , declOrMacro + , cVar + , cVarDecl + , cVarIntDecl + , cVarCharDecl + , cVarDeclStmt + , cVarAddr + , cIntExpr + , cStringExpr + , cCharExpr + , cExprAddr + , cFuncCall + , cFuncCallStmt + , cAssignStmt + , cCharArrayDecl + , cIntArrayDecl + , cTypeArrayDecl + , cParamDecl + , cParamDecl' + , cPointerDecl + , cPointerCast + , cPointedExpr + , cIndirection + , cFuncDefinition + , cTypedefDecl + , cType + , cReturn + , cReturnExpr + , (<<+>) + , (<+>>) + , cPointerArrayDecl + , cExprStmt + ) where + +import Language.C +import Text.PrettyPrint.HughesPJ + +-- HACK: +-- Extension and redefinition of the C AST in order to cope with function calls outside +-- function bodies. +-- This is needed for macro declarations of variables and macro declarations of struct fields. +data CExtDecl' = CED CExtDecl | CMacroExt CBlockItem | CStructExt String String [CDecl'] + +data CDecl' = + CDecl' CDecl + | CFld CBlockItem + +instance Pretty CDecl' where + pretty (CDecl' c) = pretty c <> semi + pretty (CFld b) = pretty b <> semi + +instance Pretty CExtDecl' where + pretty (CED c) = pretty c + pretty (CMacroExt m) = pretty m + pretty (CStructExt tn sn l) = + hsep [ + text "typedef", + vcat [ + text "struct" <+> text sn <+> text "{", + nest 4 $ sep ( (map pretty l)), + text "}" + ] + ] <+> text tn <> semi + +data CTranslUnit' = CTranslUnit' [CExtDecl'] NodeInfo + +instance Pretty CTranslUnit' where + pretty (CTranslUnit' edecls _) = vcat (map pretty edecls) + +declOrMacro :: Either CDecl CBlockItem -> CExtDecl' +declOrMacro = either (CED . CDeclExt) CMacroExt +-------------------------------------------------------------------------------- +-- Language.C auxiliary + +-------------------------------------------------------------------------------- +-- Declarations -- CDeclSpec + +-- Short-hand for C void type +cVoidType :: CDeclSpec +cVoidType = CTypeSpec (CVoidType undefNode) + +-- Short-hand for C int type +cIntType :: CDeclSpec +cIntType = CTypeSpec (CIntType undefNode) + +-- Short-hand for C char type +cCharType :: CDeclSpec +cCharType = CTypeSpec (CCharType undefNode) + +-- Returns a C type with a given name +cType :: String -> CDeclSpec +cType tname = + CTypeSpec $ CTypeDef (internalIdent tname) undefNode + +-- Constant type qualifier +cConst :: CDeclSpec +cConst = CTypeQual (CConstQual undefNode) + +-------------------------------------------------------------------------------- +-- Declarations -- CDecl + +-- Wrapper for declaring variables without initialization +cVarDecl :: String -> String -> CDecl +cVarDecl name typ = cParamDecl name (cType typ) + +cVarIntDecl :: String -> CDecl +cVarIntDecl name = cParamDecl name cIntType + +cVarCharDecl :: String -> CDecl +cVarCharDecl name = cParamDecl name cCharType + +-- Wrapper for C typedef definitions +cTypedefDecl :: String -> CDeclSpec -> CDecl +cTypedefDecl tname typ = + CDecl [CStorageSpec (CTypedef undefNode),typ] [(Just (cDeclr tname []), Nothing, Nothing)] undefNode + +-- Wrapper for declaring function parameters +cParamDecl :: String -> CDeclSpec -> CDecl +cParamDecl tname typ = + CDecl [typ] [(Just (cDeclr tname []), Nothing, Nothing)] undefNode + +cParamDecl' :: String -> CDeclSpec -> CDecl' +cParamDecl' tname typ = CDecl' $ cParamDecl tname typ + +cPointerDecl :: String -> CDeclSpec -> CDecl +cPointerDecl tname typ = CDecl [typ] [(Just (cDeclr tname [CPtrDeclr [] undefNode]), Nothing, Nothing)] undefNode + +cPointer :: CDeclSpec -> CDecl +cPointer typ = CDecl [typ] [(Just (CDeclr Nothing [CPtrDeclr [] undefNode] Nothing [] undefNode), Nothing, Nothing)] undefNode + +cDeclr :: String -> [CDerivedDeclr] -> CDeclr +cDeclr nm lst = CDeclr (Just (internalIdent nm)) lst Nothing [] undefNode + +-------------------------------------------------------------------------------- +-- Statements -- CBlockItem + +cAssignStmt :: CExpr -> CExpr -> CBlockItem +cAssignStmt evar cexpr = cExprStmt $ CAssign CAssignOp evar cexpr undefNode + +-- Wrapper for C function call statements +cFuncCallStmt :: String -> [CExpr] -> CBlockItem +cFuncCallStmt fname = cExprStmt . cFuncCall fname + +-- Wrapper for C expression statements +cExprStmt :: CExpr -> CBlockItem +cExprStmt e = CBlockStmt (CExpr (Just e) undefNode) + +-- Default return statement (value OK) +cReturn :: String -> CBlockItem +cReturn caoOk = CBlockStmt $ CReturn (Just (cVar caoOk)) undefNode + +cReturnExpr :: CExpr -> CBlockItem +cReturnExpr e = CBlockStmt $ CReturn (Just e) undefNode + +cVarDeclStmt :: String -> String -> CBlockItem +cVarDeclStmt name = CBlockDecl . cVarDecl name + +cCharArrayDecl :: String -> [CExpr] -> CBlockItem +cCharArrayDecl name = cArrayDecl name [cConst, cCharType] True + +cIntArrayDecl :: String -> [CExpr] -> CBlockItem +cIntArrayDecl name = cArrayDecl name [cConst, cIntType] False + +cTypeArrayDecl :: String -> String -> [CExpr] -> CBlockItem +cTypeArrayDecl name typ = cArrayDecl name [cType typ] False + +cArrayDecl :: String -> [CDeclSpec] -> Bool -> [CExpr] -> CBlockItem +cArrayDecl name qual pointer = cArray qual name dlst + where + dlst = cNoArraySize : if pointer then [cNoArraySize] else [] + +cPointerArrayDecl :: String -> [CExpr] -> CBlockItem +cPointerArrayDecl name = cArray [cVoidType] name dlst + where + dlst = [cNoArraySize, CPtrDeclr [] undefNode] + +cArray :: [CDeclSpec] -> String -> [CDerivedDeclr] -> [CExpr] -> CBlockItem +cArray typ name dlst initLst = CBlockDecl $ CDecl typ + [ (Just name', Just (CInitList (concatMap initVal initLst) undefNode), Nothing) ] + undefNode + where + name' = cDeclr name dlst + + initVal :: CExpr -> CInitList + initVal str = [([], CInitExpr str undefNode)] + +cNoArraySize :: CDerivedDeclr +cNoArraySize = CArrDeclr [] (CNoArrSize False) undefNode +-------------------------------------------------------------------------------- +-- Expressions -- CExpr + +-- Returns a C variable with a given name +{-# INLINE cVar #-} +cVar :: String -> CExpr +cVar name = CVar (internalIdent name) undefNode + +-- Wrapper for C function calls +cFuncCall :: String -> [CExpr] -> CExpr +cFuncCall fname args = CCall (cVar fname) args undefNode + +-- C literal expression from integer +cIntExpr :: Integer -> CExpr +cIntExpr n = CConst $ CIntConst (cInteger n) undefNode + +-- C literal expression from string +cStringExpr :: String -> CExpr +cStringExpr str = CConst $ CStrConst (cString str) undefNode + +-- C literal char +cCharExpr :: Char -> CExpr +cCharExpr c = CConst $ CCharConst (cChar c) undefNode + +-- Indirection of an expression +cIndirection :: CExpr -> CExpr +cIndirection e = CUnary CIndOp e undefNode + +-- Indirection of a pointer cast to int +cPointedExpr :: CExpr -> CExpr +cPointedExpr e = cIndirection (CCast (cPointer cIntType) e undefNode) + +-- Cast of a pointer +cPointerCast :: String -> CExpr -> CExpr +cPointerCast typ e = CCast (cPointer (cType typ)) e undefNode + +{-# INLINE cVarAddr #-} +cVarAddr :: String -> CExpr +cVarAddr vid = CUnary CAdrOp (cVar vid) undefNode + +{-# INLINE cExprAddr #-} +cExprAddr :: CExpr -> CExpr +cExprAddr vid = CUnary CAdrOp vid undefNode + +-------------------------------------------------------------------------------- +-- Wrapper for defining C functions +cFuncDefinition :: String -> [CDecl] -> String -> CStat -> CFunDef +cFuncDefinition fname cParamDecls caoRes body = let + prms' = if null cParamDecls + then [CDecl [cVoidType] [] undefNode] + else cParamDecls -- Void for empty parameter list in new style declarations + funcDecl = cDeclr fname [CFunDeclr (Right (prms', False)) [] undefNode] + in CFunDef [cType caoRes] funcDecl [] body undefNode + +-------------------------------------------------------------------------------- +(<+>>) :: CStat -> [CBlockItem] -> CStat +(<+>>) (CCompound a1 lst a2) it = CCompound a1 (lst ++ it) a2 +(<+>>) _ _ = error ".<<+>>>: Not expected case" + +(<<+>) :: [CBlockItem] -> CStat -> CStat +(<<+>) it (CCompound a1 lst a2) = CCompound a1 (it ++ lst) a2 +(<<+>) _ _ = error ".<<<+>>: Not expected case" + diff --git a/src/Language/CAO/Translation/Names.hs b/src/Language/CAO/Translation/Names.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Translation/Names.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternGuards #-} + +{- | +Module : $Header$ +Description : CAO Translation naming. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +CAO to C tranlation naming. +-} + +module Language.CAO.Translation.Names + ( moduleHeader + , typePrefix + , fOpCall + , fCastCall + , initName + , disposeName + , opCode + , fCall + , lopName + ) where + +import Data.List (nub) + +import Language.CAO.Common.Outputable +import Language.CAO.Common.Var + +import Language.CAO.Platform.Naming +import Language.CAO.Platform.Query +import Language.CAO.Platform.Specification + +import Language.CAO.Syntax +import Language.CAO.Syntax.Codes + +import Language.CAO.Type + +-- Header -- +-- This code is importing the headers for all the types defined in the specification of +-- the platform. A more sophisticated mechanism would register the types of the used operations +-- and only generate imports for those. +moduleHeader :: String -> TranslationSpec -> String +moduleHeader fn tspec = + banner ++ concatMap (\m -> "#include \"" ++ m ++ "\"\n") + ( nub $ defaultHeader (globalTransSpec tspec) : map headerFile (queryTTS (typeTransSpec tspec)) ) + where + banner = + "/*\n\tAutomatically generated by the CAO compiler from file:\n\t" ++ + fn ++ "\n*/\n" + +lopName :: Type Var -> APat Var -> OpCode +lopName t p = + case p of + VectP (CElem _) -> case t of + Bits _ _ -> code_set + _ -> code_ref + VectP (CRange _ _) -> code_range_set + MatP (CElem _) (CElem _) -> code_ref + MatP (CRange _ _) (CRange _ _) -> code_range_set + MatP (CRange _ _) (CElem _) -> code_row_range_set + MatP (CElem _) (CRange _ _) -> code_col_range_set + + +fCall :: TranslationSpec -> String -> OpCode -> String +fCall tspec n fs = callPrefix (globalTransSpec tspec) ++ "_" ++ n ++ "_" ++ operName fs + +fCastCall :: TranslationSpec -> String -> String -> String +fCastCall tspec orig dest = callPrefix (globalTransSpec tspec) ++ orig ++ "_" ++ (operName code_cast) ++ "_" ++ dest + +fOpCall :: PP a => TranslationSpec -> Expr a -> String -> String +fOpCall tspec ex typ = callPrefix (globalTransSpec tspec) ++ typ ++ operName (codeOf ex) + +initName, disposeName, typePrefix :: TranslationSpec -> String +initName = initProcName . globalTransSpec +disposeName = disposeProcName . globalTransSpec +typePrefix = tpPrefix . globalTransSpec + diff --git a/src/Language/CAO/Translation/PreC.hs b/src/Language/CAO/Translation/PreC.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Translation/PreC.hs @@ -0,0 +1,892 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} +{- | +Module : $Header$ +Description : CAO to C pre-translation. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +After handling constants, the next step is to make the CAO code as close as +possible to the final C code. In more detail, the following actions are +performed: +* All CAO native operations are replaced by a call to a function with the +same name as the respective implementation in the static library. For +instance, the following CAO code, where 'a', 'b' and 'r' are integer variables + +@r := a + b;@ + +is transformed to + +@r := CAO_int_add(a, b);@ + +In particular, the called name follows the convention: + +@{prefix} {type name} {operation name}(argument list)@ + +* Accesses to vectors or matrices are replaced by extraction of references. +Although CAO does not support references, this is completely transparent +since these are treated as a special kind of variable. For instance, the +following assignment to a vector v of integers, where n is an integer + +@v[0] := n;@ + +is transformed to + +@ +def t : REF; +t := CAO_vector_ref(v, 0); +t := CAO_int_assign(n); +@ + +In the final translation step, the variable t will be translated to a real +reference. + +* Operation and function arguments are handled according to the specification +of safety, as explained in the previous section. If an operation in specified +as unsafe, a copy of its arguments is generated. If an operation is argument +safe, a copy of the argument used as result is generated as in the case +@a := (a,b)@. This assumes that the compiler does not introduce aliasing +and that variables can be distinguished by their name. The introduction of +references described above in not a problem since it always references a +region of a container and cannot be mixed with other references. +We should notice that the implementation of the init and assign operations in +the library must be safe. Otherwise, a copy would not solve the problem as +these are the operations used to copy values. Also, ref operations must be safe +since extracting a reference should not change its argument. + +* Calls to structure fields are replaced by integers accordingly with the +specification. For instance, let us consider the following structure in CAO: + +@ +typedef S := struct [ + def n : int; + def b : bool; +]; +@ + +and that we have the following code: +@ + def i : int; + i := s.n; + s.b := true; +@ + +The inlining option makes the integer constant to be used directly in the +selection functions: + +@ + c_i := CAO_struct_select(c_s, 0); + c_t := CAO_bool_init(true); + c_t50 := CAO_struct_ref(c_s, 1); + c_t50 := CAO_bool_assign(c_t); +@ + +In this case, the field n was replaced by 0 and the field b was replaced by 1. +The global variable option replaces the call by a global variable: + +@ + c_i := CAO_struct_select(c_s, c_n); + c_t52 := CAO_struct_ref(c_s, c_b); + c_t52 := CAO_bool_assign(c_const_true); +@ + +which is initialized in the global init procedure: + +@ + def init() : void { + c_n := CAO_int_init(0); + c_b := CAO_int_init(1); + c_const_true := CAO_bool_init(true); +} +@ + +* The specification allows us to determine if values should be returned by +value or by reference. The language also allows us to return several results +simultaneously. The chosen mechanism for returning several values or references +were C structures. + +For instance, let us consider the swap function which returns two integer, and +that integers in this platform are returned by value: + +@ + def swap(a : int, b : int) : int, int { + return b, a; +} +@ + +In this phase, a structure to return the two integers is generated using CAO +syntax. However, this will be directly mapped to C structures since it is not +a user defined CAO structure. + +@ +typedef sRes55 := struct[def c_sRes55_0 : int; + def c_sRes55_1 : int;]; + def c_swap(c_a : int, c_b : int) : sRes55 { + def c_CAO_t58 : sRes55; + c_CAO_t58.c_sRes55_0 := CAO_int_assign(c_b); + c_CAO_t58.c_sRes55_1 := CAO_int_assign(c_a); + return c_CAO_t58; +} +@ + +A call to the swap function: + +@ + n1, n2 := swap(m1, m2); +@ + +is transformed to + +@ + def c_CAO_t65 : sRes59; + c_CAO_t65 := c_swap(c_m1, c_m2); + c_n1 := CAO_int_assign(c_CAO_t65.c_sRes59_0); + c_n2 := CAO_int_assign(c_CAO_t65.c_sRes59_1); +@ + +-} + +module Language.CAO.Translation.PreC + ( cao2prec + , precStatement + , precAssignment + ) where + +import Control.Monad + +import Data.List (partition) + +import Language.CAO.Common.Fresh +import Language.CAO.Common.Literal +import Language.CAO.Common.Monad +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.State +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Language.CAO.Platform.Literals +import Language.CAO.Platform.Naming +import Language.CAO.Platform.Query +import Language.CAO.Platform.Specification + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils (type2TyDecl, typeOf, Typeable) + +import Language.CAO.Translation.Names + +import Language.CAO.Type +import Language.CAO.Type.Utils + +-- This module should: +-- * Replace CAO operations by calls to functions with the same name as in the backend +-- * Handle operation and function arguments accordingly with the specification of safety, +-- making copies whenever necessary +-- *_init and *_assign have to be safe. Otherwise, a copy would not solve the problem. +-- * Distinguish between values returned by value or by reference and create the necessary +-- structure declarations +-- * Replace calls to struct fields by integers +-- * ??? Replace CAO types by backend types??? +-- Safe operations by design: +-- *_init +-- *_assign +-- *_ref + +-------------------------------------------------------------------------------- +-- CaoAST + +cao2prec + :: CaoMonad m + => TranslationSpec -> Prog Var + -> m (Prog Var) +cao2prec tspec (Prog defs (Just ip)) = withPreCST $ do + (defs', fldDefs) <- concatMapAndUnzipM (precDefinition tspec) defs + -- The init procedure does not return any value, thus it is safe to ignore + -- the second value of 'precFunc' + (ip', _) <- precFunc tspec ip + return $ Prog defs' (Just (aux fldDefs ip')) + where + aux :: [FieldDef] -> Fun Var -> Fun Var + aux s f = f { funBody = s ++ funBody f } +cao2prec _ _ = internalError "cao2prec" "No init function" + +-------------------------------------------------------------------------------- +precDefinition + :: CaoMonad m + => TranslationSpec -> LDef Var + -> m ([LDef Var], [FieldDef]) +precDefinition tspec (L l d) = case d of + VarDef _ -> return (L l d : [], []) + FunDef fd -> do + (fd', structDecl) <- precFunc tspec fd + return (consMaybe structDecl $ L l (FunDef fd') : [], []) + TyDef td -> precTypeDef tspec l td + ConstDef _ -> return (L l d : [], []) + +-------------------------------------------------------------------------------- + +type FieldDef = LStmt Var +type StructResDecl = LDef Var + +precTypeDef + :: CaoMonad m + => TranslationSpec -> SrcLoc -> TyDef Var + -> m ([LDef Var], [FieldDef]) +precTypeDef tspec l (StructDecl sname lFlds) = liftM (mapFst (L l (TyDef $ TySynDef sname $ TySynD sname) : )) $ + globalOrInlinedField tspec + (liftM unzip $ zipWithSeqM auxGlobal lFlds) + (liftM (const ([], [])) $ zipWithSeqM auxInlined lFlds) + where + + auxGlobal :: CaoMonad m => Integer -> (Located Var, TyDecl Var) -> m (LDef Var, FieldDef) + auxGlobal fldIndex (nm, _) = do + nm' <- liftM (L (getLoc nm)) $ freshVar' Global (getSymbol (unLoc nm)) RInt + let decl = L l $ VarDef $ VarD nm' (type2TyDecl RInt) Nothing + assign <- fCallSAux tspec code_init (LVVar nm') [rintLit fldIndex] + return (decl, genLoc assign) + + auxInlined :: CaoMonad m => Integer -> (Located Var, TyDecl Var) -> m () + auxInlined fldIndex (nm, _) = putFieldProj (unLoc nm, fldIndex) + + +precTypeDef _ l t = return ([L l $ TyDef t], []) + +-------------------------------------------------------------------------------- +precFunc + :: CaoMonad m + => TranslationSpec -> Fun Var + -> m (Fun Var, Maybe StructResDecl) +precFunc tspec (Fun (L loc fn) args _ body) = do + resetPreCST + + let typ@(FuncSig ta _ c) = varType fn + + (rtype, sdef, rsdef) <- precReturnType tspec typ + let retD' = map type2TyDecl rtype + typ' = FuncSig ta (Tuple rtype) c + fn' = L loc $ setType typ' fn + putFunType fn typ' + + body' <- precBlocks tspec body + refV <- getRefVar + tmpvs <- getTmpVars + refV' <- mapMaybeM refVarDecl refV + + let body'' = insertTmps body' tmpvs + + return (Fun fn' args retD' (consMaybe refV' (consMaybe rsdef body'')), sdef) + + where + refVarDecl v = do + t <- freshVar' Global caoRef Bullet + return $ genLoc $ VDecl $ VarD (genLoc v) (TySynD (genLoc t)) Nothing + + insertTmps bd tmpvs = let + (dep, noDep) = partition (isDependent . varType) tmpvs + in insertAll (map varDecl' noDep) (map varDecl' dep) bd + + varDecl' = genLoc . VDecl . varDecl + + insertAll nodeps deps [] = nodeps ++ deps + insertAll [] deps (L l (Nop EndIndex) : sts) = L l (Nop EndIndex) : deps ++ sts + insertAll _ _ (L _ (Nop EndIndex) : _) = internalError "insertAll" "Not expected order" + insertAll nodeps deps (L l (Nop EndConsts) : sts) = L l (Nop EndConsts) : nodeps ++ insertAll [] deps sts + insertAll nodeps deps (s : sts) = s : insertAll nodeps deps sts + +precReturnType + :: CaoMonad m + => TranslationSpec -> Type Var + -> m ([Type Var], Maybe StructResDecl, Maybe ReturnStructDecl) +precReturnType tspec (FuncSig _ (fromTuple -> rtype) _) = do + (vtyp, rtyp) <- returnByValOrRef tspec rtype + (vtyp', sdecl, rsdecl) <- precByVal vtyp + return (consMaybe vtyp' rtyp, sdecl, rsdecl) + where + + precByVal :: CaoMonad m => [Type Var] -> m (Maybe (Type Var), Maybe StructResDecl, Maybe ReturnStructDecl) + precByVal [] = return (Nothing, Nothing, Nothing) + precByVal [t] = valOrRef tspec t + (return (Just t, Nothing, Nothing)) -- Single value variable returned directly + (returnStruct =<< newStructRes [t]) + precByVal typs = returnStruct =<< newStructRes typs + + returnStruct (t, sd) = do + (fv, sdecl) <- returnStructDecl tspec t + putRetStruct fv + return (Just t, Just sd, Just sdecl) +precReturnType _ _ = internalError + "precReturnType" "Unexpected function type." + +-------------------------------------------------------------------------------- +-- Handling structs to return results of functions + +type ReturnStructDecl = LStmt Var + +-- Returns a new struct with a field of each given typ +newStructRes + :: CaoMonad m + => [Type Var] + -> m (Type Var, StructResDecl) +newStructRes typs = do + uid <- uniqId + let tname = structRes ++ show uid + sname = mkGId (mkTvName tname) uid Bullet + sflds <- zipWithSeqM (newStructField tname sname) typs + let struct = Struct sname sflds + return ( struct + , genLoc $ TyDef $ StructDecl (genLoc sname) + (map (mapPair genLoc type2TyDecl) sflds)) + where + newStructField tname sname n typ = do + fld <- freshSFld (tname ++ "_" ++ show n) (SField sname typ) + return (fld, typ) + +-- Declares a new struct variable to return results +returnStructDecl + :: CaoMonad m + => TranslationSpec -> Type Var + -> m (Var, ReturnStructDecl) +returnStructDecl tspec typ@(Struct sname _) = do + (i, sn) <- freshSmb + let fv = mkCStruct sn i typ (typePrefix tspec) (getSymbol sname) + let decl = genLoc $ VDecl $ VarD (genLoc fv) (type2TyDecl typ) Nothing + return (fv, decl) +returnStructDecl _ _ = internalError "returnStructDecl" "Not expected case" + + +-------------------------------------------------------------------------------- + +precBlocks + :: CaoMonad m + => TranslationSpec -> [LStmt Var] + -> m [LStmt Var] +precBlocks tspec = concatMapM (precStatement tspec) + +precStatement + :: CaoMonad m + => TranslationSpec -> LStmt Var + -> m [LStmt Var] +precStatement tspec (L l (VDecl vd)) = + liftM (singleton . L l . VDecl) $ precVDecl tspec vd + +-- TODO: Constant declaration must be processed because of the change in Target +precStatement tspec (L l (CDecl cd)) = do + (cd', stmt) <- precCDecl tspec cd + return (L l (CDecl cd') : stmt) + +precStatement tspec (L l (Assign lv [L l' (TyE _ (FunCall (L lf fn) args))])) = do + Just ftyp <- getFunType fn + let fn' = L lf $ setType ftyp fn + (lv', decl, assign) <- precReturnLVal tspec lv ftyp + (args', stmts) <- safetyCopy tspec lv args + return $ decl ++ stmts ++ L l (Assign lv' [L l' (annTyE ftyp (FunCall fn' args'))]) : assign + +precStatement tspec (L l (Assign [lv] [ex])) = + precAssignment tspec l lv ex + +precStatement _ (L _ (Assign _ _)) = + internalError "precStatement" "Unexpected assignment case" + +precStatement tspec (L l (FCallS pn ex)) = do + (ex', stmts) <- safeOrUnsafeDefault tspec + (return (ex, [])) + (genUnsafeCopy tspec ex) + (return (ex, [])) --- There is no need to make a copy to make it arg + -- safe, because there is no result assignment since this is a + -- procedure + return $ stmts ++ [ L l $ FCallS pn ex' ] + +precStatement tspec (L l (Ret exps)) = do + precReturn tspec l exps + +precStatement tspec (L l (Ite ex ifBlock eBlock)) = do + ifBlock' <- precBlocks tspec ifBlock + eBlock' <- mapMaybeM (precBlocks tspec) eBlock + return [ L l $ Ite ex ifBlock' eBlock' ] + +precStatement tspec (L l (While ex whileBlock)) = do + whileBlock' <- precBlocks tspec whileBlock + return [ L l $ While ex whileBlock' ] + +precStatement tspec (L l (Seq i seqBlock)) = do + seqBlock' <- precBlocks tspec seqBlock + return [ L l $ Seq i seqBlock' ] + +precStatement _ (L l (Nop a)) = return [L l (Nop a)] + +{- +Note +The translation of 'if' and 'while' statements will use native C support. +Therefore, it is assumed that these operations are safe and do not need +previous copy of the values. +-} +-------------------------------------------------------------------------------- + +precReturnLVal + :: CaoMonad m + => TranslationSpec -> [LVal Var] -> Type Var + -> m ([LVal Var], [ReturnStructDecl], [LStmt Var]) +precReturnLVal tspec lvs (FuncSig _ (Tuple (ht:_)) _) = do + (vlv, rlv) <- returnByValOrRef tspec lvs + if null vlv then return (rlv, [], []) + else case ht of + typ@(Struct _ flds) -> do + (fv, decl) <- returnStructDecl tspec typ + assign <- zipWithM (aux fv) vlv flds + return (LVVar (genLoc fv) : rlv, [decl], assign) + _ -> return (vlv ++ rlv, [], []) + where + + aux fv lv (fld, _) = liftM genLoc $ + fCallSAux tspec code_init lv [genLoc $ annTyE (varType fld) $ StructProj (genLoc (annTyE (varType fv) (Var fv))) fld] +precReturnLVal _ _ _ = internalError + "precReturnLVal" "Unexpected case." + +precReturn + :: CaoMonad m + => TranslationSpec -> SrcLoc -> [TLExpr Var] + -> m [LStmt Var] +precReturn tspec loc exps = do + (val, ref) <- returnByValOrRef tspec exps + (val', stmt) <- precByVal val + return $ stmt ++ [ L loc $ Ret $ val' `consMaybe` ref ] + where + precByVal :: CaoMonad m => [TLExpr Var] -> m (Maybe (TLExpr Var), [LStmt Var]) + precByVal [] = return (Nothing, []) + precByVal [v] = + valOrRef tspec (typeOf v) + (return (Just v, [])) -- Single value variable returned directly + (liftM wrap $ precByVal' [v]) + precByVal vals = liftM wrap $ precByVal' vals + + wrap (a, b) = (Just a, b) + + precByVal' :: CaoMonad m => [TLExpr Var] -> m (TLExpr Var, [LStmt Var]) + precByVal' vals = do + Just fv <- getRetStruct + let Struct _ flds = varType fv + block <- zipWithM (\ (fld, _) ex -> do + sfld <- freshSFld (getSymbol fld) (varType fld) + case unLoc ex of + -- Init is safe because it takes constants + TyE t (Lit l) -> do + l' <- precLiteral tspec t l + liftM genLoc $ fCallSAux tspec code_init (LVStruct (LVVar (genLoc fv)) sfld) (map (L (getLoc ex) . TyE t . Lit) l') + -- Assign must be safe, otherwise the system would not be safe + TyE _ (Var _) -> liftM genLoc $ fCallSAux tspec code_assign (LVStruct (LVVar (genLoc fv)) sfld) [ex] + _ -> error "Not expected" + ) flds vals + return (genLoc $ annTyE (varType fv) $ Var fv, block) + +-------------------------------------------------------------------------------- +precAssignment + :: CaoMonad m + => TranslationSpec -> SrcLoc -> LVal Var -> TLExpr Var + -> m [LStmt Var] +precAssignment tspec loc lv ex = case lv of + LVVar (unLoc -> vid) -> assignSimpleLVal vid + LVStruct lv' fld -> do + fld' <- precField tspec fld + precSimpleAssign tspec loc lv' [ex, fld'] + LVCont _ lv' (VectP (CElem iexp)) + -> precSimpleAssign tspec loc lv' [ex, iexp] + LVCont _ lv' (VectP (CRange iexp jexp)) + -> precRangeAssign tspec loc code_range_set lv' [ex, iexp, jexp] + LVCont _ lv' (MatP (CElem ce) (CElem re)) + -> precSimpleAssign tspec loc lv' [ex, ce, re] + LVCont _ lv' (MatP (CRange ci cj) (CRange ri rj)) + -> precRangeAssign tspec loc code_range_set lv' [ex, ci, cj, ri, rj] + LVCont _ lv' (MatP (CRange lre rre) (CElem cole)) + -> precRangeAssign tspec loc code_row_range_set lv' [ex, cole, lre, rre] + LVCont _ lv' (MatP (CElem rowe) (CRange lce rce)) + -> precRangeAssign tspec loc code_col_range_set lv' [ex, rowe, lce, rce] + + where + + assignSimpleLVal vid = case unLoc ex of + TyE t (Lit l) -> do + l' <- precLiteral tspec t l + let ex' = map (L (getLoc ex) . TyE t . Lit) l' + let typ = typeOf ex + n <- cCall tspec code_init typ + return $ L loc (Assign [lv] [genLoc $ annTyE typ $ FunCall (genLoc n) ex' ]) : [] + + TyE _ (Var _) -> do + let typ = typeOf ex + n <- cCall tspec code_assign typ + return $ L loc (Assign [lv] [genLoc $ annTyE typ $ FunCall (genLoc n) [ex] ]) : [] + + TyE td (Cast _ _ ce) -> assignCast vid td ce + TyE _ (StructProj s f) -> do + f' <- precField tspec f + assignGeneral vid [s, f'] + _ -> assignGeneral vid (getArgExps ex) + + assignCast vid td ce = do + let typ = typeOf ce + n <- liftM (L (getLoc ex)) $ cCastCall tspec typ td + (ce', stmts) <- safetyCopy' tspec typ code_cast [vid] [ce] + return $ stmts ++ [ L loc $ Assign [lv] [L (getLoc ex) $ annTyE td $ FunCall n ce'] ] + + assignGeneral vid args = do + let fcode = codeOf $ unTyp $ unLoc ex + typ = typeOf $ head args + n <- cCall tspec fcode typ + (args', stmts) <- safetyCopy' tspec typ fcode [vid] args + return $ stmts ++ [ L loc $ Assign [lv] [L (getLoc ex) $ annTyE (typeOf lv) $ FunCall (genLoc n) args' ] ] + +{- +Note +Some operations have of the backend must be safe. Otherwise it would not +be possible to ensure the safety of the translation. These operations are: +* initialization -> code_init +* assignment -> code_assign +* reference extraction -> code_ref +* global references -> cGlobalRef +-} + +-- Precondition: the list is not empty +precRangeAssign + :: CaoMonad m + => TranslationSpec -> SrcLoc -> OpCode -> LVal Var -> [TLExpr Var] + -> m [LStmt Var] +precRangeAssign tspec loc op lv exps = do + (root, path) <- precLValue tspec lv + if null path + then simpleLVal root + else composedLVal root path + + where + simpleLVal (L rl root) = do + n1 <- cCall tspec op (typeOf lv) + (exps'', stmts) <- safetyCopy' tspec (typeOf lv) op [root] exps + return $ stmts ++ + assign (L rl root) n1 exps'' : [] + + composedLVal (L rl root) path = do + fv <- getRefVariable + let n1 = cGlobalRef (typePrefix tspec) -- [See Note] + n2 <- cCall tspec op (typeOf lv) + (exps', stmts) <- safeOfUnsafe tspec (typeOf lv) op + (return (exps, [])) + (genUnsafeCopy tspec exps) + (return (exps, [])) -- TODO: Is this a bug? + return $ stmts ++ + assign (genLoc fv) n1 (L rl (annTyE (varType root) (Var root)) : path ) : + assign (genLoc fv) n2 exps' : [] + + assign l fn exps' = L loc $ Assign [LVVar l] [genLoc $ annTyE (typeOf l) $ FunCall (genLoc fn) exps'] + +-- Precondition: the list is not empty +precSimpleAssign + :: CaoMonad m + => TranslationSpec -> SrcLoc -> LVal Var -> [TLExpr Var] + -> m [LStmt Var] +precSimpleAssign tspec loc lv exps@(ex:exps') = do + (root, path) <- precLValue tspec lv + if null path + then simpleLVal root + else composedLVal root path + + where + simpleLVal (L rl root) = bitsCase (typeOf lv) + (auxBits rl root) + (do fv <- getRefVariable + n1 <- cCall tspec code_ref (typeOf lv) -- [See Note] + let c1 = assign (genLoc fv) n1 $ L rl (annTyE (varType root) (Var root)) : exps' + c2 <- auxGen fv + return $ c1 : c2 : [] + ) + + composedLVal (L rl root) path = do + fv <- getRefVariable + let n1 = cGlobalRef (typePrefix tspec) -- [See Note] + bitsCase (typeOf lv) + (do let c1 = assign (genLoc fv) n1 $ L rl (annTyE (varType root) (Var root)) : path + c2 <- auxBits rl fv + return $ c1 : c2) + (do let c1 = assign (genLoc fv) n1 $ L rl (annTyE (varType root) (Var root)) : path ++ exps' + c2 <- auxGen fv + return $ c1 : c2 : []) + + auxBits rl lv' = do + n2 <- cCall tspec code_set (typeOf lv) + (exps'', stmts) <- safetyCopy' tspec (typeOf lv) code_set [lv'] exps + return $ stmts ++ assign (L rl lv') n2 exps'' : [] + + -- [See Note] + auxGen fv = do + (n2, ex') <- case unLoc ex of + TyE ty (Lit l) -> do + nn <- cCall tspec code_init ty + l' <- precLiteral tspec ty l + return (nn, map (L (getLoc ex) . TyE ty . Lit) l') + TyE _ (Var v) -> do + let ty = varType v + nn <- cCall tspec code_assign ty + return (nn, [ex]) + _ -> error "precGenericAssign" + return $ assign (genLoc fv) n2 ex' + + assign l fn exs = L loc $ Assign [LVVar l] [genLoc $ annTyE (typeOf l) $ FunCall (genLoc fn) exs] +precSimpleAssign _ _ _ _ = internalError "precSimpleAssign" "Not expected" + +-------------------------------------------------------------------------------- +-- This function takes as left value and returns its inner variable, +-- together with the complete path from the variable to the value. +precLValue + :: CaoMonad m + => TranslationSpec -> LVal Var + -> m (Located Var, [TLExpr Var]) +precLValue _ (LVVar (L l vid)) = return (L l vid, []) +precLValue tspec (LVStruct lv fld) = do + (e, lres) <- precLValue tspec lv + fld' <- precField tspec fld + return (e, lres ++ [fld']) +precLValue tspec (LVCont _ lv (VectP (CElem iexp))) = do + (e, lres) <- precLValue tspec lv + return (e, lres ++ [iexp]) +precLValue tspec (LVCont _ lv (MatP (CElem ce) (CElem re))) = do + (e, lres) <- precLValue tspec lv + return (e, lres ++ [ce, re]) +precLValue _ _ = + internalError "precLValue" "Not expected case" + +-------------------------------------------------------------------------------- +-- Only to split literals whenever needed +precVDecl + :: CaoMonad m + => TranslationSpec -> VarDecl Var + -> m (VarDecl Var) +precVDecl tspec (ContD loc typ exps) = + liftM (ContD loc typ) $ concatMapM aux exps + where + aux (L ll (TyE t (Lit l))) = + liftM (map (L ll . TyE t . Lit)) $ precLiteral tspec t l + aux v = return [v] +precVDecl _ vd = return vd + +-------------------------------------------------------------------------------- + +precCDecl + :: CaoMonad m + => TranslationSpec -> ConstDecl Var + -> m (ConstDecl Var, [LStmt Var]) +precCDecl tspec (ConstD (L l c) d (ConstInit e)) = do + stmt <- precAssignment tspec l (LVVar (L l c)) (annL (typeOf c) e) + return (ConstD (L l c) d None, stmt) +precCDecl _ cd = return (cd, []) + +------------------------------------------------------------------------------- +precField + :: CaoMonad m + => TranslationSpec -> Var + -> m (TLExpr Var) +precField tspec fld = globalOrInlinedField tspec + (return $ genLoc $ annTyE RInt $ Var $ setType RInt fld) + (do nfld <- lookupFieldProj fld + case nfld of + Just nfld' -> return $ rintLit nfld' + Nothing -> internalError "precField" "Field of structure not found") +------------------------------------------------------------------------------- +-- Getting the reference variable +getRefVariable :: CaoMonad m => m Var +getRefVariable = getRefVar >>= \mstr -> + case mstr of + Nothing -> do + (i, vn) <- freshSmb + let refV = mkCRef vn i caoRef + setRefVar refV + return refV + Just refV -> return refV + +------------------------------------------------------------------------------- +-- Literals +-- TODO: difference between signed and unsigned bits + +-- TODO: Somewhere before this phase, the size of the bit string is being +-- truncated without verification of the overflow. + +-- TODO: The chunk size has to be an exact divisor of the size of the type. +-- Otherwise, the is unreliable or unpredicatable. + +-- Is the current backend for HIACE handling negative numbers correctly? + +-- Integers are signed. Possible sign specification (signed/unsigned platform)? + +-- The typechecker verifies the validity (range) of mod and modpol literals +-- We only have to validate statically if the precision of the platform is enough +-- and possibly if the literal has to be split +precLiteral + :: CaoMonad m + => TranslationSpec -> Type Var -> Literal Var + -> m [Literal Var] +-- For boolean literals, it is assumed that literals cannot be split. +-- This should be added to the system documentation. +precLiteral tspec typ l = checkLiteral tspec typ + (return [l]) + (\ls -> case l of + -- This ensures that booleans are supported + BLit _ -> return [l] + ILit v -> do + l' <- checkILit ls v + return $ map ILit l' + -- TODO: signed/unsigned bit strings!! + BSLit s bits -> do + l' <- checkBSLit ls typ bits + return $ map (BSLit s) l' + PLit p -> do + l' <- checkPLit ls typ p + return $ map PLit l') + +------------------------------------------------------------------------------- +-- Argument copy + +-- Creates a copy of all variables in a list. This is used when the call to a function is +-- not safe, i.e., it may not preserve the contents of the arguments. +genUnsafeCopy + :: CaoMonad m + => TranslationSpec -> [TLExpr Var] + -> m ([TLExpr Var], [LStmt Var]) +genUnsafeCopy tspec = safeCopy (\ _ _ -> True) tspec [] + +-- Creates a copy of all variables which are in the specified list. This is used when the call to a +-- function is argument safe but it may have problems if a variable is simultaneously argument and +-- result. +genArgSafeCopy + :: CaoMonad m + => TranslationSpec -> [Var] -> [TLExpr Var] + -> m ([TLExpr Var], [LStmt Var]) +genArgSafeCopy = safeCopy elem + +safeCopy + :: CaoMonad m + => (Var -> [Var] -> Bool) -> TranslationSpec -> [Var] -> [TLExpr Var] + -> m ([TLExpr Var], [LStmt Var]) +safeCopy cond tspec lv exps = do + (e, stmt, vars) <- concatMap3M worker exps + mapM_ storeTmpVar vars + return (e, stmt) + where + worker :: CaoMonad m => TLExpr Var -> m (TLExpr Var, [LStmt Var], [Var]) + worker ex@(unLoc -> unTyp -> Var v) | cond v lv = do + let typ = varType v + n <- cCall tspec code_assign typ + (var, decl, vars) <- + ifM isDependent workerDepend workerNonDep typ + return ( genLoc $ annTyE typ $ Var var + , decl ++ [genLoc $ Assign [LVVar $ genLoc var] [genLoc $ annTyE typ $ FunCall (genLoc n) [ex]]] + , vars) + worker e = return (e, [], []) + + workerDepend typ = do + v <- freshVar Local typ + return (v, [genLoc $ VDecl $ varDecl v], []) + + workerNonDep typ = do + var <- freshTmpVar typ + return (var, [], [var]) + + + +safetyCopy + :: CaoMonad m + => TranslationSpec -> [LVal Var] -> [TLExpr Var] + -> m ([TLExpr Var], [LStmt Var]) +safetyCopy tspec lv ex = safeOrUnsafeDefault tspec + (return (ex, [])) + (genUnsafeCopy tspec ex) + (genArgSafeCopy tspec (getVars lv) ex) + +safetyCopy' + :: CaoMonad m + => TranslationSpec -> Type Var -> OpCode -> [Var] -> [TLExpr Var] + -> m ([TLExpr Var], [LStmt Var]) +safetyCopy' tspec typ fcode lv ex = safeOfUnsafe tspec typ fcode + (return (ex, [])) + (genUnsafeCopy tspec ex) + (genArgSafeCopy tspec lv ex) + +------------------------------------------------------------------------------- +-- Auxiliary + +-- Calls + +-- This function was changed to accept a list of expressions since literals can +-- be decomposed is several literal expressions to fit the platform representation +fCallSAux + :: CaoMonad m + => TranslationSpec -> OpCode -> LVal Var -> [TLExpr Var] + -> m (Stmt Var) +fCallSAux tspec op lv ex = do + -- This is the type to choose from the several libraries + let typ = typeOf $ head ex + n <- cCall tspec op typ + return $ Assign [lv] [genLoc $ annTyE typ $ FunCall (genLoc n) ex ] -- TODO: is this type annotation correct? + +cCall + :: CaoMonad m + => TranslationSpec -> OpCode -> Type Var + -> m Var +cCall tspec op typ = liftM (cFun op typ (callPrefix $ globalTransSpec tspec)) $ typeName tspec typ + +cCastCall + :: CaoMonad m + => TranslationSpec -> Type Var -> Type Var + -> m Var +cCastCall tspec typ typD = do + tname <- typeName tspec typ + tnameD <- typeName tspec typD + return $ cCast typ (callPrefix $ globalTransSpec tspec) tname tnameD + +returnByValOrRef + :: (CaoMonad m, Typeable a) + => TranslationSpec -> [a] + -> m ([a], [a]) +returnByValOrRef tspec = partitionM byVal + where + byVal e = valOrRefFuncReturn tspec (typeOf e) (return True) (return False) + +------------------------------------------------------------------------------- +bitsCase :: Type Var -> m a -> m a -> m a +bitsCase typ fb fe = case typ of + Bits _ _ -> fb + _ -> fe + +getVars :: [LVal Var] -> [Var] +getVars = map aux + where + aux (LVVar v) = unLoc v + aux _ = internalError "getVars" "Not expected case." +------------------------------------------------------------------------------- + +getArgExps :: TLExpr Var -> [TLExpr Var] +getArgExps ex = case unTyp $ unLoc ex of + Lit _ -> [ex] + StructProj s f -> [s, genLoc $ annTyE (varType f) $ Var f] + UnaryOp _ e -> [e] + BinaryOp _ l r -> [l, r] + Access e1 (VectP (CElem ei)) -> [e1, ei] + Access e1 (VectP (CRange ei ej)) -> [e1, ei, ej] + Access e1 (MatP (CElem ei) (CElem ej)) -> [e1, ei, ej] + Access e1 (MatP (CRange ei ej) (CRange ek el)) -> [e1, ei, ej, ek, el] + Access e1 (MatP (CRange ei ej) (CElem cole)) -> [e1, cole, ei, ej] + Access e1 (MatP (CElem rowe) (CRange ei ej)) -> [e1, rowe, ei, ej] + _ -> [] + +------------------------------------------------------------------------------- +moduleName :: String +moduleName = "" + +internalError :: String -> String -> a +internalError funcName msg = error $ + moduleName ++ ".<" ++ funcName ++ ">: " ++ msg + +varDecl :: Var -> VarDecl Var +varDecl v = VarD (genLoc v) (type2TyDecl (varType v)) Nothing + +rintLit :: Integer -> TLExpr Var +rintLit = genLoc . annTyE RInt . Lit . ILit diff --git a/src/Language/CAO/Translation/Yices.hs b/src/Language/CAO/Translation/Yices.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Translation/Yices.hs @@ -0,0 +1,64 @@ +{- +Module : $Header$ +Description : The Yices expression translation +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Translation.Yices + ( expr2Y + , cond2Y + , type2Y + ) where + +import Math.SMT.Yices.Syntax + +import Language.CAO.Index +import Language.CAO.Common.Var +import Language.CAO.Type + +cond2Y :: ICond Var -> ExpY +cond2Y ex = case ex of + IBool b -> LitB b + IBInd v -> VarE $ getSymbol v + INot e -> NOT $ cond2Y e + IAnd e -> AND $ map cond2Y e + IBoolOp op e1 e2 ->(bOp2Y op) [cond2Y e1, cond2Y e2] + ILeq e -> (LitI 0) :<= expr2Y e + IEq e -> (LitI 0) := expr2Y e + +expr2Y :: IExpr Var -> ExpY +expr2Y ex = case ex of + IInt n -> LitI n + IInd v -> VarE $ getSymbol v + ISum e -> aux e + IArith op e1 e2 -> (aOp2Y op) (expr2Y e1) (expr2Y e2) + ISym e -> LitI (-1) :*: expr2Y e + where + aux [e] = expr2Y e + aux (e:es) = (expr2Y e) :+: aux es + aux _ = error "" + +aOp2Y :: IAOp -> (ExpY -> ExpY -> ExpY) +aOp2Y IMinus = (:-:) +aOp2Y ITimes = (:*:) +aOp2Y IDiv = DIV -- TODO: Is this the correct division? +aOp2Y IModOp = MOD +aOp2Y _ = error "aOp2Y" +--Power + +bOp2Y :: IBOp -> ([ExpY] -> ExpY) +bOp2Y IOr = OR +bOp2Y _ = error "" +-- XOr + +type2Y :: Type id -> Maybe TypY +type2Y t = case t of + Bool -> return $ VarT "bool" + Int -> return $ VarT "int" + _ -> Nothing diff --git a/src/Language/CAO/Type.hs b/src/Language/CAO/Type.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Type.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +{- | +Module : $Header$ +Description : CAO internal type representation. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +This module constains the definition of data types which represent the +internal representation of CAO types. + +-} +module Language.CAO.Type where + +{- TODO - Notes: + - The Eq constraint in Type may have to be droped since syntactic equality is too + - weak to be used in dependent types + - + - The Show instance for expressions may lead to unreadable representations. Using + - pretty printing may solve this, but read instances may have to be changed to + - parsing functions + -} + +import Data.Foldable ( Foldable ) +import Data.Traversable ( Traversable ) + +import Language.CAO.Common.Literal (Sign) +import Language.CAO.Common.Outputable +import Language.CAO.Common.Polynomial + +import Language.CAO.Index + +-------------------------------------------------------------------------------- +-- * Type representation + +data Type id + -- | Arbitrary precision integers. These are mostly used for arithmetic + -- operation. + = Int + -- | Register integers (machine length integers). These are mostly used + -- for data type sizes, iteration (seq) indexes, access indexes, shift + -- and rotate. + | RInt + -- | Boolean values. + | Bool + -- | Bit strings with a sign and a given size. + | Bits !Sign (IExpr id) + -- | Modular types with an optional base type, an optional polynomial + -- variable and a polynomial expression. + -- Not all combinations are valid. Thus, we may have: + -- 1) @Mod Nothing Nothing ...@ + -- 2) ... + | Mod (Maybe (Type id)) (Maybe id) (Pol id) + -- | Vectors of a given size and type of elements. + | Vector (IExpr id) (Type id) + -- | Matrices with a given dimension and type of elements. + | Matrix (IExpr id) (IExpr id) (Type id) + -- | Type synonyms ... + | TySyn id (Type id) + -- | Function types: list of argument types, the return type and + -- a 'Class' classifier (pure, read-only or procedure). + | FuncSig [Type id] (Type id) (Class id) + -- | Structure type: ... + | Struct id [(id, Type id)] + -- | Struct field type: ... + | SField id (Type id) + -- | Polynomial variables?? + | Indet (Type id) + -- | Tupple of types. Used only internally. + | Tuple [Type id] + -- | No type. + | Bullet + -- | Type of symbolic constants: constant identifier, an optional invariant + -- and its type. + | Index id (Maybe (ICond id)) (Type id) + -- | Type of generic variables: must not occur after type checking. + | TyVar !TyVarId + -- | Type of integer variables + | IntVar !TyVarId + -- | Type of unknown modules + | ModVar !TyVarId + deriving (Show, Read, Eq, Functor, Foldable, Traversable) + +type TyVarId = Int + +instance PP id => PP (Type id) where + ppr = pprType + +pprType :: PP id => Type id -> CDoc +pprType Int + = text "int" +pprType RInt + = text "register" <+> text "int" +pprType Bool + = text "bool" +pprType (Bits s i) + = ppr s <+> text "bits" <> brackets (ppr i) +pprType (Mod Nothing Nothing (Pol [])) + = text "mod" <> brackets (char '*') +pprType (Mod Nothing Nothing (Pol [p])) + = text "mod" <> brackets (ppr p) +pprType (Mod (Just b) (Just i) p) + = text "mod" <> brackets ( ppr b <> char '<' <> ppr i + <> char '>' <> char '/' <> ppr p) +pprType (Vector i t) + = text "vector" <> brackets (ppr i) <+> text "of" <+> ppr t +pprType (Matrix r c t) + = text "matrix" <> ppr [r, c] <+> text "of" <+> ppr t +pprType (TySyn _ t) + = text "synonym" <+> text "to" <+> ppr t +pprType (FuncSig args ret clas) + = ppr (Tuple args) <+> text "->" <+> ppr ret <+> braces (ppr clas) +pprType (Struct sn flds) + = text "struct" <+> ppr sn <+> ifPprDebug ( text "@@Fields=" + <> noPprDebug (pprFlds flds) + <> text "@@" + ) +pprType (SField fn ty) + = text "field" <+> text "of" <+> text "struct" <+> + ppr fn <+> char ':' <+> ppr ty +pprType (Indet ty) + = text "indeterminate" <+> text "of" <+> ppr ty +pprType (Tuple tys) + = parens $ pprElems tys +pprType Bullet + = char '@' +pprType (Index i c t) + = ppr t <+> ifPprDebug ( text "forall @@Var=" + <> ppr i <> text "@@Cond=" + <> ppr c + ) +pprType (TyVar i) + = char '@' <> ppr i +pprType (IntVar i) + = text "i@" <> ppr i +pprType (ModVar i) + = text "mod" <> brackets (char '*' <> ppr i) +pprType _ + = text "??" + +pprFlds :: PP id => [(id, Type id)] -> CDoc +pprFlds = fsep . punctuate comma . map pprFld + +pprFld :: PP id => (id, Type id) -> CDoc +pprFld (n, ty) = ppr n <+> colon <+> ppr ty + +-------------------------------------------------------------------------------- +-- * Auxiliary definitions + +-- | Function classification (pure/read-only/procedure) +-- +data Class id + -- | Pure functions do not have side-effects. Every call with the same + -- arguments yields the same result. + = Pure + -- | Read-only functions access the global state but do not modify it. + -- Different calls with the same arguments may yield different results, + -- but the global values remain unchanged. + | RO + -- | Procedures access the global state and modify it as side-effect. + -- This constructor carries the list of written global variables. + | Proc [id] + deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) + +instance PP id => PP (Class id) where + ppr Pure = text "Pure" + ppr RO = text "ReadOnly" + ppr (Proc n) = text "Procedure" + <+> ifPprDebug (text "#Globals_Written" <> ppr n) diff --git a/src/Language/CAO/Type/Utils.hs b/src/Language/CAO/Type/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Type/Utils.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE PatternGuards #-} +{- | + Module : $Header$ + Description : CAO type representation utilities + Copyright : (c) SMART Team / HASLab + License : GPL + + Maintainer : Paulo Silva + Stability : experimental + Portability : non-portable + + This module defines utility function for the CAO type representation. +-} + +module Language.CAO.Type.Utils + ( isAlgebraic + , isBool + , isInt + , isBits + , isVar + , isNil + , isFunType + , isProc + , isTySyn + , isStruct + , isIndet + , isMod + , isModInt + , isModPol + , isVector + , isMatrix + , isIntExt + , isRInt + , isSimpleType + , isContainer + , sfType + , retType + , synType + , fieldType + , funClass + , getModulusBase + , extractBaseType + , extractBottomBaseType + , getStructName + , wVars + , getPoly + , maximumClass + , fromTuple + , toTuple + , innerType + , substTy + , getBVSize + , isDependent + ) where + +import Control.Arrow (second) + +import Data.List ( foldl' ) +import Data.Set ( Set ) +import qualified Data.Set as Set + +import Language.CAO.Common.Outputable +import Language.CAO.Common.Polynomial + +import Language.CAO.Index + +import Language.CAO.Type + +-------------------------------------------------------------------------------- +-- * Predicates over type representations +isAlgebraic :: Type id -> Bool +isAlgebraic (Index _ _ t) = isAlgebraic t +isAlgebraic Int = True +isAlgebraic RInt = True +isAlgebraic (Mod _ _ _) = True +isAlgebraic (Matrix _ _ t) = isAlgebraic t +isAlgebraic _ = False + +isBool :: Type id -> Bool +isBool Bool = True +isBool (Index _ _ n) = isBool n +isBool _ = False + +isInt :: Type id -> Bool +isInt Int = True +isInt RInt = True +isInt (Index _ _ n) = isInt n +isInt _ = False + +isIntExt :: Type id -> Bool +isIntExt (Index _ _ t) = isIntExt t +isIntExt Int = True +isIntExt t = isBits t + +isRInt :: Type id -> Bool +isRInt (Index _ _ t) = isRInt t +isRInt RInt = True +isRInt _ = False + +isBits :: Type id -> Bool +isBits (Bits _ _) = True +isBits _ = False + +isVar :: Type id -> Bool +isVar (FuncSig _ _ _) = False +isVar (SField _ _) = False +isVar (Indet _) = False +isVar (Tuple _) = False +isVar Bullet = False +isVar _ = True + +isNil :: Type id -> Bool +isNil Bullet = True +isNil (Tuple []) = True +isNil _ = False + +isFunType :: Type id -> Bool +isFunType (FuncSig _ _ _) = True +isFunType _ = False + +isProc :: Type id -> Bool +isProc (FuncSig _ _ (Proc _)) = True +isProc _ = False + +isTySyn :: Type id -> Bool +isTySyn (TySyn _ _) = True +isTySyn _ = False + +isStruct :: Type id -> Bool +isStruct (Struct _ _) = True +isStruct _ = False + +isIndet :: Type id -> Bool +isIndet (Indet _) = True +isIndet _ = False + +isMod :: Type id -> Bool +isMod (Mod _ _ _) = True +isMod _ = False + +isModInt :: Type id -> Bool +isModInt (Mod Nothing Nothing _) = True +isModInt _ = False + +isModPol :: Type id -> Bool +isModPol (Mod (Just _) _ _) = True +isModPol _ = False + +isVector :: Type id -> Bool +isVector (Vector _ _) = True +isVector _ = False + +isMatrix :: Type id -> Bool +isMatrix (Matrix _ _ _) = True +isMatrix _ = False + +isSimpleType :: Type id -> Bool +isSimpleType Int = True +isSimpleType RInt = True +isSimpleType Bool = True +isSimpleType (Bits _ _) = True +isSimpleType (Mod _ _ _) = True +isSimpleType _ = False + +isContainer :: Type id -> Bool +isContainer (Vector {}) = True +isContainer (Matrix {}) = True +isContainer (Struct {}) = True +isContainer _ = False + +-- Is a data type that may have dependencies +isDependent :: Type a -> Bool +isDependent t = case t of + Int -> False + RInt -> False + Bool -> False + _ -> True + +-------------------------------------------------------------------------------- +getStructName :: PP id => Type id -> id +getStructName (Struct v _) = v +getStructName t = error $ ".: unexpected type " + ++ showPprDebug t +funClass :: PP id => Type id -> Class id +funClass (FuncSig _ _ c) = c +funClass f = error $ ".: unexpected type " + ++ showPprDebug f + +retType :: PP id => Type id -> Type id +retType (FuncSig _ t _) = t +retType f = error $ ".: unexpected type " + ++ showPprDebug f + +synType :: PP id => Type id -> Type id +synType (TySyn _ t) = t +synType t = error $ ".: unexpected type " + ++ showPprDebug t + +fromTuple :: Type id -> [Type id] +fromTuple (Tuple t) = t +fromTuple t = [t] + +toTuple :: [Type id] -> Type id +toTuple [t] = t +toTuple t = Tuple t + +getPoly :: PP id => Type id -> Pol id +getPoly (Mod _ _ p) = p +getPoly t = error $ ".: unexpected type " + ++ showPprDebug t + +extractBaseType :: PP id => Type id -> Type id +extractBaseType (Mod (Just t) _ _) + = t +extractBaseType t + = error $ ".: unexpected type " + ++ showPprDebug t + +extractBottomBaseType :: Type id -> Type id +extractBottomBaseType m@(Mod Nothing Nothing _) + = m +extractBottomBaseType (Mod (Just t) _ _) + = extractBottomBaseType t +extractBottomBaseType _ + = error "extractBottomBaseType: not a Mod" + +getModulusBase :: Type id -> (IExpr id) +getModulusBase (Mod Nothing Nothing (Pol [Mon (CoefI c) EZero])) = c +getModulusBase m@(Mod _ _ _) = getModulusBase (extractBottomBaseType m) +getModulusBase _ = error "getModulusBase: not a Mod" + +maximumClass :: Ord id => [Class id] -> Class id +maximumClass [] + = Pure +maximumClass cls + | lst <- wVars cls, not (Set.null lst) = Proc $ Set.toList lst + | otherwise = maximum cls + +wVars :: Ord id => [Class id] -> Set id +wVars = foldl' goVs Set.empty + where + goVs acc (Proc wvs) = Set.union (Set.fromList wvs) acc + goVs acc _ = acc + +sfType :: PP id => Type id -> Type id +sfType (SField _ rt) = rt +sfType t = error $ ".: unexpected type " + ++ showPprDebug t + +fieldType :: (PP id, Eq id) => id -> Type id -> Type id +fieldType fi (TySyn _ ty) = fieldType fi ty +fieldType fi (Struct n flds) + | Just ty' <- lookup fi flds = ty' + | otherwise = error $ ".\ + \: unknown field " ++ showPprDebug fi ++ " of struct " ++ + showPprDebug n +fieldType _ ty = error $ ".\ + \: unexpected type " ++ showPprDebug ty + +innerType :: PP a => Type a -> [Type a] +innerType t = case t of + Vector _ t' -> [t'] + Matrix _ _ t' -> [t'] + Struct _ flds -> map snd flds + _ -> error $ + ".: unexpected case for type: " + ++ showPpr t + +substTy :: Type a -> (Type a, TyVarId) -> Type a +substTy Int _ = Int +substTy RInt _ = RInt +substTy Bool _ = Bool +substTy Bullet _ = Bullet +substTy (Bits sg e) _ = Bits sg e + +substTy t1@(TyVar v1) (t2, v2) + | v1 == v2 = t2 + | otherwise = t1 + +substTy (Mod mty mind pol) s = Mod (fmap (`substTy` s) mty) mind pol +substTy (Vector e t) s = Vector e $ substTy t s +substTy (Matrix e1 e2 t) s = Matrix e1 e2 $ substTy t s +substTy (TySyn sn t) s = TySyn sn $ substTy t s +substTy (FuncSig ts t c) s = FuncSig (map (`substTy` s) ts) (substTy t s) c +substTy (Struct sn flds) s = Struct sn $ map (second (`substTy` s)) flds +substTy (SField fn t) s = SField fn $ substTy t s +substTy (Indet t) s = Indet $ substTy t s +substTy (Tuple ts) s = Tuple $ map (`substTy` s) ts +substTy (Index vn mc t) s = Index vn mc $ substTy t s +substTy _ _ = error "" + +-------------------------------------------------------------------------------- +-- Waste + +getBVSize :: PP id => Type id -> IExpr id +getBVSize (Bits _ s) = s +getBVSize (Vector s _) = s +getBVSize t = error $ ".: unexpected type " + ++ showPprDebug t + diff --git a/src/Language/CAO/Typechecker.hs b/src/Language/CAO/Typechecker.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Typechecker.hs @@ -0,0 +1,705 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternGuards #-} + +{- | +Module : $Header$ +Description : CAO type checker. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +This module implements the typechecker of the CAO language. This follows the paper ... +-} + +module Language.CAO.Typechecker ( tcCaoAST ) where + +import Control.Applicative ( (<$>) ) +import Control.Monad + +import Data.List ( genericLength ) +import qualified Data.Set as Set + +import Language.CAO.Common.Error +import Language.CAO.Common.Literal +import Language.CAO.Common.Monad +import Language.CAO.Common.Polynomial hiding ((.*.), (.+.)) +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.State +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Language.CAO.Index + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils + +import Language.CAO.Type +import Language.CAO.Type.Utils + +import Language.CAO.Typechecker.Check +import Language.CAO.Typechecker.Constraint +import Language.CAO.Typechecker.Expr +import Language.CAO.Typechecker.Heap +import Language.CAO.Typechecker.Index +import Language.CAO.Typechecker.PostProcessor +import Language.CAO.Typechecker.Solver + +import Main.Flags (RunMode(..)) +-------------------------------------------------------------------------------- +--Typechecker +-------------------------------------------------------------------------------- + +{-# INLINE tcError' #-} +tcError' :: CaoMonad m => ErrorCode Var -> m a +tcError' a = tcError a + +--Typechecking Prog ------------------------------------------------------------ + +mapWithLoc :: CaoMonad m => (a -> m b) -> Located a -> m (Located b) +mapWithLoc f (L loc e) = setSrcLoc loc >> liftM (L loc) (f e) + +tcCaoAST :: CaoMonad m => RunMode -> Prog Name -> m (Prog Var, Heap) +tcCaoAST m ast = withTcST $ do + setMode m + ast' <- tcProg ast + h <- getHeap + return (ast', h) + +-- Prog ------------------------------------------------------------------------ + +tcProg :: CaoMonad m => Prog Name -> m (Prog Var) +tcProg (Prog defs _) = liftM2 Prog (mapM (mapWithLoc tcDef) defs) (return Nothing) + +-- Definition ------------------------------------------------------------------ + +tcDef :: CaoMonad m => Def Name -> m (Def Var) +tcDef (VarDef v) = VarDef . fst <$> tcVarDecl Global v +tcDef (ConstDef c) = ensureDepMode $ ConstDef <$> tcConstDecl Global c +tcDef (FunDef f) = FunDef <$> tcFunc f +tcDef (TyDef t) = TyDef <$> tcTypeDef t + +-- Func ------------------------------------------------------------------------ + +tcFunc :: CaoMonad m => Fun Name -> m (Fun Var) +tcFunc (Fun (L loc n) args rtype body) = keepGScope $ do + setSrcLoc loc + (args', ats) <- mapAndUnzipM tcArg args + (rtype', rt) <- tcTypeDecls rtype + (body', st, cc) <- tcStmts rt body + checkFuncReturn st rt + let tct = FuncSig ats rt cc + n' <- checkDecl Global tct n + return (Fun (L loc n') args' rtype' body') + +-- Arg ------------------------------------------------------------------------- + +tcArg :: CaoMonad m => Arg Name -> m (Arg Var, Type Var) + +tcArg (Arg (L loc v) td) = do + setSrcLoc loc + (td', tct) <- tcTypeDecl td + v' <- checkDecl Local tct v + return (Arg (L loc v') td', tct) + +tcArg (ArgConst (L loc c) td cond) = ensureDepMode $ do + setSrcLoc loc + (td', tct) <- tcIndexDecl td + c' <- checkConstDecl Local c tct Nothing + (cond', i') <- withCond cond + return (ArgConst (L loc c') td' cond', Index c' i' tct) + where + withCond Nothing = return (Nothing, Nothing) + withCond (Just cnd) = do + (cnd', i) <- tcICond cnd + addHypothesis [i] + return (Just cnd', Just i) + +--TypeDef ---------------------------------------------------------------------- + +tcTypeDef :: CaoMonad m => TyDef Name -> m (TyDef Var) +tcTypeDef (TySynDef (L loc n) d) = do + setSrcLoc loc + (st', t) <- tcTypeDecl d + n' <- checkTySyn n t + return (TySynDef (L loc n') st') +tcTypeDef (StructDecl ln@(L loc _) sfs) = do + setSrcLoc loc + (tds, tys) <- mapAndUnzipM tcStructFldDecl sfs + checkStructDecl ln (map fst sfs) tds tys + where + tcStructFldDecl :: CaoMonad m => (Located Name, TyDecl Name) -> m (TyDecl Var, Type Var) + tcStructFldDecl (L lc _, td) = setSrcLoc lc >> tcTypeDecl td + +--TypeDecl --------------------------------------------------------------------- + +tcTypeDecls :: CaoMonad m => [TyDecl Name] -> m ([TyDecl Var], Type Var) +tcTypeDecls = liftM (mapSnd toTuple) . mapAndUnzipM tcTypeDecl + +tcTypeDeclsL :: CaoMonad m => [LTyDecl Name] -> m ([LTyDecl Var], Type Var) +tcTypeDeclsL = liftM (mapSnd toTuple) . mapAndUnzipM (\ (L loc d) -> setSrcLoc loc >> liftM (mapFst (L loc)) (tcTypeDecl d)) + +tcTypeDecl :: CaoMonad m => TyDecl Name -> m (TyDecl Var, Type Var) +tcTypeDecl IntD = + return (IntD, Int) +tcTypeDecl RIntD = + return (RIntD, RInt) +tcTypeDecl BoolD = + return (BoolD, Bool) +tcTypeDecl (BitsD sign es) = do + (es', i) <- tcIExpr RInt es + checkBitsSize i + return (BitsD sign es', Bits sign i) +tcTypeDecl (ModD (ModNum eb)) = do + (eb', b) <- tcIExpr Int eb + checkModBase b + let tct = Mod Nothing Nothing $ Pol [Mon (CoefI b) EZero] + return (ModD (ModNum eb'), tct) +tcTypeDecl (ModD (ModPol td ti poly)) = do + (td', tct) <- tcTypeDecl td + checkMod tct + tcWarn (PolExtensionWarn poly) + when (isModInt tct) $ + tcWarn $ BaseExtensionWarn (getPoly tct) + (ti', poly', mpt) <- checkPolynomial tct ti poly + checkPolyLit poly mpt + return (ModD (ModPol td' ti' poly'), mpt) +tcTypeDecl (VectorD ei td) = do + (ei', i) <- tcIExpr RInt ei + checkVectorSize i + (td', tct) <- tcTypeDecl td + return (VectorD ei' td', Vector i tct) +tcTypeDecl (MatrixD er ec td) = do + (er', r) <- tcIExpr RInt er + (ec', c) <- tcIExpr RInt ec + checkMatrixSize r c + (td', tct) <- tcTypeDecl td + checkAlgebraic tct + let tct' = Matrix r c tct + return (MatrixD er' ec' td', tct') +tcTypeDecl (TySynD (L loc n)) = do + setSrcLoc loc + v <- checkScopeType n + return (TySynD (L loc v), synType $ varType v) + +-- Statement ------------------------------------------------------------------- + +-- XXX: The use of maximumClass in this way is not very efficient +tcStmts :: CaoMonad m => Type Var -> [LStmt Name] -> m ([LStmt Var], Type Var, Class Var) +tcStmts rt stmts = do + (s, t, c) <- fold3M (tcLStmt rt) (:) goTy (\ x y -> maximumClass [x, y]) ([], Bullet, Pure) stmts + s' <- cleanDeadCode s + return (s', t, c) + where + goTy :: Type Var -> Type Var -> Type Var + goTy Bullet t = t + goTy t _ = t + + +cleanDeadCode :: CaoMonad m => [LStmt id] -> m [LStmt id] +cleanDeadCode [] = return [] +cleanDeadCode (e@(L l (Ret _)) : r) = do + unless (null r) $ withSrcLoc l (tcWarn (DeadCodeReturn :: WarningCode Var)) + return [e] +cleanDeadCode (e : r) = liftM (e :) $ cleanDeadCode r + +tcLStmt :: CaoMonad m => Type Var -> LStmt Name -> m (LStmt Var, Type Var, Class Var) +tcLStmt rt (L loc stmt) = withSrcLoc loc $ do + (stmt', ty, c) <- tcStmt stmt rt + return (L loc stmt', ty, c) + +tcStmt :: CaoMonad m => Stmt Name -> Type Var -> m (Stmt Var, Type Var, Class Var) +tcStmt (VDecl vd) _ = do + (vd', c) <- tcVarDecl Local vd + return (VDecl vd', Bullet, c) +tcStmt (CDecl cd) _ = ensureDepMode $ do + cd' <- tcConstDecl Local cd + return (CDecl cd', Bullet, Pure) +tcStmt (Assign lvs es@[L fcl (TyE _ (FunCall (L nl n) exps))]) _ = do + v <- checkScopeFunc n + if isProc (varType v) + then tcProc lvs fcl nl v exps + else tcAssign lvs es +tcStmt (Assign lvs es) _ = + tcAssign lvs es +tcStmt (FCallS fid exps) _ = do + fid' <- checkScopeProc fid + let FuncSig pts frt (Proc wvars) = varType fid' + unless (isNil frt) $ tcError (BadUseException fid' ProcScope) + (exps', pts', cc, _) <- checkArgs exps pts + let wvars' = Set.toList $ wVars cc `Set.union` Set.fromList wvars + fid'' = setType (FuncSig pts' Bullet (Proc wvars)) fid' + return (FCallS fid'' exps', Bullet, Proc wvars') +tcStmt (Ret exps) rt = do + (exps'', ccs) <- checkMultipleAssign exps (fromTuple rt) + return (Ret exps'', rt, maximumClass ccs) +tcStmt (Ite cond istms Nothing) rt = do + (cond', c1) <- tcExpTyp cond Bool + (istms', _, c2) <- keepScope $ tcStmts rt istms + return (Ite cond' istms' Nothing, Bullet, maximumClass [c1, c2]) +tcStmt (Ite cond istms (Just estms)) rt = do + (cond', cb) <- tcExpTyp cond Bool + (istms', ist, cc1) <- keepScope $ tcStmts rt istms + (estms', est, cc2) <- keepScope $ tcStmts rt estms + return ( Ite cond' istms' (Just estms') + , if not ((isNil ist) || (isNil est)) then rt else Bullet + , maximumClass [cb, cc1, cc2] + ) +tcStmt (While cond wstms) rt = do + (cond', cb) <- tcExpTyp cond Bool + (wstms', _, cc) <- keepScope $ tcStmts rt wstms + return (While cond' wstms', Bullet, maximum [cb, cc]) +tcStmt (Seq (SeqIter ivar estart eend eby _) sstms) rt = do + (estart', start) <- tcIExpr RInt estart + (eend', end) <- tcIExpr RInt eend + (eby', by) <- tcBy eby + keepScope $ do + ivar' <- checkConstDecl Local ivar RInt Nothing + let i = IInd $ ivar' + (start', end') = if by > 0 then (start, end) else (end, start) + addHypothesis [start' .<=. i, i .<=. end'] + (sstms', sst, c) <- tcStmts rt sstms + return (Seq (SeqIter ivar' estart' eend' eby' (SimpleRng [])) sstms', sst, c) +tcStmt (Nop a) _ = return (Nop a, Bullet, Pure) + +tcBy :: CaoMonad m => Maybe (LExpr Name) -> m (Maybe (LExpr Var), Integer) +tcBy Nothing = return (Nothing, 1) +tcBy (Just eb) = do + (eby', rby) <- tcIExpr RInt eb + case rby of + IInt n + | n < 0 -> return (Just (L (getLoc eby') (Lit (ILit n))), n) + | n > 0 -> return (Just eby', n) + _ -> tcError' SeqRangeErr + +tcProc :: CaoMonad m => [LVal Name] + -> SrcLoc + -> SrcLoc + -> Var + -> [TLExpr Name] + -> m (Stmt Var, Type Var, Class Var) +tcProc lvs fcl loc fid es = do + (lvs', lvts, cc') <- tcLValues lvs + let FuncSig pts frt (Proc wvars) = varType fid + (es', pts', cc, s) <- checkArgs es pts + let wvars' = Set.toList $ wVars (cc ++ cc') `Set.union` (Set.fromList wvars) + frt' = applySubst s frt + fid' = setType (FuncSig pts' frt' (Proc wvars)) fid + expr = L fcl $ annTyE frt' $ FunCall (L loc fid') es' + sbs <- check (zipWith (.=?>.) (fromTuple frt') lvts) [] + let lvts' = case lvts of + [t] -> t + _ -> Tuple lvts + expr' = annotE sbs lvts' expr + return (Assign lvs' [expr'], Bullet, Proc wvars') + +tcAssign :: CaoMonad m => [LVal Name] -> [TLExpr Name] -> m (Stmt Var, Type Var, Class Var) +tcAssign lvs es = do + (lvs', tslvs, ca) <- tcLValues lvs + (es'', ccs) <- checkAssign es tslvs + return (Assign lvs' es'', Bullet, maximumClass (ccs ++ ca)) + +checkAssign :: CaoMonad m => [TLExpr Name] -> [Type Var] -> m ([TLExpr Var], [Class Var]) +checkAssign ets lvts + | length lvts > 1 && length ets == 1 = checkTupleAssign (head ets) lvts + | otherwise = checkMultipleAssign ets lvts + +checkTupleAssign :: CaoMonad m => TLExpr Name -> [Type Var] -> m ([TLExpr Var], [Class Var]) +checkTupleAssign es lvts = do + (es', tes, c, cnstr, tp) <- tcTLExpr es + let ets = fromTuple tes + unless (length lvts == length ets) $ tcError' $ CardinalityException $ AssignCardinalityException TupleAssign + sbs <- withSrcLoc (getLoc es) $ check (cnstr ++ (zipWith (.=?>.) ets lvts)) tp + let es'' = annotE sbs (toTuple lvts) es' + return ([es''], c) + +checkMultipleAssign :: CaoMonad m => [TLExpr Name] -> [Type Var] -> m ([TLExpr Var], [Class Var]) +checkMultipleAssign ets lvts + | length lvts == length ets = zipWithAndUnzipM tcExpTyp ets lvts + | otherwise = tcError' $ CardinalityException $ AssignCardinalityException MultipleAssign + +-- LValue ---------------------------------------------------------------------- + +tcLValues :: CaoMonad m => [LVal Name] -> m ([LVal Var], [Type Var], [Class Var]) +tcLValues = mapAndUnzip3M tcLValue + +tcLValue :: CaoMonad m => LVal Name -> m (LVal Var, Type Var, Class Var) +tcLValue (LVVar (L loc x)) = do + setSrcLoc loc + (v, c) <- checkScopeLVar x + return (LVVar (L loc v), varType v, c) +tcLValue (LVStruct lv fi) = do + (lv', lvt, c) <- tcLValue lv + fi' <- checkScopeSField lvt fi + return (LVStruct lv' fi', sfType $ varType fi', c) +tcLValue (LVCont _ lv pat) = do + (lv', lvt, c1) <- tcLValue lv + (pat', tct, c2, cnstr) <- tcAPat lvt pat + unless (null cnstr) $ tcError' $ UnknownErr "Non-empty constraints in a lvalue" + return (LVCont tct lv' pat', tct, maximumClass [c1, c2]) + +-- XXX: Check literals despite the mode +tcAPat :: CaoMonad m => Type Var -> APat Name -> m (APat Var, Type Var, Class Var, [Constraint]) +tcAPat lvt (VectP (CElem e)) = do + (e', mi, c) <- tcAccess e + (tct, cnstr) <- checkVBAccess lvt mi + return (VectP (CElem e'), tct, c, cnstr) +tcAPat lvt (VectP (CRange ei ej)) = do + (ei', i) <- tcIExpr RInt (unTypL ei) + (ej', j) <- tcIExpr RInt (unTypL ej) + (tct, cnstr) <- checkVBRange lvt i j + return (VectP (CRange (annL RInt ei') (annL RInt ej')), tct, Pure, cnstr) +tcAPat lvt (MatP (CElem ei) (CElem ej)) = do + (ei', mi, c1) <- tcAccess ei + (ej', mj, c2) <- tcAccess ej + (tct, cnstr) <- checkMAccess lvt (joinJust mi mj) + return (MatP (CElem ei') (CElem ej'), tct, maximumClass [c1,c2], cnstr) +tcAPat lvt (MatP (CRange ei ej) (CRange ek el)) = do + (ei', i) <- tcIExpr RInt (unTypL ei) + (ej', j) <- tcIExpr RInt (unTypL ej) + (ek', k) <- tcIExpr RInt (unTypL ek) + (el', l) <- tcIExpr RInt (unTypL el) + (tct, cnstr) <- checkMRange lvt i j k l + return (MatP (CRange (annL RInt ei') (annL RInt ej')) (CRange (annL RInt ek') (annL RInt el')), tct, Pure, cnstr) +tcAPat lvt (MatP (CElem ei) (CRange ek el)) = do + (ei', mi, c) <- tcAccess ei + (ek', k) <- tcIExpr RInt (unTypL ek) + (el', l) <- tcIExpr RInt (unTypL el) + (tct, cnstr) <- checkMRow lvt k l mi + return (MatP (CElem ei') (CRange (annL RInt ek') (annL RInt el')), tct, c, cnstr) +tcAPat lvt (MatP (CRange ek el) (CElem ei)) = do + (ei', mi, c) <- tcAccess ei + (ek', k) <- tcIExpr RInt (unTypL ek) + (el', l) <- tcIExpr RInt (unTypL el) + (tct, cnstr) <- checkMCol lvt k l mi + return (MatP (CRange (annL RInt ek') (annL RInt el')) (CElem ei'), tct, c, cnstr) + +tcAccess :: CaoMonad m => TLExpr Name -> m (TLExpr Var, Maybe (IExpr Var), Class Var) +tcAccess e = withStrictMode + (do (e', i) <- tcIExpr RInt (unTypL e) + return (annL RInt e', Just i, Pure)) + (do (e', c) <- tcExpTyp e RInt + return (e', Nothing, c)) + +-- VarDeclaration -------------------------------------------------------------- + +tcVarDecl :: CaoMonad m => Scope -> VarDecl Name -> m (VarDecl Var, Class Var) +tcVarDecl s (VarD (L loc x) b me) = do + (b', tct) <- tcTypeDecl b + (me', c) <- checkMExp tct me + setSrcLoc loc + x' <- checkDecl s tct x + return (VarD (L loc x') b' me', c) + where + checkMExp :: CaoMonad m => Type Var + -> Maybe (TLExpr Name) + -> m (Maybe (TLExpr Var), Class Var) + checkMExp _ Nothing = + return (Nothing, Pure) + checkMExp tct (Just e) = do + (e', cc) <- tcExpTyp e tct + return (Just e', cc) +tcVarDecl s (MultiD xs b) = do + (b', tct) <- tcTypeDecl b + xs' <- mapM (mapWithLoc (checkDecl s tct)) xs + return (MultiD xs' b', Pure) +tcVarDecl s (ContD (L loc x) b es) = do + (b', tct) <- tcTypeDecl b + it <- checkContainerInit tct (genericLength es) + (es'', ccs) <- zipWithAndUnzipM tcExpTyp es (repeat it) + setSrcLoc loc + x' <- checkDecl s tct x + return (ContD (L loc x') b' es'', maximumClass ccs) + +-- ConstDeclaration ------------------------------------------------------------ + +tcConstDecl :: CaoMonad m => Scope -> ConstDecl Name -> m (ConstDecl Var) +tcConstDecl s (ConstD (L loc x) b mo) = do + unless globalOrLocalDef $ tcError' $ UnknownErr "Symbolic constants without value are not allowed in local definitions." + (b', tct) <- tcIndexDecl b + setSrcLoc loc + (x', mo') <- checkMExp tct + return (ConstD (L loc x') b' mo') + where + globalOrLocalDef = case (s, mo) of + (Global, _) -> True + (Local, ConstInit _) -> True + _ -> False + + checkMExp :: CaoMonad m => Type Var -> m (Var, ConstAnn Var) + checkMExp tct = case mo of + None -> do + x' <- checkConstDecl s x tct Nothing + return (x', None) + ConstInit me -> do + (e, i) <- tcIExpr tct me + x' <- checkConstDecl s x tct (Just i) + return (x', ConstInit e) + ConstCond me -> do + x' <- checkConstDecl s x tct Nothing + e <- tcCond me + return (x', ConstCond e) + +tcConstDecl Global (MultiConstD xs b me) = do + (b', tct) <- tcIndexDecl b + xs' <- mapM (checkVs tct) xs + me' <- mapMaybeM tcCond me + return (MultiConstD xs' b' me') + where + checkVs :: CaoMonad m => Type Var -> Located Name -> m (Located Var) + checkVs tct (L loc x) = + setSrcLoc loc >> L loc <$> checkConstDecl Global x tct Nothing + +tcConstDecl Local (MultiConstD _ _ _) = + tcError' $ UnknownErr "Symbolic constants without value are not allowed in local definitions." + +tcCond :: CaoMonad m => LExpr Name -> m (LExpr Var) +tcCond e = do + (e', i) <- tcICond e + addHypothesis [i] + return e' + +-- Exp ------------------------------------------------------------------------- + +tcExpTyp :: CaoMonad m => TLExpr Name -> Type Var -> m (TLExpr Var, Class Var) +tcExpTyp e t = do + (e', et, c, cnstr, tp) <- tcTLExpr e + sbs <- withSrcLoc (getLoc e) $ check (cnstr ++ [et .=?>. t]) tp + let e'' = annotE sbs t e' + return (e'', maximumClass c) + +tcTLExpr :: CaoMonad m => TLExpr Name -> m (TLExpr Var, Type Var, [Class Var], [Constraint], [TypePred]) +tcTLExpr (L loc (TyE _ e)) = do + setSrcLoc loc + (e', tct, c, cnst, tp) <- tcExpr e + return (L loc (annTyE tct e'), tct, c, cnst, tp) + +-- Empty list means pure functions +tcExpr :: CaoMonad m => Expr Name -> m (Expr Var, Type Var, [Class Var], [Constraint], [TypePred]) + +tcExpr (Lit lit) = do + (lit', tct) <- tcLiteral lit + return (Lit lit', tct, [], [], []) + +tcExpr (Var x) = do + (x', c) <- checkScopeVar x + return (Var x', varType x', [c], [], []) + +tcExpr (FunCall (L loc fid) exps) = do + setSrcLoc loc + fid' <- checkScopeFunc fid + unless (nsFunName fid') $ tcError (ScopeException fid FuncScope) + let ft@(FuncSig pts frt c) = varType fid' + when (isProc ft) $ tcError (BadUseException fid' ProcScope) + (exps', pts', cs, s) <- checkArgs exps pts + let frt' = applySubst s frt + fid'' = setType (FuncSig pts' frt' c) fid' + return ( FunCall (L loc fid'') exps' + , frt' + , c:cs + , [], [] + ) + +tcExpr (StructProj sexp fi) = do + (sexp', sexpt, c, cnstr, tp) <- tcTLExpr sexp + fi' <- checkScopeSField sexpt fi + return ( StructProj sexp' fi' + , sfType $ varType fi' + , c + , cnstr, tp + ) + +tcExpr (UnaryOp op e) = tcUnaryExpr op e + +tcExpr (BinaryOp op e1 e2) = tcBinaryExpr op e1 e2 + +tcExpr (Access e1 pat) = do + (e1', et1, c1, cnstr1, tp1) <- tcTLExpr e1 + (pat', tct, c2, cnstrp) <- tcAPat et1 pat + return ( Access e1' pat' + , tct + , c2 : c1 + , cnstr1 ++ cnstrp + , tp1 + ) + +tcExpr (Cast b td e1) = do + (e1', et1, c, cnstr, tp) <- tcTLExpr e1 + (td', tct) <- tcTypeDeclsL td + return (Cast b td' e1', tct, c, cnstr ++ [et1 .=>>. tct], tp) + +tcUnaryExpr :: CaoMonad m => UOp -> TLExpr Name + -> m (Expr Var, Type Var, [Class Var], [Constraint], [TypePred]) +tcUnaryExpr op e = case op of + Sym -> do + tct <- TyVar <$> nextTyVarId + (e', et, c, cnstr, tp) <- tcTLExpr e + return (UnaryOp Sym e', tct, c, cnstr ++ [ToAlgebraic tct et], Algebraic tct : tp) + Not -> do + (e', et, c, cnstr, tp) <- tcTLExpr e + return (UnaryOp Not e', Bool, c, cnstr ++ [et .=?>. Bool], tp) + BNot -> do + (e', et, c, cnstr, tp) <- tcTLExpr e + return (UnaryOp BNot e', et, c, cnstr, BitsT et : tp) + +tcBinaryExpr :: CaoMonad m => BinOp Name -> TLExpr Name -> TLExpr Name + -> m (Expr Var, Type Var, [Class Var], [Constraint], [TypePred]) +tcBinaryExpr bop e1 e2 = case bop of + ArithOp op -> do + (e1', et1, c1, cnstr1, tp1) <- tcTLExpr e1 + (e2', et2, c2, cnstr2, tp2) <- tcTLExpr e2 + (tct, cnstr', tp') <- checkAOp op et1 et2 + return ( BinaryOp (ArithOp op) e1' e2' + , tct + , c1 ++ c2 + , cnstr1 ++ cnstr2 ++ cnstr' + , tp1 ++ tp2 ++ tp' + ) + CmpOp _ op -> do + (e1', et1, c1, cnstr1, tp1) <- tcTLExpr e1 + (e2', et2, c2, cnstr2, tp2) <- tcTLExpr e2 + tct <- nextTyVarId + let (cnstr, tct') = if isEqNeq op + then ([UnifiesC (TyVar tct) et1 et2], TyVar tct) + else ([et1 .=?>. IntVar tct, et2 .=?>. IntVar tct], IntVar tct) + return ( BinaryOp (CmpOp tct' op) e1' e2' + , Bool, c1 ++ c2 + , cnstr1 ++ cnstr2 ++ cnstr + , tp1 ++ tp2 + ) + BoolOp op -> do + (e1', et1, c1, cnstr1, tp1) <- tcTLExpr e1 + (e2', et2, c2, cnstr2, tp2) <- tcTLExpr e2 + return (BinaryOp (BoolOp op) e1' e2' + , Bool + , c1 ++ c2 + , cnstr1 ++ cnstr2 ++ [et1 .=?>. Bool, et2 .=?>. Bool] + , tp1 ++ tp2) + + BitOp op -> do + (e1', et1, c1, cnstr1, tp1) <- tcTLExpr e1 + (e2', et2, c2, cnstr2, tp2) <- tcTLExpr e2 + return ( BinaryOp (BitOp op) e1' e2' + , et1 -- Arbitrary choice (et1 == et2) + , c1 ++ c2 + , cnstr1 ++ cnstr2 ++ [et1 .=?=. et2] + , tp1 ++ tp2 + ) + + BitsSROp op -> do + (e1', et1, c1, cnstr1, tp1) <- tcTLExpr e1 + (e2', et2, c2, cnstr2, tp2) <- tcTLExpr e2 + return ( BinaryOp (BitsSROp op) e1' e2' + , et1 + , c1 ++ c2 + , cnstr1 ++ cnstr2 ++ [et2 .=?>. RInt] + , tp1 ++ tp2 ++ [BitsOrVector et1] + ) + + Concat -> do + (e1', et1, c1, cnstr1, tp1) <- tcTLExpr e1 + (e2', et2, c2, cnstr2, tp2) <- tcTLExpr e2 + tct <- TyVar <$> nextTyVarId + return (BinaryOp Concat e1' e2' + , tct + , c1 ++ c2 + , cnstr1 ++ cnstr2 ++ [Conc tct et1 et2] + , tp1 ++ tp2) + +-- Literal --------------------------------------------------------------------- + +-- XXX: Introduce signed literals +tcLiteral :: CaoMonad m => Literal Name -> m (Literal Var, Type Var) +tcLiteral (BLit b) = + return (BLit b, Bool) +tcLiteral (ILit i) = do + tvi <- IntVar <$> nextTyVarId + return (ILit i, tvi) +tcLiteral (BSLit sig val) = + return (BSLit sig val, Bits sig $ IInt $ genericLength val) +tcLiteral (PLit pol) = do + (pol', tct) <- tcPolynomial pol + return (PLit pol', tct) + +-- Polynomial ------------------------------------------------------------------ + +tcPolynomial :: CaoMonad m => Pol Name -> m (Pol Var, Type Var) +tcPolynomial (Pol ms) = do + (ms', mst, cnts) <- tcMonomials ms + tct <- TyVar <$> nextTyVarId + sbs <- check (UnifiesL tct mst : cnts) [] + let tct' = subst' sbs tct + return (Pol ms', tct') + +-- Monomial -------------------------------------------------------------------- + +tcMonomials :: CaoMonad m => [Mon Name] -> m ([Mon Var], [Type Var], [Constraint]) +tcMonomials = fold3M tcMonomial (:) (:) (++) ([], [], []) + +-- XXX: It is possible to check if the mod value is a valid one. +-- Something like 0 <= i' < mod(tct) +tcMonomial :: CaoMonad m => Mon Name -> m (Mon Var, Type Var, [Constraint]) +tcMonomial (Mon (CoefI i) EZero) = do + tct <- ModVar <$> nextTyVarId + i' <- wellFormedExpr i + return (Mon (CoefI i') EZero, tct, []) +tcMonomial (Mon (CoefI i) (MExpI n e)) = do + (n', tct) <- checkScopeInd n + i' <- wellFormedExpr i + return (Mon (CoefI i') (MExpI n' e), tct, []) +tcMonomial (Mon (CoefP p) EZero) = do + (p', tct) <- tcPolynomial p + return (Mon (CoefP p') EZero, tct, []) +tcMonomial (Mon (CoefP p) (MExpI n e))= do + (n', tct) <- checkScopeInd n + (p', pt) <- tcPolynomial p + return(Mon (CoefP p') (MExpI n' e), tct, [pt .=?>. extractBaseType tct]) + +-------------------------------------------------------------------------------- +-- Checking functions +-------------------------------------------------------------------------------- + +checkPolyLit :: CaoMonad m => Pol Name -> Type Var -> m () +checkPolyLit pol tp = do + (_, tct) <- tcPolynomial pol + _ <- check [tct .=?>. tp] [] + return () + +checkArgs :: CaoMonad m => [TLExpr Name] -> [Type Var] -> m ([TLExpr Var], [Type Var], [Class Var], [(Var, IExpr Var)]) +checkArgs [] [] = return ([], [], [], []) +checkArgs (e:exps) (ti:tis) = do + (e', te, c, s) <- checkArg e ti + (exps', tes, cs, ss) <- checkArgs exps (substAux s tis) + return (e':exps', te:tes, c:cs, maybe ss (:ss) s) + + where + -- XXX: inline this? + substAux s t = maybe t (\s' -> map (Language.CAO.Syntax.Utils.subst s') t) s +-- length exps == length pts +checkArgs _ _ = tcError' $ CardinalityException ParamsCardinalityException + +--TODO: Apply the substitution to the returned type +-- The callee function 'checkArgs' already applies the substitution to the expected type +checkArg :: CaoMonad m => TLExpr Name -> Type Var -> m (TLExpr Var, Type Var, Class Var, Maybe (Var, IExpr Var)) +checkArg e (Index v cond ti) = do -- TODO: How to improve this? + (e', c) <- tcExpTyp e ti + (_, i) <- tcIExpr ti (unTypL e) + let s = (v, i) + case cond of + Just cond' -> + valid [Language.CAO.Syntax.Utils.subst s cond'] (error "<>: Not satisfied condition") + _ -> return () + return (e', ti, c, Just s) + +checkArg e ti = do + (e', c) <- tcExpTyp e ti + return (e', ti, c, Nothing) + +-------------------------------------------------------------------------------- +-- TODO: Refactor to somewhere +applySubst :: [(Var, IExpr Var)] -> Type Var -> Type Var +applySubst [] t = t +applySubst (s:xs) t = applySubst xs (Language.CAO.Syntax.Utils.subst s t) + diff --git a/src/Language/CAO/Typechecker/Check.hs b/src/Language/CAO/Typechecker/Check.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Typechecker/Check.hs @@ -0,0 +1,386 @@ + +{-# LANGUAGE PatternGuards #-} + +{- | +Module : $Header$ +Description : +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Typechecker.Check ( + checkScopeDepIndex + , checkScopeInd + , checkScopeConst + , checkScopeConst' + , checkIndex + , checkScopeType + , checkScopeFunc + , checkScopeProc + , checkScopeVar + , checkScopeLVar + , checkScopeSField + + , checkFuncReturn + , checkPolynomial + , checkContainerInit + , checkAOp + + , checkDecl + , checkConstDecl + + , checkTySyn + , checkStructDecl + , checkBitsSize + , checkMod + , checkModBase + + , checkVectorSize + , checkMatrixSize + , checkAlgebraic + + , checkVBAccess + , checkVBRange + , checkMAccess + , checkMRange + , checkMRow + , checkMCol + + ) where + +import Control.Applicative ( (<$>) ) +import Control.Monad + +import Data.Maybe ( fromJust ) + +import Language.CAO.Common.Outputable (PP) + +import Language.CAO.Common.Error +import Language.CAO.Common.Monad +import Language.CAO.Common.Polynomial hiding ( (.*.) ) +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.State +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Language.CAO.Index +import Language.CAO.Index.Eval + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils + +import Language.CAO.Typechecker.Constraint +import Language.CAO.Typechecker.Expr +import Language.CAO.Typechecker.Heap +import Language.CAO.Typechecker.Solver + +import Language.CAO.Type +import Language.CAO.Type.Utils + +-------------------------------------------------------------------------------- +-- TODO: this functions are instances of the same schema +-- TODO: Some use containsXXX other lookupXXX but they are +-- the same thing... +genericCheck :: CaoMonad m => (Name -> Int -> Type Var -> Var) + -> (Heap -> Var -> Heap) + -> Type Var + -> Name + -> m Var +genericCheck f fh t x = getHeap >>= \ h -> do + checkContains h x + u <- newUniq + let v = f x u t + putHeap $ fh h v + return v + +checkContains :: CaoMonad m => Heap -> Name -> m () +checkContains h x = + when (containsName h x) $ tcError $ DeclException $ MultipleDeclException $ fromJust $ lookupName h x + +genericScope :: CaoMonad m => Name -> (Var -> m a) -> (Var -> m a) -> m a +genericScope x fGlobal fLocal = getHeap >>= \h -> + case lookupLocalName h x of + Nothing -> case lookupGlobalName h x of + Nothing -> tcError $ ScopeException x VarScope + Just v -> fGlobal v + Just v -> fLocal v + +checkGlobal :: (PP id, Show id, Read id, CaoMonad m) => Name -> (Var -> m a) -> ErrorCode id -> m a +checkGlobal x fjust err = getHeap >>= + maybe (tcError err) fjust . flip lookupGlobalName x + +varCheck :: CaoMonad m => (Var -> Bool) -> (Var -> a) -> Var -> m a +varCheck cond modifier = ifM cond (return . modifier) checkBadUse + +-------------------------------------------------------------------------------- + +checkDecl :: CaoMonad m => Scope -> Type Var -> Name -> m Var +checkDecl Local = genericCheck mkLId insertLocalName +checkDecl Global = genericCheck mkGId insertGlobalName + +checkConstDecl :: CaoMonad m => Scope -> Name -> Type Var -> Maybe (IExpr Var) -> m Var +checkConstDecl scope x t e = case scope of + Local -> genericCheck (mkConst mkLConst) insertLocalName t x + Global -> genericCheck (mkConst mkGConst) insertGlobalName t x + where + mkConst f x' u' t' = f x' u' t' e + +checkTySyn :: CaoMonad m => Name -> Type Var -> m Var +checkTySyn x t = genericCheck aux insertGlobalName t x + where + aux x' u' t' = let + v = mkGId x' u' tct + tct = TySyn v t' + in v + +-------------------------------------------------------------------------------- +checkStructDecl :: CaoMonad m => Located Name + -> [Located Name] + -> [TyDecl Var] + -> [Type Var] + -> m (TyDef Var) +checkStructDecl ln@(L loc n) flds tds tys = getHeap >>= \ h -> do + mapM_ (checkContains h . unLoc) $ ln:flds + u <- newUniq + us <- mapM (const newUniq) flds + let n' = mkGId n u t' + t' = TySyn n' $ Struct n' fts + flds' = map (\ (L lc vv, uu, tt) -> + L lc $ mkGId vv uu (SField n' tt)) vvuutt + fts = zip (map unLoc flds') tys + ftds = zip flds' tds + vvuutt = zip3 flds us tys + -- XXX: change to a strict version of foldl + putHeap $ foldl insertGlobalName h (n': map unLoc flds') + return (StructDecl (L loc n') ftds) + +checkPolynomial :: CaoMonad m => Type Var -> Name -> Pol Name -> m (Var, Pol Var, Type Var) +checkPolynomial td ti pol = getHeap >>= \ h -> + case lookupGlobalName h ti of + Nothing -> do + u <- newUniq + let v = mkGId ti u (Indet t) + t = Mod (Just td) (Just v) pol' + pol' = pol <|> ti ~> v + putHeap (insertGlobalName h v) + return (v, pol', t) + Just v -> do + let pol' = pol <|> ti ~> v + ty = Mod (Just td) (Just v) pol' + unless (varType v == Indet ty) $ tcError $ DeclException $ MultipleDeclException v + return (v, pol', ty) + +-------------------------------------------------------------------------------- +checkScopeVar :: CaoMonad m => Name -> m (Var, Class Var) +checkScopeVar xvar = genericScope xvar fGlobal fLocal + where + fGlobal v + | nsVar v = return (v, RO) + | indVar v = return (v, Pure) + | otherwise = checkBadUse v + fLocal v + | nsVar v = return (v, Pure) + | indVar v = return (v, Pure) + | otherwise = checkBadUse v + +checkScopeDepIndex :: CaoMonad m => Name -> m Var +checkScopeDepIndex ind = genericScope ind fIndex fIndex + where + fIndex = varCheck indVar id + +checkScopeLVar :: CaoMonad m => Name -> m (Var, Class Var) +checkScopeLVar lvar = genericScope lvar fGlobal fLocal + where + fGlobal = varCheck nsVar (split id (Proc . singleton)) + fLocal = varCheck nsVar (split id (const Pure)) + +-------------------------------------------------------------------------------- + +checkScopeConst' :: CaoMonad m => Name -> m (Maybe Integer) +checkScopeConst' cnst = getHeap >>= return . flip lookupConstName cnst + +checkScopeConst :: CaoMonad m => Name -> m Integer +checkScopeConst cnst = + getHeap >>= maybe (tcError (IntEvalErr :: ErrorCode Name)) return . flip lookupConstName cnst + +checkIndex :: CaoMonad m => Name -> (Var -> m a) -> (Var -> Integer -> m a) -> m a +checkIndex x fnothing fjust = do + x' <- checkScopeDepIndex x + mi <- checkScopeConst' $ varName x + maybe (fnothing x') (fjust x') mi + +-------------------------------------------------------------------------------- + +checkScopeType :: CaoMonad m => Name -> m Var +checkScopeType syn = checkGlobal syn + (varCheck (isTySyn . varType) id) + (ScopeException syn TypeScope) + +checkScopeProc :: CaoMonad m => Name -> m Var +checkScopeProc fid = checkGlobal fid + (varCheck (isProc . varType) id) + (ScopeException fid ProcScope) + +checkScopeFunc :: CaoMonad m => Name -> m Var +checkScopeFunc fid = checkGlobal fid + (varCheck nsFunName id) + (ScopeException fid FuncScope) + +checkScopeInd :: CaoMonad m => Name -> m (Var, Type Var) +checkScopeInd indx = checkGlobal indx + (\ t -> case varType t of + Indet ty -> return (t, ty) + _ -> checkBadUse t) + (ScopeException indx IndScope) + +checkScopeSField :: CaoMonad m => Type Var -> Name -> m Var +checkScopeSField (Struct sn1 _) fi = checkGlobal fi + (\ v -> case varType v of + SField sn2 _ | sn1 == sn2 -> return v + _ -> tcError $ ScopeException sn1 (SFieldScope fi)) + (ScopeException sn1 (SFieldScope fi)) +checkScopeSField st _ = tcError (WrongTypeException st StructType) + +-------------------------------------------------------------------------------- + +checkBadUse :: CaoMonad m => Var -> m a +checkBadUse x = tcError $ BadUseException x $ checkAux $ varType x + where + checkAux t + | isProc t = ProcScope + | isFunType t = FuncScope + | isVar t = VarScope + | isTySyn t = TypeScope + | isIndet t = IndetScope + | otherwise = GenericScope + +checkFuncReturn :: CaoMonad m => Type Var -> Type Var -> m () +checkFuncReturn t1 rt + = unless (not (isNil t1) || isNil rt) $ tcError (FuncReturnErr :: ErrorCode Var) + +checkContainerInit :: CaoMonad m => Type Var -> Integer -> m (Type Var) +checkContainerInit (Vector k it) n = do + valid [ k .==. IInt n ] $ CardinalityException $ InitCardinalityException VectorType + return it +checkContainerInit (Matrix u v it) n = do + checkAlgebraic it + valid [ (u .*. v) .==. IInt n ] $ CardinalityException $ InitCardinalityException VectorType + return it +checkContainerInit _ _ = tcError (ContainerInitErr :: ErrorCode Var) + +checkBitsSize :: CaoMonad m => IExpr Var -> m () +checkBitsSize s = valid [IInt 1 .<=. s] (DeclException (SizeDeclException s Nothing BitsType)) + +-- Precondition: The index arguments are reduced +checkVectorSize :: CaoMonad m => IExpr Var -> m () +checkVectorSize s = valid [ IInt 1 .<=. s ] (DeclException (SizeDeclException s Nothing VectorType)) + +-- Precondition: The index arguments are reduced +checkMatrixSize :: CaoMonad m => IExpr Var -> IExpr Var -> m () +checkMatrixSize r c = valid [ IInt 1 .<=. r, IInt 1 .<=. c ] (DeclException (SizeDeclException r (Just c) MatrixType)) + +checkModBase :: CaoMonad m => IExpr Var -> m () +checkModBase b = valid [IInt 2 .<=. b] (DeclException $ BaseDeclException b) + +-- By the standard, the bottom base type has to be a mod! +checkMod :: CaoMonad m => Type Var -> m () +checkMod t = unless (isMod t && isMod (extractBottomBaseType t)) $ tcError (WrongTypeException t ModType) + +-------------------------------------------------------------------------------- +-- TODO: The verification of accesses is very similar to the code of unification +checkMAccess :: CaoMonad m => Type Var -> Maybe (IExpr Var, IExpr Var) -> m (Type Var, [Constraint]) +checkMAccess (Matrix u v it) mi = do + cAccessM u v mi + return (it, []) +checkMAccess t mi = do + tid <- TyVar <$> nextTyVarId + return (tid, [MAccess tid t mi]) + +cAccessM :: CaoMonad m => IExpr Var -> IExpr Var -> Maybe (IExpr Var, IExpr Var) -> m () +cAccessM _ _ Nothing = return () +cAccessM u v (Just (i, j)) = + valid [IInt 0 .<=. i, i .<. u, IInt 0 .<=. j, j .<. v] $ UnknownErr "Checking strict access (matrix access)" + +checkMRange :: CaoMonad m => Type Var -> IExpr Var -> IExpr Var -> IExpr Var -> IExpr Var -> m (Type Var, [Constraint]) +checkMRange (Matrix u v it) i j k l = do + uu <- checkRange u i j (RangeException MatrixType) + vv <- checkRange v k l (RangeException MatrixType) + return (Matrix uu vv it, []) +checkMRange t i j k l = do + tid <- TyVar <$> nextTyVarId + return (tid, [MRange tid t i j k l]) + +checkMRow :: CaoMonad m => Type Var -> IExpr Var -> IExpr Var -> Maybe (IExpr Var) -> m (Type Var, [Constraint]) +checkMRow (Matrix v u it) i j ma = do + cAccessV v ma + vv <- checkRange u i j (RangeException MatrixType) + return (Matrix (IInt 1) vv it, []) +checkMRow t i j ma = do + tid <- TyVar <$> nextTyVarId + return (tid, [MRow tid t i j ma]) + +checkMCol :: CaoMonad m => Type Var -> IExpr Var -> IExpr Var -> Maybe (IExpr Var) -> m (Type Var, [Constraint]) +checkMCol (Matrix v u it) i j ma = do + cAccessV u ma + vv <- checkRange v i j (RangeException MatrixType) + return (Matrix vv (IInt 1) it, []) +checkMCol t i j ma = do + tid <- TyVar <$> nextTyVarId + return (tid, [MCol tid t i j ma]) + + +checkVBAccess :: CaoMonad m => Type Var -> Maybe (IExpr Var) -> m (Type Var, [Constraint]) +checkVBAccess (Bits s k) i = do + cAccessV k i + return (Bits s (IInt 1), []) +checkVBAccess (Vector k it) i = do + cAccessV k i + return (it, []) +checkVBAccess t1 i = do + tid <- TyVar <$> nextTyVarId + return (tid, [VBAccess tid t1 i]) + +cAccessV :: CaoMonad m => IExpr Var -> Maybe (IExpr Var) -> m () +cAccessV _ Nothing = return () +cAccessV k (Just i) = + valid [IInt 0 .<=. i, i .<. k] $ UnknownErr "Checking strict access (vector)" +checkVBRange :: CaoMonad m => Type Var -> IExpr Var -> IExpr Var -> m (Type Var, [Constraint]) +checkVBRange (Bits s k) i j = do + k' <- checkRange k i j (RangeException BitsType) + return (Bits s k', []) +checkVBRange (Vector k it) i j = do + k' <- checkRange k i j (RangeException VectorType) + return (Vector k' it, []) +checkVBRange t1 i j = do + tid <- TyVar <$> nextTyVarId + return (tid, [VBRange tid t1 i j]) + +checkRange :: CaoMonad m => IExpr Var -> IExpr Var -> IExpr Var -> ErrorCode Var -> m (IExpr Var) +checkRange u i j err = do + valid [j .<. u, i .<=. j, IInt 0 .<=. i] err + return $ evalExpr $ ISum [ j, ISym i, IInt 1 ] + +-------------------------------------------------------------------------------- +checkAOp :: CaoMonad m => AOp -> Type Var -> Type Var -> m (Type Var, [Constraint], [TypePred]) +checkAOp Times t1 t2 = do + tct <- TyVar <$> nextTyVarId + return (tct, [Mult tct t1 t2], [Algebraic tct]) +checkAOp Power t1 t2 = do + tct <- TyVar <$> nextTyVarId + return (tct, [Pow tct t1, t2 .=?>. Int], [Algebraic tct]) +checkAOp Div t1 t2 = do + tct <- TyVar <$> nextTyVarId + return (tct, [Unifies tct t1 t2], [IntOrMod tct]) +checkAOp ModOp t1 t2 = do + tct <- IntVar <$> nextTyVarId + return (tct, [t1 .=?>. tct, t2 .=?>. tct], []) +-- TODO: This does not work for operation on bit strings +checkAOp _ t1 t2 = do + tct <- TyVar <$> nextTyVarId + return (tct, [Unifies tct t1 t2], [Algebraic tct]) + diff --git a/src/Language/CAO/Typechecker/Constraint.hs b/src/Language/CAO/Typechecker/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Typechecker/Constraint.hs @@ -0,0 +1,145 @@ + +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +{- +Module : $Header$ +Description : Constraints +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable () + +-} + +module Language.CAO.Typechecker.Constraint ( + Constraint(..) + , Substitution(..) + , (.=?=.) + , (.=?>.) + , (.=>>.) + , subst + , subst' + , substSqrL + , substL + , remove + , substitution + ) where + +import Language.CAO.Common.Outputable hiding (equals) +import Language.CAO.Common.Var hiding (mrange) + +import Language.CAO.Index + +import Language.CAO.Type + +{- This may be of the form: + - two types must be equal + - two types must be coercible + - a predicate that a type(s) must meet + - an error to report the failure + + - two level constraints: + - type constrains are solved and index constraints are generated + - index constraints are solved +-} + +(.=?=.), (.=?>.), (.=>>.) :: Type Var -> Type Var -> Constraint +(.=?=.) t1 t2 = Equal t1 t2 +(.=?>.) t1 t2 = Coerces t1 t2 +(.=>>.) t1 t2 = Casts t1 t2 + +data Constraint + = Equal (Type Var) (Type Var) + | Coerces (Type Var) (Type Var) + | Unifies (Type Var) (Type Var) (Type Var) + | Casts (Type Var) (Type Var) + + | ToAlgebraic (Type Var) (Type Var) + + | Mult (Type Var) (Type Var) (Type Var) + | Pow (Type Var) (Type Var) + | Conc (Type Var) (Type Var) (Type Var) + | UnifiesL (Type Var) [Type Var] + | UnifiesC (Type Var) (Type Var) (Type Var) + + | MAccess (Type Var) (Type Var) (Maybe (IExpr Var, IExpr Var)) + | MRange (Type Var) (Type Var) (IExpr Var) (IExpr Var) (IExpr Var) (IExpr Var) + | MRow (Type Var) (Type Var) (IExpr Var) (IExpr Var) (Maybe (IExpr Var)) + | MCol (Type Var) (Type Var) (IExpr Var) (IExpr Var) (Maybe (IExpr Var)) + + | VBAccess (Type Var) (Type Var) (Maybe (IExpr Var)) + | VBRange (Type Var) (Type Var) (IExpr Var) (IExpr Var) + +instance Show Constraint where + show (Equal t1 t2) = showPpr t1 ++ " =?= " ++ showPpr t2 + show (Coerces t1 t2) = showPpr t1 ++ " =?> " ++ showPpr t2 + show (Unifies tu t1 t2) = showPpr t1 ++ " =^^=> " ++ showPpr t2 ++ " = " ++ showPpr tu + show (Casts t1 t2) = "(" ++ showPpr t1 ++ ")" ++ showPpr t2 + show (Mult tv t1 t2) = showPpr t1 ++ " * " ++ showPpr t2 ++ " = " ++ showPpr tv + show (Pow t1 t2) = showPpr t1 ++ " = ** " ++ showPpr t2 + show (Conc tv t1 t2) = showPpr t1 ++ " @ " ++ showPpr t2 ++ " = " ++ showPpr tv + show (UnifiesL tv tlst) = "[" ++ concatMap showPpr tlst ++ "] = " ++ showPpr tv + show (UnifiesC tu t1 t2) = showPpr t1 ++ " =^C^=> " ++ showPpr t2 ++ " = " ++ showPpr tu + show (ToAlgebraic tu t) = "toAlgebraic(" ++ showPpr t ++ ") = " ++ showPpr tu + show _ = "access" + +data Substitution = Subst Int (Type Var) + deriving Eq + +instance Show Substitution where + show (Subst n t2) = "@" ++ show n ++ " ==> " ++ showPpr t2 + +substitution :: [Substitution] -> [Constraint] -> [Constraint] +substitution [] c = c +substitution sb c = map (substL sb) c + +substL :: [Substitution] -> Constraint -> Constraint +substL sl c = foldr substC c sl + +substC :: Substitution -> Constraint -> Constraint +substC s (Equal t1 t2) = Equal (subst s t1) (subst s t2) +substC s (Coerces t1 t2) = Coerces (subst s t1) (subst s t2) +substC s (Unifies tu t1 t2) = Unifies (subst s tu) (subst s t1) (subst s t2) +substC s (Casts t1 t2) = Casts (subst s t1) (subst s t2) +substC s (ToAlgebraic t1 t2) = ToAlgebraic (subst s t1) (subst s t2) +substC s (Mult tu t1 t2) = Mult (subst s tu) (subst s t1) (subst s t2) +substC s (Pow t1 t2) = Pow (subst s t1) (subst s t2) +substC s (Conc tu t1 t2) = Conc (subst s tu) (subst s t1) (subst s t2) +substC s (UnifiesL t1 tlst) = UnifiesL (subst s t1) (map (subst s) tlst) +substC s (UnifiesC tu t1 t2) = UnifiesC (subst s tu) (subst s t1) (subst s t2) +substC s (MAccess t1 t2 mi) = MAccess (subst s t1) (subst s t2) mi +substC s (MRange t1 t2 i1 i2 i3 i4) = MRange (subst s t1) (subst s t2) i1 i2 i3 i4 +substC s (MRow t1 t2 i1 i2 mi) = MRow (subst s t1) (subst s t2) i1 i2 mi +substC s (MCol t1 t2 i1 i2 mi) = MCol (subst s t1) (subst s t2) i1 i2 mi +substC s (VBAccess t1 t2 mi) = VBAccess (subst s t1) (subst s t2) mi +substC s (VBRange t1 t2 i1 i2) = VBRange (subst s t1) (subst s t2) i1 i2 + +subst' :: [Substitution] -> Type Var -> Type Var +subst' s t = foldr subst t s + +subst :: Substitution -> Type Var -> Type Var +subst (Subst n' t) (IntVar n) | n == n' = t +subst (Subst n' t) (ModVar n) | n == n' = t +subst (Subst n' t) (TyVar n) | n == n' = t +subst s (Tuple ts) = Tuple $ map (subst s) ts +subst _ t = t + +remove :: TyVarId -> [Substitution] -> [Substitution] +remove tid = filter (\ (Subst n _) -> tid /= n) + +-- (active substitution list) (target substitution list) +substSqrL :: [Substitution] -> [Substitution] -> [Substitution] +substSqrL sbs = map (flip substSqr' sbs) + +-- (target substitution) (active substitution list) +substSqr' :: Substitution -> [Substitution] -> Substitution +substSqr' s = foldr substSqr s + +-- (active substitution) (target substitution) +substSqr :: Substitution -> Substitution -> Substitution +substSqr sbs (Subst n t) = Subst n (subst sbs t) + diff --git a/src/Language/CAO/Typechecker/Expr.hs b/src/Language/CAO/Typechecker/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Typechecker/Expr.hs @@ -0,0 +1,87 @@ + +{- | +Module : $Header$ +Description : Checks constraints over types +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Typechecker.Expr + ( Constraint(..) + , Substitution + , (.=?=.) + , (.=?>.) + , (.=>>.) + , check + , TypePred(..) + , subst' + , checkAlgebraic + ) where + +import Control.Monad + +import Language.CAO.Common.Error +import Language.CAO.Common.Monad +import Language.CAO.Common.Var + +import Language.CAO.Typechecker.Constraint +import Language.CAO.Typechecker.Solver +import Language.CAO.Typechecker.Unification + +import Language.CAO.Type +import Language.CAO.Type.Utils + +check :: CaoMonad m => [Constraint] -> [TypePred] -> m [Substitution] +check cnst tpred = case solve cnst of + Right (s, c) -> do + let s' = checkSubst s + evalCond s' tpred + v <- valid' c + unless v $ tcError (UnknownErr $ + ".: <>: condition: " ++ show c :: ErrorCode Var) + return s' + Left err -> tcError err + +data TypePred + = Algebraic (Type Var) + | AlgebraicExt (Type Var) + | FuncReturn (Type Var) (Type Var) -- Is this necessary in expressions? + | MatrixT (Type Var) + | BitsOrVector (Type Var) + | BitsT (Type Var) + | ModT (Type Var) + | IntOrMod (Type Var) + deriving Show + +checkSubst :: [Substitution] -> [Substitution] +checkSubst = map worker + where + worker (Subst t (IntVar _)) = Subst t Int + worker s = s + +evalCond :: CaoMonad m => [Substitution] -> [TypePred] -> m () +evalCond sbs = mapM_ aux + where + aux (Algebraic t) = checkAlgebraic $ subst' sbs t + aux (AlgebraicExt t) = let t' = subst' sbs t + in unless (isAlgebraic t' || isBits t') $ tcError (WrongTypeException t' AlgebraicType) + aux (FuncReturn t1 rt) = let t1' = subst' sbs t1; rt' = subst' sbs rt + in unless (not (isNil t1') || isNil rt') $ tcError (FuncReturnErr :: ErrorCode Var) + aux (MatrixT t) = let t' = subst' sbs t + in unless (isMatrix t') $ tcError (WrongTypeException t' MatrixType) + aux (BitsOrVector t) = let t' = subst' sbs t + in unless (isBits t' || isVector t') $ tcError (WrongTypeException t' BitsOrVectorType) + aux (BitsT t) = let t' = subst' sbs t + in unless (isBits t') $ tcError (WrongTypeException t' BitsType ) + aux (ModT t) = let t' = subst' sbs t + in unless (isMod t') $ tcError (WrongTypeException t' ModType ) + aux (IntOrMod t) = let t' = subst' sbs t + in unless (isMod t' || isInt t') $ tcError (WrongTypeException t' IntOrModType ) + +checkAlgebraic :: CaoMonad m => Type Var -> m () +checkAlgebraic t = unless (isAlgebraic t) $ tcError (WrongTypeException t AlgebraicType) diff --git a/src/Language/CAO/Typechecker/Heap.hs b/src/Language/CAO/Typechecker/Heap.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Typechecker/Heap.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE PatternGuards #-} +{- | +Module : $Header$ +Description : Heap for type checking. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +Heap for type checking. +-} + +module Language.CAO.Typechecker.Heap + ( Heap + , emptyHeap + , lookupGlobalName + , insertLocalName + , lookupName + , lookupLocalName + , containsName + , replaceGlobalHeap + , insertGlobalName + , insertConstName + , lookupConstName + , Name + , addHyp + , getHyp + , getIndexes + ) where + +import Control.Monad + +import Data.Map (Map) +import qualified Data.Map as Map + +import Language.CAO.Index + +import Language.CAO.Common.Var + +------------------------------------------------------------------------------- +-- Heap +------------------------------------------------------------------------------- + +-- Heap data type ------------------------------------------------------------- + +data Heap = Heap + { globalHeap :: Map Name Var + , localHeap :: Map Name Var + , constsHeap :: Map Name Integer + , hypothesis :: [ICond Var] + } + +-- Heap manipulation routines -------------------------------------------------- + +emptyHeap :: Heap +emptyHeap = Heap Map.empty Map.empty Map.empty [] + +containsName :: Heap -> Name -> Bool +containsName h x = containsLocalName h x || containsGlobalName h x + +lookupName :: Heap -> Name -> Maybe Var +lookupName h x = lookupLocalName h x `mplus` lookupGlobalName h x + +replaceGlobalHeap :: Heap -> Heap -> Heap +replaceGlobalHeap h nh = h { globalHeap = globalHeap nh } + +-- Global variables ----------------------------------------------------------- + +{-# INLINE containsGlobalName #-} +containsGlobalName :: Heap -> Name -> Bool +containsGlobalName h x = Map.member x (globalHeap h) + +{-# INLINE lookupGlobalName #-} +lookupGlobalName :: Heap -> Name -> Maybe Var +lookupGlobalName h v = Map.lookup v (globalHeap h) + +{-# INLINE insertGlobalName #-} +insertGlobalName :: Heap -> Var -> Heap +insertGlobalName h v = + h { globalHeap = Map.insert (varName v) v (globalHeap h) } + +-- Local variables ------------------------------------------------------------ + +{-# INLINE containsLocalName #-} +containsLocalName :: Heap -> Name -> Bool +containsLocalName h x = Map.member x (localHeap h) + +{-# INLINE lookupLocalName #-} +lookupLocalName :: Heap -> Name -> Maybe Var +lookupLocalName h v = Map.lookup v (localHeap h) + +{-# INLINE insertLocalName #-} +insertLocalName :: Heap -> Var -> Heap +insertLocalName h v = + h { localHeap = Map.insert (varName v) v (localHeap h) } + +-- Constants ------------------------------------------------------------------ + +{-# INLINE lookupConstName #-} +lookupConstName :: Heap -> Name -> Maybe Integer +lookupConstName h v = Map.lookup v (constsHeap h) + +{-# INLINE insertConstName #-} +insertConstName :: Heap -> Name -> Integer -> Heap +insertConstName h x a = h { constsHeap = Map.insert x a (constsHeap h)} + +-------------------------------------------------------------------------------- + +-- Hypothesis + +{-# INLINE addHyp #-} +addHyp :: Heap -> [ICond Var] -> Heap +addHyp h i = h { hypothesis = i ++ hypothesis h } + +{-# INLINE getHyp #-} +getHyp :: Heap -> [ICond Var] +getHyp = hypothesis + +getIndexes :: Heap -> [Var] +getIndexes h = filter indVar $ Map.elems (globalHeap h) ++ Map.elems (localHeap h) + diff --git a/src/Language/CAO/Typechecker/Index.hs b/src/Language/CAO/Typechecker/Index.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Typechecker/Index.hs @@ -0,0 +1,148 @@ + +{- | +Module : $Header$ +Description : Type checking indexes +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable +-} + +module Language.CAO.Typechecker.Index + ( tcIndexDecl + , tcICond + , tcIExpr + , wellFormedExpr + ) where + +import Control.Applicative ( (<$>) ) +import Control.Monad + +import Language.CAO.Common.Error +import Language.CAO.Common.Literal +import Language.CAO.Common.Monad +import Language.CAO.Common.SrcLoc +import Language.CAO.Common.State +import Language.CAO.Common.Utils +import Language.CAO.Common.Var + +import Language.CAO.Index +import Language.CAO.Index.Eval +import Language.CAO.Index.Utils +import Language.CAO.Syntax +import Language.CAO.Typechecker.Check +import Language.CAO.Typechecker.Expr +import Language.CAO.Typechecker.PostProcessor +import Language.CAO.Type +import Language.CAO.Type.Utils + +-------------------------------------------------------------------------------- +-- Type checking index declarations + +tcIndexDecl :: CaoMonad m => TyDecl Name -> m (TyDecl Var, Type Var) +tcIndexDecl IntD = return (IntD, Int) +tcIndexDecl RIntD = return (RIntD, RInt) +tcIndexDecl BoolD = return (BoolD, Bool) +tcIndexDecl _ = tcError (NotSupportedIndexTyp :: ErrorCode Var) +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- Conditions + +tcICond :: CaoMonad m => LExpr Name -> m (LExpr Var, ICond Var) +tcICond (L loc e) = + setSrcLoc loc >> mapPair (L loc) evalCond <$> tceICond' e + +tceICondTL :: CaoMonad m => TLExpr Name -> m (TLExpr Var, ICond Var) +tceICondTL (L loc (TyE _ e)) = withSrcLoc loc $ + mapFst (L loc . annTyE Bool) <$> tceICond' e + +tceICond' :: CaoMonad m => Expr Name -> m (Expr Var, ICond Var) +tceICond' (Lit (BLit b)) = + return (Lit (BLit b), IBool b) +tceICond' (Var x) = checkIndex x + (ifM (isBool . varType) (return . split Var IBInd) + (const $ tcError (NotSupportedIndexOp :: ErrorCode Var))) + (const $ const $ tcError (NotSupportedIndexOp :: ErrorCode Var)) +tceICond' (UnaryOp Not e) = + mapPair (UnaryOp Not) INot <$> tceICondTL e + +tceICond' (BinaryOp (CmpOp _ op) e1 e2) = do + (e1', i1, et1, c1) <- tieTL e1 + (e2', i2, et2, c2) <- tieTL e2 + tct <- TyVar <$> nextTyVarId + sbs <- check (c1 ++ c2 ++ [Unifies tct et1 et2]) [] + let tct' = subst' sbs tct + e1'' = annotE sbs tct' e1' + e2'' = annotE sbs tct' e2' + return (BinaryOp (CmpOp tct' op) e1'' e2'', (mapCOp op) i1 i2) + +tceICond' (BinaryOp (BoolOp op) e1 e2) = do + (e1', i1) <- tceICondTL e1 + (e2', i2) <- tceICondTL e2 + let i = case op of + And -> IAnd [i1, i2] + _ -> (mapBOp op) i1 i2 + return (BinaryOp (BoolOp op) e1' e2', i) + +tceICond' _ = tcError (NotSupportedIndexOp :: ErrorCode Var) + +-------------------------------------------------------------------------------- +-- Expressions + +tcIExpr :: CaoMonad m => Type Var -> LExpr Name -> m (LExpr Var, IExpr Var) +tcIExpr tpr (L loc e) = + setSrcLoc loc >> mapPair (L loc) evalExpr <$> topTie tpr e + +topTie :: CaoMonad m => Type Var -> Expr Name -> m (Expr Var, IExpr Var) +topTie tpr e = do + (e', i, t, c) <- tie e + sbs <- check (c ++ [t .=?>. tpr]) [] + let e'' = unTyp $ unLoc $ annotE sbs tpr $ genLoc $ annTyE t e' + return (e'', i) + +tieTL :: CaoMonad m => TLExpr Name -> m (TLExpr Var, IExpr Var, Type Var, [Constraint]) +tieTL (L loc (TyE _ e)) = withSrcLoc loc $ do + (e', i, t, c) <- tie e + return (L loc (annTyE t e'), i, t, c) + +tie :: CaoMonad m => Expr Name -> m (Expr Var, IExpr Var, Type Var, [Constraint]) +tie (Lit (ILit i)) = do + tid <- IntVar <$> nextTyVarId + return (Lit (ILit i), IInt i, tid, []) +tie (Var x) = do + (x', i) <- checkIndex x + (ifM (isInt . varType) + (\ x' -> return $ maybe (x', IInd x') (curry id x') $ indConst x') + (const $ tcError (NotSupportedIndexOp :: ErrorCode Name))) + (return .$. curry (mapSnd IInt)) + return (Var x', i, varType x', []) +tie (BinaryOp (ArithOp op) e1 e2) = do + (e1', i1, et1, c1) <- tieTL e1 + (e2', i2, et2, c2) <- tieTL e2 + tct <- TyVar <$> nextTyVarId + let iexp = case op of + Plus -> ISum [i1, i2] + _ -> (mapAOp op) i1 i2 + cnst = [Unifies tct et1 et2] + return (BinaryOp (ArithOp op) e1' e2', iexp, tct, c1 ++ c2 ++ cnst) +tie (UnaryOp Sym e) = do + (e', i, et, c) <- tieTL e + return (UnaryOp Sym e', ISym i, et, c) + +tie _ = tcError (NotSupportedIndexOp :: ErrorCode Name) + +-------------------------------------------------------------------------------- +wellFormedExpr :: CaoMonad m => IExpr Name -> m (IExpr Var) +wellFormedExpr = liftM evalExpr . worker + where + worker ie = case ie of + IInt n -> return $ IInt n + IArith op i1 i2 -> liftM2 (IArith op) (worker i1) (worker i2) + ISym i -> ISym <$> worker i + ISum l -> ISum <$> mapM worker l + IInd _ -> return (undefined) -- TODO: verify if it is in environment + +-------------------------------------------------------------------------------- + diff --git a/src/Language/CAO/Typechecker/PostProcessor.hs b/src/Language/CAO/Typechecker/PostProcessor.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Typechecker/PostProcessor.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : $Header$ +Description : AST Post processor. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +Post processes the CAO AST after type checking, introducing explicit casts +when coercions are used. +-} + +module Language.CAO.Typechecker.PostProcessor ( annotE ) where + +import Language.CAO.Typechecker.Constraint + +import Language.CAO.Syntax +import Language.CAO.Syntax.Utils + +import Language.CAO.Type +import Language.CAO.Type.Utils + +import Language.CAO.Common.Var +import Language.CAO.Common.SrcLoc + +-------------------------------------------------------------------------------- + +annotE :: [Substitution] -> Type Var -> TLExpr Var -> TLExpr Var +annotE sbs tr (L loc (TyE ta l@(Lit _))) = let + ta' = subst' sbs ta + in checkCoerce (L loc $ TyE ta' l) ta' tr +annotE sbs tr (L loc (TyE ta e@(Var _))) = let + ta' = subst' sbs ta + in checkCoerce (L loc $ TyE ta' e) ta' tr +annotE sbs tr (L loc (TyE ta (FunCall fn es))) = let + ta' = subst' sbs ta + FuncSig pts _ _ = typeOf fn + es' = zipWith (annotE sbs) pts es + in checkCoerce (L loc $ TyE ta' $ FunCall fn es') ta' tr +-- A projection is always applied to a structure. +-- There are no coercions, unifications or casts inside strutures. +-- Structures are not algebraic types and cannot be used inside matrices +-- The expression 'se' can only be a struct or a path inside vectors or other +-- structures. +-- Conjecture: there are no undefined annotations inside the path to a structure +annotE sbs tr (L loc (TyE ta e@(StructProj _ _))) = let + ta' = subst' sbs ta + in checkCoerce (L loc $ TyE ta' e) ta' tr +annotE sbs tr (L loc (TyE ta (UnaryOp op e1))) = let + ta' = subst' sbs ta + e1' = annotE sbs ta' e1 + in checkCoerce (L loc $ TyE ta' $ UnaryOp op e1') ta' tr +annotE sbs tr (L loc (TyE ta (BinaryOp op e1 e2))) = let + ta' = subst' sbs ta + (e1', e2') = annotOp op sbs ta' e1 e2 + in checkCoerce (L loc $ TyE ta' $ BinaryOp op e1' e2') ta' tr +annotE sbs tr (L loc (TyE ta (Access e p))) = let + ta' = subst' sbs ta + e' = annotAccess sbs ta' e (isRange p) + in checkCoerce (L loc $ TyE ta' $ Access e' p) ta' tr +-- XXX: type is being ignored +annotE sbs _ (L loc (TyE ta (Cast b td e))) = let + ta' = subst' sbs ta + te = subst' sbs (typeOf e) + e' = annotE sbs te e + in case checkCoerce e' te ta' of + -- Additional implicit casts may be needed + -- Maintains the original cast external occurrence + L _ (TyE _ (Cast _ _ e'')) -> L loc $ TyE ta' $ Cast b td e'' + -- The cast was not necessary (casting the type to itself) + e'' -> e'' + +-------------------------------------------------------------------------------- +annotOp :: BinOp Var -> [Substitution] -> Type Var -> TLExpr Var -> TLExpr Var -> (TLExpr Var, TLExpr Var) +annotOp (ArithOp Power) sbs tr e1 e2 = let + e1' = annotE sbs tr e1 + e2' = annotE sbs Int e2 + in (e1', e2') +annotOp (ArithOp Times) sbs tr e1 e2 = let + t1 = subst' sbs $ typeOf e1 + t2 = subst' sbs $ typeOf e2 + in case (t1, t2) of + (Matrix s1 s2 _, Matrix s2' s3 _) -> let + Matrix _ _ tr' = tr + e1' = annotE sbs (Matrix s1 s2 tr') e1 + e2' = annotE sbs (Matrix s2' s3 tr') e2 + in (e1', e2') + _ -> let + e1' = annotE sbs tr e1 + e2' = annotE sbs tr e2 + in (e1', e2') +annotOp (CmpOp ty _) sbs Bool e1 e2 = let + tr = subst' sbs ty + e1' = annotE sbs tr e1 + e2' = annotE sbs tr e2 + in (e1', e2') +annotOp (CmpOp _ _) _ _ _ _ = error ".: Unexpected case for compare operations" +annotOp (BitsSROp _) sbs tr e1 e2 = let + e1' = annotE sbs tr e1 + e2' = annotE sbs RInt e2 + in (e1', e2') +annotOp Concat sbs tr e1 e2 = case tr of + -- Concatenation of bit strings does not imply any coercion + Bits _ _ -> let + t1 = subst' sbs $ typeOf e1 + t2 = subst' sbs $ typeOf e2 + e1' = annotE sbs t1 e1 + e2' = annotE sbs t2 e2 + in (e1', e2') + Vector _ t -> let + -- Maintain the sizes of the expected vector types + Vector k1 _ = subst' sbs $ typeOf e1 + Vector k2 _ = subst' sbs $ typeOf e2 + e1' = annotE sbs (Vector k1 t) e1 + e2' = annotE sbs (Vector k2 t) e2 + in (e1', e2') + _ -> error ".: Unexpected case for concat" +annotOp _ sbs tr e1 e2 = let + e1' = annotE sbs tr e1 + e2' = annotE sbs tr e2 + in (e1', e2') + +-------------------------------------------------------------------------------- +-- In this function, we have to distinguish the cases of accesses to individual +-- elements, from the case of ranges. +annotAccess :: [Substitution] -> Type Var -> TLExpr Var -> Bool -> TLExpr Var +annotAccess sbs tr e isRng = case subst' sbs (typeOf e) of + t@(Bits _ _) -> annotE sbs t e + Vector k _ -> annotE sbs (Vector k tr') e + Matrix i j _ -> annotE sbs (Matrix i j tr') e + _ -> error ".: Unexpected case for an access" + where + tr' = if isRng then head (innerType tr) else tr + +-------------------------------------------------------------------------------- +checkCoerce :: TLExpr Var -> Type Var -> Type Var -> TLExpr Var +checkCoerce e tct tct' + | tct == tct' = e + | isModInt tct && isModInt tct' = + let e' = addCoerce e Int + in checkCoerce e' Int tct' + | isModInt tct && isBits tct' = + let e' = addCoerce e Int + in checkCoerce e' Int tct' + | isBits tct && isMod tct' = + let e' = addCoerce e Int + in checkCoerce e' Int tct' + | isInt tct && isModPol tct' = + let bas = extractBottomBaseType tct' + e' = addCoerce e bas + in checkCoerce e' bas tct' + | isMod tct && isModPol tct' && extractBaseType tct' /= tct = + let bas = extractBaseType tct' + e' = addCoerce e bas + in checkCoerce e' bas tct' + | otherwise + = addCoerce e tct' + +-------------------------------------------------------------------------------- +addCoerce :: TLExpr Var -> Type Var -> TLExpr Var +addCoerce e tct' = let + tct = case tct' of + Tuple tpl -> map (L genSrcLoc . type2TyDecl) tpl + _ -> [L genSrcLoc $ type2TyDecl tct'] + in L genSrcLoc $ annTyE tct' $ Cast False tct e + +-------------------------------------------------------------------------------- diff --git a/src/Language/CAO/Typechecker/SMT.hs b/src/Language/CAO/Typechecker/SMT.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Typechecker/SMT.hs @@ -0,0 +1,71 @@ + +{- +Module : $Header$ +Description : Interface with a SMT solver (Yices). +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Typechecker.SMT ( + checkValidity + ) where + +import Control.Monad.Trans + +import Math.SMT.Yices.Pipe +import Math.SMT.Yices.Syntax + +import Language.CAO.Common.Error +import Language.CAO.Common.Monad +import Language.CAO.Common.SrcLoc (defSrcLoc) +import Language.CAO.Common.State +import Language.CAO.Common.Var + +import Language.CAO.Index + +import Language.CAO.Translation.Yices + +import Language.CAO.Type + +import Language.CAO.Typechecker.Heap + +checkValidity :: CaoMonad m => ICond Var -> ICond Var -> m Bool +checkValidity hyp prop = do + decl <- getDecl + yices <- getYices + case yices of + Nothing -> do + caoWarning defSrcLoc $ NoProverWarning prop + return True + Just yices' -> do + r <- liftIO $ validity yices' decl (cond2Y hyp :=> cond2Y prop) + return $ either (const False) (const True) r + +getDecl :: CaoMonad m => m [CmdY] +getDecl = getHeap >>= return . map worker . getIndexes + where + worker v = case varType v of + Int -> DEFINE (getSymbol v, VarT "int") Nothing + RInt -> DEFINE (getSymbol v, VarT "int") Nothing + Bool -> DEFINE (getSymbol v, VarT "bool") Nothing + _ -> error "getDecl: not defined" + +validity :: FilePath -> [CmdY] -> ExpY -> IO (Either String ()) +validity yices decls prop = do + res <- runYices yices (decls ++ [ASSERT (NOT prop)]) + return $ case res of + Sat c -> Left $ "Assertion failed:\n" ++ show prop + ++ "\nCounter example:\n" ++ concatMap show c + Unknown c -> Left $ "Unknown validity:\n" ++ show prop + ++ "\nResult:\n" ++ concatMap show c + UnSat _ -> Right () + InCon c -> Left $ "InCon: " ++ concat c + +runYices :: FilePath -> [CmdY] -> IO ResY +runYices yices = quickCheckY yices ["-tc"] + diff --git a/src/Language/CAO/Typechecker/Solver.hs b/src/Language/CAO/Typechecker/Solver.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Typechecker/Solver.hs @@ -0,0 +1,90 @@ + +{- | +Module : $Header$ +Description : Decision procedures for constraints +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable +-} + +module Language.CAO.Typechecker.Solver + ( valid + , valid' + ) where + +import Control.Monad + +import Language.CAO.Common.Error +import Language.CAO.Common.Monad +import Language.CAO.Common.State +import Language.CAO.Common.Var +import Language.CAO.Index +import Language.CAO.Index.Eval + +import Language.CAO.Typechecker.SMT + +valid :: CaoMonad m => [ICond Var] -> ErrorCode Var -> m () +valid i e = do + r <- validEval $ IAnd i + unless r $ tcError e + +valid' :: CaoMonad m => [ICond Var] -> m Bool +valid' i = validEval $ IAnd i + +validEval :: CaoMonad m => ICond Var -> m Bool +validEval c = case evalCond c of + IBool b -> return b + IAnd i -> do + hyp <- getHypothesis + case fromHyp hyp i of + IBool b -> return b + r -> checkValidity (IAnd hyp) r + _ -> error $ ": unexpected canonical form." + +fromHyp :: [ICond Var] -> [ICond Var] -> ICond Var +fromHyp hyp cond = let + cond' = filter (not . checkHyp hyp) cond + in if null cond' then IBool True else IAnd cond' + + where + + checkHyp :: [ICond Var] -> ICond Var -> Bool + checkHyp hyp' c = any (exactHyp c) hyp' + + exactHyp :: ICond Var -> ICond Var -> Bool +-- C, a |= a + exactHyp c h + | c == h = True +-- C, 0 <= a |= 0 <= b <== |= a <= b' + exactHyp (ILeq b) (ILeq a) = let + (n, c, i) = decompose b + (n', c', i') = decompose a + in if i == i' + then if evalBool [c .<. IInt 0, c' .<. IInt 0] + then evalBool [(n .*. c') .<=. (n' .*. c)] + else if evalBool [c .>. IInt 0, c' .>. IInt 0] + then evalBool [(n' .*. c) .<=. (n .*. c')] + else evalBool [a .<=. b] + else evalBool [a .<=. b] + + exactHyp c (IAnd l) = checkHyp l c + exactHyp _ _ = False + +evalBool :: [ICond Var] -> Bool +evalBool = toBool . evalCond . IAnd +toBool :: ICond Var -> Bool +toBool (IBool b) = b +toBool _ = False + +-- (Term, Coeficient, Variable) +decompose :: IExpr Var -> (IExpr Var, IExpr Var, IExpr Var) +decompose (ISum [IInt n, IArith ITimes c i]) = (IInt n, c, i) +decompose (ISum [IInt n, i]) = (IInt n, IInt 1, i) +decompose (ISum [IArith ITimes c i]) = (IInt 0, c, i) +decompose (IArith ITimes c i) = (IInt 0, c, i) +decompose i = (IInt 0, IInt 1, i) + + diff --git a/src/Language/CAO/Typechecker/Unification.hs b/src/Language/CAO/Typechecker/Unification.hs new file mode 100644 --- /dev/null +++ b/src/Language/CAO/Typechecker/Unification.hs @@ -0,0 +1,479 @@ + +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +{- +Module : $Header$ +Description : Unification of type when checking expressions. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Language.CAO.Typechecker.Unification ( solve ) where + +import Data.List (partition) + +import Language.CAO.Common.Error +import Language.CAO.Common.Polynomial +import Language.CAO.Common.Var hiding (mrange) + +import Language.CAO.Index + +import Language.CAO.Type +import Language.CAO.Type.Utils +import Language.CAO.Typechecker.Constraint + +import Language.CAO.Index.Eval + +{- +Invariants: +* Coercions are directed, i.e., the left type coerces to the right type. The left + type is the actual type while the right type is the expected type. +* Unification is not directed, i.e., left and right types are interchangeable. +* Unification always takes a type variable which will take the type resulting of + the unification. +* Casts are directed. The left type is the source type and the right type is the + target type. +* The target type of a cast is always determined, i.e., it is not a type variable. +* After a cast of a type variable, this cannot occur again. +* Leafs (variables and constants) types cannot be unbounded type variables. + They are either base types or integer type variables. +* The list of constraints is collected in a post-order traversal of the expression. + This means that leafs in the expression are processed + before the operators. This as a number of implications: + - A given type variable only appears in a constraint *after* appearing as a result + of an unification. This means that unification is a kind of type variable + introduction. + - Since each unification resolves to a type which is not an unbounded variable, + all the subsequent occurences get replaced. This means that, when processing + constraints, unbounded variables can only occur as the result of an unification. + - It is possible that integer type variables are not instantiated. In this case, + the integer type is assumed. +-} + +-- TODO: Missing tuple case +solve :: [Constraint] -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +solve [] = return ([], []) +solve (Equal t1 t2 : s) = solvePat (equals t1 t2) s +solve (Coerces t1 t2 : s) = solvePat (coerces t1 t2) s +solve (Unifies tv t1 t2 : s) = solvePat (unifies tv t1 t2) s +solve (UnifiesC tv t1 t2 : s) = solvePat (unifiesC tv t1 t2) s +solve (Casts t1 t2 : s) = solvePat (casts t1 t2) s +solve (ToAlgebraic t1 t2 : s) = solvePat (toAlgebraic t1 t2) s +solve (Mult tv t1 t2 : s) = solvePat (mult tv t1 t2) s +solve (Pow t1 t2 : s) = solvePat (power t1 t2) s +solve (Conc tv t1 t2 : s) = solvePat (conc tv t1 t2) s +solve (UnifiesL tv tlst : s) = solvePat (unifiesL tv tlst) s +solve (MAccess t1 t2 mi : s) = solvePat (maccess t1 t2 mi) s +solve (MRange t1 t2 i1 i2 i3 i4 : s) = solvePat (mrange t1 t2 i1 i2 i3 i4) s +solve (MRow t1 t2 i1 i2 mi : s) = solvePat (mrow t1 t2 i1 i2 mi) s +solve (MCol t1 t2 i1 i2 mi : s) = solvePat (mcol t1 t2 i1 i2 mi) s +solve (VBAccess t1 t2 mi : s) = solvePat (vbaccess t1 t2 mi) s +solve (VBRange t1 t2 i1 i2 : s) = solvePat (vbrange t1 t2 i1 i2) s + +solvePat + :: Either (ErrorCode Var) ([Substitution], [ICond Var]) + -> [Constraint] + -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +solvePat f s = do + (sbs, c) <- f + (s', c') <- solve (substitution sbs s) + let sbs' = substSqrL s' sbs + return (sbs' ++ s', c ++ c') + +skip :: Either (ErrorCode Var) ([Substitution], [ICond Var]) +skip = return ([], []) + +self :: Type Var -> Substitution +self t@(TyVar n) = Subst n t +self t@(IntVar n) = Subst n t +self t@(ModVar n) = Subst n t +self _ = error "self substitution: not expected" + +equals :: Type Var -> Type Var -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +equals Bool Bool = skip +equals RInt RInt = skip +equals Int Int = skip +equals (IntVar n1) t2@(IntVar n2) + | n1 == n2 = skip + | otherwise = return ([Subst n1 t2, self t2], []) +equals t1@(IntVar n1) t2 + | isInt t2 = return ([Subst n1 t2], []) + | otherwise = Left (TypeMismatchException t1 t2 MatchException) +equals t1 t2@(IntVar n2) + | isInt t1 = return ([Subst n2 t1], []) + | otherwise = Left (TypeMismatchException t1 t2 MatchException) +equals (Bits s1 n1) (Bits s2 n2) | s1 == s2 = return ([], [n1 .==. n2]) +equals (ModVar m1) t2@(ModVar m2) + | m1 == m2 = skip + | otherwise = return ([Subst m1 t2, self t2], []) +-- TODO: missing cases for ModVar's +equals (Mod Nothing Nothing (Pol [Mon (CoefI n1) EZero])) + (Mod Nothing Nothing (Pol [Mon (CoefI n2) EZero])) = + return ([], [n1 .==. n2]) +equals (Mod (Just t1) v1 p1) (Mod (Just t2) v2 p2) | v1 == v2 = do + (s', c') <- equals t1 t2 + c'' <- eqPol p1 p2 + return (s', c' ++ c'') +equals (Vector i1 t1) (Vector i2 t2) = do + (s', c') <- equals t1 t2 + return (s', i1 .==. i2 : c') +equals (Matrix i1 j1 t1) (Matrix i2 j2 t2) = do + (s', c') <- equals t1 t2 + let c = [i1 .==. i2, j1 .==. j2] + return (s', c ++ c') +equals (Struct s1 _) (Struct s2 _) | s1 == s2 = skip + +equals t1 t2 = Left (TypeMismatchException t1 t2 MatchException) + +coerces :: Type Var -> Type Var -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +coerces Bool Bool = skip +coerces RInt RInt = skip +coerces Int Int = skip +-- When two integer type variables are compared: +-- - if they are equal, they can be removed since they add no information +-- - if they are different, one replaces all occurrences of the other +coerces (IntVar n1) t2@(IntVar n2) + | n1 == n2 = skip + | otherwise = return ([Subst n1 t2, self t2], []) +-- When a integer type variable is being coerced to another type, the target type +-- can only be an integer (rint or int) type, since integers cannot be coerced to any +-- other type. +-- - The integer type variable is replaced by the target type in all its occurrences. +-- - Otherwise, the coercion is not possible +coerces t1@(IntVar n1) t2 + | isInt t2 = return ([Subst n1 t2], []) + | otherwise = Left (TypeMismatchException t1 t2 MatchException) +-- When a type is being coerced to an integer type variable, the source type can be +-- either a bit string or an integer (rint or int) by the possible coercion rules. +-- - if it is an integer type, this type replaces all occurrences of the variable +-- - if it is a bit string, this implies that the variable type is int, since coercions +-- to rint are not allowed. +coerces t1 (IntVar n2) + | isInt t1 = return ([Subst n2 t1], []) + | isBits t1 = return ([Subst n2 Int], []) + +-- Index +coerces t1 (Index _ _ t2) = coerces t1 t2 +-- Bits to Integers +coerces (Bits _ _) Int = skip +-- Bits +coerces (Bits s1 n1) (Bits s2 n2) | s1 == s2 = return ([], [n1 .==. n2]) +-- Mod's +-- What may happen if the base of a Mod is an integer? Should that be possible? +coerces (ModVar m1) t2@(ModVar m2) + | m1 == m2 = skip + | otherwise = return ([Subst m1 t2, self t2], []) +coerces (ModVar m1) m2@(Mod Nothing Nothing (Pol [Mon (CoefI _) EZero])) = + return ([Subst m1 m2], []) +coerces (ModVar m1) (Mod (Just t2) _ _) = coerces (ModVar m1) t2 +-- TODO: missing cases for ModVar's +--coerces (Mod Nothing Nothing (Pol [])) (Mod {}) = skip +coerces (Mod Nothing Nothing (Pol [Mon (CoefI n1) EZero])) + (Mod Nothing Nothing (Pol [Mon (CoefI n2) EZero])) = + return ([], [n1 .==. n2]) +coerces (Mod (Just t1) v1 p1) (Mod (Just t2) v2 p2) | v1 == v2 = do + (s', c') <- coerces t1 t2 + c'' <- eqPol p1 p2 + return (s', c' ++ c'') +coerces t1 (Mod (Just b) _ _) = coerces t1 b +-- Vectors +coerces (Vector i1 t1) (Vector i2 t2) = do + (s', c') <- coerces t1 t2 + return (s', i1 .==. i2 : c') +-- Matrices +coerces (Matrix i1 j1 t1) (Matrix i2 j2 t2) = do + (s', c') <- coerces t1 t2 + let c = [i1 .==. i2, j1 .==. j2] + return (s', c ++ c') + +coerces (Struct s1 _) (Struct s2 _) | s1 == s2 = skip + +coerces t1 t2 = Left (TypeMismatchException t1 t2 MatchException) + +eqPol :: Pol Var -> Pol Var -> Either (ErrorCode Var) [ICond Var] +eqPol (Pol p1) (Pol p2) = eqPolLst p1 p2 + where + eqPolLst [] [] = return [] + eqPolLst (m1 : mlst1) (m2 : mlst2) = do + c1 <- eqMon m1 m2 + c2 <- eqPolLst mlst1 mlst2 + return (c1 ++ c2) + eqPolLst _ _ = Left $ UnknownErr "eqPol: <>: eqPolLst" + + eqMon (Mon c1 b1) (Mon c2 b2) = do + c1' <- eqCoef c1 c2 + _ <- eqBase b1 b2 + return c1' + + eqCoef (CoefI i1) (CoefI i2) = return [i1 .==. i2] + eqCoef (CoefP pl1) (CoefP pl2) = eqPol pl1 pl2 + eqCoef _ _ = Left $ UnknownErr "eqPol: <>: eqCoef" + + eqBase EZero EZero = return [] + eqBase (MExpI v1 e1) (MExpI v2 e2) | v1 == v2 && e1 == e2 = return [] + eqBase _ _ = Left $ UnknownErr "eqPol: <>: eqBase" + +unifies :: Type Var -> Type Var -> Type Var -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +-- Operations on bits imply a coercion to Int. This rule must come +-- before the rest of unification, otherwise, equal bit string types +-- would unify to themselves. +unifies (TyVar tv) (Bits _ _) (Bits _ _) = return ([Subst tv Int], []) + +unifies (TyVar tv) t1@(IntVar n1) t2@(IntVar n2) + | n1 == n2 = return ([Subst tv t2, self t1, self t2], []) + | otherwise = return ([Subst n1 t2, Subst tv t2, self t2], []) + +-- Unification of an integer type variable with a integer type +-- returns this integer type. +-- Unification of an integer type variable with a bit string +-- returns an integer (the only possible unification) +unifies (TyVar tv) (IntVar n1) t2 + | isInt t2 = return ([Subst n1 t2, Subst tv t2], []) + | isBits t2 = return ([Subst n1 Int, Subst tv Int], []) +-- Symmetric case of the above +unifies (TyVar tv) t1 (TyVar n2) + | isInt t1 = return ([Subst n2 t1, Subst tv t1], []) + | isBits t1 = return ([Subst n2 Int, Subst tv Int], []) + +unifies (TyVar tv) t1@(ModVar m1) t2@(ModVar m2) + | m1 == m2 = return ([Subst tv t2, self t1, self t2], []) + | otherwise = return ([Subst m1 t2, Subst tv t2, self t2], []) + +-- Mod variables +unifies (TyVar tv) (ModVar m1) m2@(Mod Nothing Nothing (Pol [Mon (CoefI _) EZero])) = + return ([Subst m1 m2, Subst tv m2], []) + +unifies (TyVar tv) (ModVar m1) (Mod (Just t2) _ _) = unifies (TyVar tv) (ModVar m1) t2 + +unifies (TyVar tv) m1@(Mod Nothing Nothing (Pol [Mon (CoefI _) EZero])) (ModVar m2) = + return ([Subst m2 m1, Subst tv m1], []) + +unifies (TyVar tv) (Mod (Just t1) _ _) (ModVar m2) = unifies (TyVar tv) (ModVar m2) t1 + +-- Unification cannot rely on just coercion for the case of vectors +-- and matrices, because of the unification must be propagated +-- through the structure. +-- Unification of Vectors +unifies (TyVar tv) (Vector i1 t1) (Vector i2 t2) = do + (sbs, c') <- unifies (TyVar tv) t1 t2 + let tv' = subst' sbs (TyVar tv) -- This can be improved... + sbs' = Subst tv (Vector i1 tv') : remove tv sbs -- Arbitrary choice since i1 and i2 must be equal + return (sbs', i1 .==. i2 : c') +-- Unification of Matrices +unifies (TyVar tv) (Matrix i1 j1 t1) (Matrix i2 j2 t2) = do + (sbs, c') <- unifies (TyVar tv) t1 t2 + let tv' = subst' sbs (TyVar tv) -- This can be improved... + sbs' = Subst tv (Matrix i1 j1 tv') : remove tv sbs -- Arbitrary choice since i1 and i2 must be equal + c = i1 .==. i2 : j1 .==. j2 : c' + return (sbs', c) + +unifies (TyVar tv) s@(Struct s1 _) (Struct s2 _) | s1 == s2 = + return ([Subst tv s], []) +-- General unification case uses coercions +-- TODO: use try/catch?? +unifies (TyVar tv) t1 t2 = case coerces t1 t2 of + Left _ -> case coerces t2 t1 of + Left _ -> Left (TypeMismatchException t1 t2 UnificationException) + Right (sbs, c) -> do + let sbs' = Subst tv (subst' sbs t1) : sbs + return (sbs', c) + Right (sbs, c) -> do + let sbs' = Subst tv (subst' sbs t2) : sbs + return (sbs', c) +unifies _ t1 t2 = Left (TypeMismatchException t1 t2 UnificationException) + +--casts' t1 t2 | isModInt t1 = return $ isIntExt t2 || isModInt t2 +casts :: Type Var -> Type Var -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +casts RInt Int = skip +casts Int RInt = skip +-- Any integer type variable is castable to an int or rint +-- So, we can assume that the source type is equal to the target type +casts (IntVar n) Int = return ([Subst n Int], []) +casts (IntVar n) RInt = return ([Subst n RInt], []) +-- rint's are not directly castable to bits to avoid errors. +-- This also means that an integer type variable is only castable +-- to bits if it is an int. +casts (IntVar n) (Bits _ _) = return ([Subst n Int], []) +casts Int (Bits _ _) = skip +casts (Bits {}) (Bits {}) = skip +casts (ModVar _) Int = skip +casts (ModVar _) (Bits _ _) = skip +casts (ModVar _) (Mod Nothing Nothing (Pol [Mon (CoefI _) EZero])) = skip +casts (ModVar _) (Mod (Just _) (Just _) (Pol _)) = skip +casts (Mod Nothing Nothing (Pol [Mon (CoefI _) EZero])) Int = skip +casts (Mod Nothing Nothing (Pol [Mon (CoefI _) EZero])) (Bits _ _) = skip -- Possible through int +casts (Mod Nothing Nothing (Pol [Mon (CoefI _) EZero])) (Mod Nothing Nothing (Pol [Mon (CoefI _) EZero])) = skip +casts (Mod Nothing Nothing (Pol [Mon (CoefI _) EZero])) (Mod (Just _) (Just _) (Pol _)) = skip +casts Int (Mod {}) = skip +-- This is only possible when the integer type variable is an Int +casts (IntVar n) (Mod {}) = return ([Subst n Int], []) +casts (Bits _ _) (Mod {}) = skip +{- +casts Int (Mod Nothing Nothing (Pol [Mon (CoefI _) EZero])) = skip +casts (Bits _ _) (Mod Nothing Nothing (Pol [Mon (CoefI _) EZero])) = skip -- Possible through int +casts Int (Mod (Just bt) (Just v) _) = skip +casts (Bits _ _) (Mod (Just bt) (Just v) _) = skip-} +casts (Vector i1 t1) (Mod (Just bt) (Just _) pol) = do + (sbs, c) <- casts t1 bt + return (sbs, i1 .==. IInt (degree pol) : c) +casts (Mod (Just bt) (Just _) pol) (Vector i2 t2) = do + (sbs, c) <- casts bt t2 + return (sbs, i2 .==. IInt (degree pol) : c) +casts (Matrix i1 j1 t1) (Mod (Just bt) (Just _) pol) = do + (sbs, c) <- casts t1 bt + let deg = IInt $ degree pol + c' = IAnd [i1 .==. IInt 1, j1 .==. deg] .||. IAnd [j1 .==. IInt 1, i1 .==. deg] + return (sbs, c' : c) +casts (Mod (Just bt) (Just _) pol) (Matrix i2 j2 t2) = do + (sbs, c) <- casts bt t2 + let deg = IInt $ degree pol + c' = IAnd [i2 .==. IInt 1, deg .==. j2] .||. IAnd [j2 .==. IInt 1, deg .==. i2] + return (sbs, c' : c) +casts (Matrix i1 j1 t1) (Vector i2 t2) = do + (sbs, c) <- casts t1 t2 + let c' = IAnd [i1 .==. IInt 1, j1 .==. i2] .||. IAnd [j1 .==. IInt 1, i1 .==. i2] + return (sbs, c' : c) +casts (Vector i1 t1) (Matrix i2 j2 t2) = do + (sbs, c) <- casts t1 t2 + let c' = IAnd [i2 .==. IInt 1, i1 .==. j2] .||. IAnd [j2 .==. IInt 1, i1 .==. i2] + return (sbs, c' : c) +casts (Vector i1 t1) (Vector i2 t2) = do + (sbs, c) <- casts t1 t2 + return (sbs, i1 .==. i2 : c) +casts (Matrix i1 j1 t1) (Matrix i2 j2 t2) = do + (sbs, c) <- casts t1 t2 + return (sbs, i1 .==. i2 : j1 .==. j2 : c) +casts (Tuple t1) (Tuple t2) = solve $ zipWith Casts t1 t2 + +casts t1 t2 = either (const (Left (TypeMismatchException t1 t2 CastException))) Right (coerces t1 t2) + +toAlgebraic :: Type Var -> Type Var -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +toAlgebraic (TyVar tv) (Bits _ _) = return ([Subst tv Int], []) +toAlgebraic (TyVar tv) t = return ([Subst tv t], []) +toAlgebraic _ _ = Left (UnknownErr "toAlgebraic") + +mult :: Type Var -> Type Var -> Type Var -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +mult (TyVar tv) (Matrix r1 c1 t1) (Matrix r2 c2 t2) = do + (sbs, c) <- mult (TyVar tv) t1 t2 + let tv' = subst' sbs (TyVar tv) + sbs' = Subst tv (Matrix r1 c2 tv') : remove tv sbs + return (sbs', c ++ [c1 .==. r2]) +mult tv@(TyVar _) t1 t2 = unifies tv t1 t2 +mult _ t1 t2 = Left (TypeMismatchException t1 t2 UnificationException) + +power :: Type Var -> Type Var -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +power (TyVar tv) (Matrix r1 c1 t) = do + (sbs, c) <- power (TyVar tv) t + let tv' = subst' sbs (TyVar tv) + sbs' = Subst tv (Matrix r1 c1 tv') : remove tv sbs + return (sbs', c ++ [r1 .==. c1]) +power (TyVar tv) (Bits _ _) = do -- Coercible to Int + return ([Subst tv Int], []) +power (TyVar tv) t = + return ([Subst tv t], []) +power t1 t2 = Left (TypeMismatchException t1 t2 UnificationException) + +-- This is a particular case for concatenation of vectores and equality. The unification of equal bit strings +-- should be a bit string. In all other cases, bit strings are taken as integers. +-- This may be a result of a poor design... +unifiesC :: Type Var -> Type Var -> Type Var -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +unifiesC (TyVar tv) (Bits s1 (IInt n1)) (Bits s2 (IInt n2)) | s1 == s2 && n1 == n2 = + return ([Subst tv (Bits s1 (IInt n1))], []) +-- TODO: Add the general case for testing bit string sizes with arbitrary case +unifiesC tv t1 t2 = unifies tv t1 t2 + +conc :: Type Var -> Type Var -> Type Var -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +conc (TyVar tv) (Bits s1 n1) (Bits s2 n2) | s1 == s2 = + return ([Subst tv (Bits s1 (evalExpr (ISum [n1, n2])))], []) +conc (TyVar tv) (Vector n1 t1) (Vector n2 t2) = do + (sbs, c) <- unifiesC (TyVar tv) t1 t2 + let tv' = subst' sbs (TyVar tv) + sbs' = Subst tv (Vector (evalExpr (ISum [n1, n2])) tv') : remove tv sbs -- TODO: improve this pattern + return (sbs', c) +conc _ t1 t2 = Left (TypeMismatchException t1 t2 UnificationException) + +isModVar :: Type Var -> Bool +isModVar m = case m of + ModVar _ -> True + _ -> False + +unifiesL :: Type Var -> [Type Var] -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +unifiesL _ [] = error ".: not expected empty case" +-- There is nothing to unify +unifiesL (TyVar tv) [t] = return ([Subst tv t], []) +unifiesL (TyVar tv) tlst = + let (modvars, tvars) = partition isModVar tlst + in if null tvars + then return (sbsLst tv (tail modvars) (head modvars), []) + else do + (tu, c) <- aux (TyVar tv) tvars + let sbs = sbsLst tv modvars tu + return (sbs, c) + + where + sbsLst t modvars tu = Subst t tu : zipWith (\ (ModVar v) -> Subst v) modvars (repeat tu) + + aux _ [t] = return (t, []) + aux tv' (t:ts) = aux' tv' t ts [] + aux _ _ = error "unifiesL.aux: Not expected case" + + aux' _ tu [] cs = return (tu, cs) + aux' tv' tu (t:ts) cs = do + (sbs, c) <- unifies tv' t tu + let tu' = subst' sbs tv' + aux' tv' tu' ts (c ++ cs) +unifiesL _ _ = error ".: not expected case" + +maccess :: Type Var -> Type Var -> Maybe (IExpr Var, IExpr Var) -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +maccess (TyVar tv) (Matrix u v t) mi = return ([Subst tv t], cAccessM u v mi) +maccess _ t2 _ = Left $ WrongTypeException t2 MatrixType + +mrange :: Type Var -> Type Var -> IExpr Var -> IExpr Var -> IExpr Var -> IExpr Var -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +mrange (TyVar tv) (Matrix u v it) i1 i2 i3 i4 = + return ( [Subst tv (Matrix (cSize i1 i2) (cSize i3 i4) it)] + , cRange u i1 i2 ++ cRange v i3 i4) +mrange _ t2 _ _ _ _ = Left $ WrongTypeException t2 MatrixType + + +mrow :: Type Var -> Type Var -> IExpr Var -> IExpr Var -> Maybe (IExpr Var) -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +mrow (TyVar tv) (Matrix v u it) i1 i2 mi = + return ([Subst tv (Matrix (IInt 1) (cSize i1 i2) it)], cRange u i1 i2 ++ cAccess v mi) +mrow _ t2 _ _ _ = Left $ WrongTypeException t2 MatrixType + +mcol :: Type Var -> Type Var -> IExpr Var -> IExpr Var -> Maybe (IExpr Var) -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +mcol (TyVar tv) (Matrix v u it) i1 i2 mi = do + return ([Subst tv (Matrix (cSize i1 i2) (IInt 1) it)], cRange v i1 i2 ++ cAccess u mi) +mcol _ t2 _ _ _ = Left $ WrongTypeException t2 MatrixType + +vbaccess :: Type Var -> Type Var -> Maybe (IExpr Var) -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +vbaccess (TyVar tv) (Bits s k) mi = return ([Subst tv (Bits s (IInt 1))], cAccess k mi) +vbaccess (TyVar tv) (Vector k t) mi = return ([Subst tv t], cAccess k mi) +vbaccess _ t2 _ = Left $ WrongTypeException t2 BitsOrVectorType + +vbrange :: Type Var -> Type Var -> IExpr Var -> IExpr Var -> Either (ErrorCode Var) ([Substitution], [ICond Var]) +vbrange (TyVar tv) (Bits s k) i1 i2 = + return ([Subst tv (Bits s (cSize i1 i2))], cRange k i1 i2) +vbrange (TyVar tv) (Vector k t) i1 i2 = + return ([Subst tv (Vector (cSize i1 i2) t)], cRange k i1 i2) +vbrange _ t2 _ _ = Left $ WrongTypeException t2 BitsOrVectorType + +----------------------------------- +-- TODO: This code is shared with Check.hs +cRange :: IExpr Var -> IExpr Var -> IExpr Var -> [ICond Var] +cRange s i j = [j .<. s, i .<=. j, IInt 0 .<=. i] +cSize :: IExpr Var -> IExpr Var -> IExpr Var +cSize i j = evalExpr $ ISum [ j, ISym i, IInt 1 ] +cAccessM :: IExpr Var -> IExpr Var -> Maybe (IExpr Var, IExpr Var) -> [ICond Var] +cAccessM _ _ Nothing = [] +cAccessM u v (Just (i, j)) = [IInt 0 .<=. i, i .<. u, IInt 0 .<=. j, j .<. v] +cAccess :: IExpr Var -> Maybe (IExpr Var) -> [ICond Var] +cAccess _ Nothing = [] +cAccess k (Just i) = [IInt 0 .<=. i, i .<. k] +---------------------------- diff --git a/src/Main/Compiler.hs b/src/Main/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Main/Compiler.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE PatternGuards #-} +{- +Module : $Header$ +Description : Compiler main module +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Main.Compiler ( caoComp ) where + +import Control.Monad +import Control.Monad.State + +import Data.Maybe (fromMaybe) +import System.Directory (doesFileExist, getPermissions, readable, findExecutable) +import System.FilePath(splitExtension, addExtension, takeFileName) +import System.IO + +import Language.CAO.Analysis.CFG +import Language.CAO.Analysis.SSA + +import Language.CAO.Common.Error +import Language.CAO.Common.Monad +import Language.CAO.Common.State +import Language.CAO.Common.Var + +import Language.CAO.Parser.Config +import Language.CAO.Parser.Parser ( parseFile ) + +import Language.CAO.Platform.Specification + +import Language.CAO.Syntax +import Language.CAO.Syntax.Tidy + +import Language.CAO.Transformation.Expand +import Language.CAO.Transformation.Eval +import Language.CAO.Transformation.Indist +import Language.CAO.Transformation.Simplify +import Language.CAO.Transformation.Target + +import qualified Language.CAO.Translation.C as NC +import Language.CAO.Translation.PreC + +import Language.CAO.Typechecker ( tcCaoAST ) + +import Main.Flags +import Main.Dot + +_WRONG_MODE :: a +_WRONG_MODE = error ": Panic! unexpected mode!" + +caoComp :: Options -> IO () +caoComp opts@(Comp {}) = do + -- Check config file + let cfg_file = config opts + exists_cfg <- doesFileExist cfg_file + when (not exists_cfg) $ + error $ "Error: could not find config file: `" ++ cfg_file ++ "'." + cfg_permissions <- getPermissions cfg_file + when (not (readable cfg_permissions)) $ + error $ "Error: config file `" ++ cfg_file ++ "' is not readable." + + -- Check input file + let input_file = input opts + (file, extension) = splitExtension input_file + when (null input_file) $ error $ "Error: no input file." + exists_input <- doesFileExist input_file + when (not exists_input) $ + error $ "Error: could not find input file: `" ++ input_file ++ "'." + when (extension /= ".cao") $ + error $ "Error: input file format not recognized: `" ++ extension ++"'." + input_permissions <- getPermissions input_file + when (not (readable input_permissions)) $ + error $ "Error: input file `" ++ input_file ++ "' is not readable." + + -- Check Yices + yices <- checkYices + + -- Output file + let output_file = fromMaybe (addExtension (takeFileName file) ".c") (output opts) + + cfg <- loadConfig cfg_file + (c_prog, warn) <- runCaoResultWarn $ compile cfg opts yices + hPutStrLn stderr $ showCaoWarnings warn + writeFile output_file c_prog +caoComp _ + = _WRONG_MODE + +checkYices :: IO (Maybe FilePath) +checkYices = do + yices <- findExecutable "yices" + maybe (hPutStrLn stderr "Without Yices some conditions may not be verified correctly") (const (return ())) yices + return yices +-------------------------------------------------------------------------------- +-- Main compilation function: +-- pipeline = parser -> typechecker -> seq expansion +-- -> eval -> simplify -> optimize -> C +compile :: TranslationSpec -> Options -> Maybe FilePath -> CaoResult String +compile cfg opts yices = do + let file_name = input opts + setFileName file_name + setYices yices + -- Parse + parsed_ast <- parseFile file_name + -- TypeCheck prog + let mode = runmode opts + (tc_ast,_) <- tcCaoAST mode parsed_ast + dump mode (verbose opts) (ddump_tc opts) (dcheck opts) tc_ast + -- Expand sequences + seq_exp_ast <- whenOpt (fexpand) + (\_ a -> expandSequences a) opts tc_ast + dump mode (verbose opts) (ddump_expand opts && fexpand opts) (dcheck opts) seq_exp_ast + -- Eval + let eval_ast = evalExpr seq_exp_ast + dump mode (verbose opts) (ddump_eval opts) (dcheck opts) eval_ast + -- Simplify + simpl_ast <- simplifyCaoAST (initProcName $ globalTransSpec cfg) eval_ast + dump mode (verbose opts) (ddump_simpl opts) (dcheck opts) simpl_ast + -- Optimize + opt_ast <- whenOpt optimize + optProg opts simpl_ast + dump mode (verbose opts) (ddump_opt opts) (dcheck opts) opt_ast + --- Platform dependent --- + -- Not valid CAO code anymore -- + -- Target + target_ast <- targetCaoAST cfg opt_ast + dump mode (verbose opts) (ddump_target opts) (dcheck opts) target_ast + -- PreC + prec_ast <- cao2prec cfg target_ast + dump mode (verbose opts) (ddump_prec opts) (dcheck opts) prec_ast + -- Cao2C + NC.cao2c cfg prec_ast + +-------------------------------------------------------------------------------- +-- Optimization + +whenOpt :: Monad m => + (Options -> Bool) -> (Options -> a -> m a) -> Options -> a -> m a +whenOpt fm f o a + | fm o = f o a + | otherwise = return a + +optProg :: Options -> Prog Var -> CaoResult (Prog Var) +optProg opts prog = do + -- ToCFG + let cfg = buildCFG prog + maybe (return ()) (generateCFG opts cfg) $ dgen_cfg opts + -- ToSSA + ssa_cfg <- mapM toSSA cfg + maybe (return ()) (generateCFG opts ssa_cfg) $ dgen_ssa opts + -- SSA back translation + let back_cfg' = map fromSSA ssa_cfg + + -- >> Indistinguishable functions + back_cfg <- maybe (return back_cfg') (flip (uncurry mkIndistFun) back_cfg') $ findist_fun opts + + -- From CFG + let opt_ast = toAST back_cfg + return opt_ast + +-------------------------------------------------------------------------------- +-- Dump mode + +dump :: RunMode -> Bool -> Bool -> Bool -> Prog Var -> CaoResult () +dump m _ True True = \ ast -> do + s <- get + put initialState + _ <- tcCaoAST m (fmap varName (tidyCaoAST ast)) + put s + liftIO $ hPutStrLn stderr "Dumped code type checked with success" + +dump _ v True False + = liftIO . hPutStrLn stderr . doDump + where + doDump | v = showCaoASTDebug + | otherwise = showCaoAST +dump _ _ False _ + = const $ return () + diff --git a/src/Main/Dot.hs b/src/Main/Dot.hs new file mode 100644 --- /dev/null +++ b/src/Main/Dot.hs @@ -0,0 +1,86 @@ + +{- +Module : $Header$ +Description : Internal control flow graph printing. +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Main.Dot where + +import Control.Exception ( catch ) +import Control.Monad +import Control.Monad.Trans (liftIO) + +import System.Exit +import System.Directory ( doesFileExist, removeFile, findExecutable ) +import System.FilePath (dropExtension, addExtension) +import System.Process +import System.IO + +import Language.CAO.Analysis.CFG + +import Language.CAO.Common.Monad + +import Main.Flags + +-------------------------------------------------------------------------------- +-- Printing Control Flow Graph + +generateCFG :: Options -> [CaoCFG] -> String -> CaoResult () +generateCFG opts cfg outExt = + liftIO $ runDotT outExt noExt $ showCFG cfg + where + noExt = dropExtension $ input opts + +runDotT :: String -> String -> String -> IO () +runDotT outExt outF arg = do + -- Find dot executable + mdot <- findExecutable "dot" + doRunDotT mdot outExt outF arg + +doRunDotT :: Maybe FilePath -> String -> FilePath -> String -> IO () +doRunDotT Nothing _ outF arg = do + hPutStrLn stderr $ "Graphviz is required by --dgen-cfg\ + \ and --dgen-ssa options." + hPutStrLn stderr $ "Generating dot file: `" ++ outF ++ "dot'." + writeFile (addExtension outF "dot") arg +doRunDotT (Just dot) outExt outF arg = do + -- Open output file + file <- openFile dotOutputF WriteMode + hSetBinaryMode file True + -- Create dot process + (Just inp, _, _, h) <- createProcess $ dotProcess file + -- Feed in input + hPutStr inp arg + hFlush inp + hClose inp + -- Finish + cd <- waitForProcess h + cF cd + `catch` catchF + + where + dotProcess out + = (proc dot ["-T" ++ outExt]) { std_in = CreatePipe + , std_out = UseHandle out + } + dotOutputF = addExtension outF outExt + + catchF :: IOError -> IO () + catchF _ = cF $ ExitFailure (-1) + + cF :: ExitCode -> IO () + cF ExitSuccess = return () + cF (ExitFailure _) = do + hPutStrLn stderr "`dot' failure!" + hPutStrLn stderr $ "Generating dot file: `" ++ outF ++ "dot'." + b <- doesFileExist dotOutputF + when b $ removeFile dotOutputF + writeFile (addExtension outF "dot") arg + diff --git a/src/Main/Flags.hs b/src/Main/Flags.hs new file mode 100644 --- /dev/null +++ b/src/Main/Flags.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-cse #-} +{- +Module : $Header$ +Description : Compilation flags +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Main.Flags + ( Options(..) + , RunMode(..) + , getOpts + , printHelp + ) where + +import System.Console.CmdArgs +import System.Environment + +data RunMode + = CAO + | CAO_Strict + | CALF + | CALF_Strict + deriving (Show, Data, Typeable) + +data Options + = Comp { + input :: FilePath + , dependent :: Bool + , verbose :: Bool + , output :: Maybe FilePath + , config :: FilePath + , runmode :: RunMode + + , ddump_tc :: Bool + , ddump_simpl :: Bool + , ddump_eval :: Bool + , ddump_expand :: Bool + , ddump_opt :: Bool + , ddump_target :: Bool + , ddump_prec :: Bool + , dgen_cfg :: Maybe String + , dgen_ssa :: Maybe String + , dcheck :: Bool + + , fexpand :: Bool + , optimize :: Bool + , findist_fun :: Maybe (String, String) + } + | Help + deriving (Show, Data, Typeable) + +comp :: Options +comp = Comp { + input = def &= args &= typ "FILE" + , dependent = def &= help "Turns on the dependent type checking" + , runmode = enum [ CALF &= help "Normal mode" + , CALF_Strict &= help "Access checking" + , CAO &= help "Type checking without symbolic constants" + , CAO_Strict &= help "Type checking without symbolic constants (with access checking)"] + &= help "Running mode" + , verbose = def &= help "Give verbose output" + , output = def &= typ "FILE" &= help "Output file" + , config = "default.plat" &= typ "FILE" &= help "Config file" + , ddump_tc = def &= help "Dump type-checked code" + &= groupname "Debugging" + , ddump_simpl = def &= help "Dump simplified code" + &= groupname "Debugging" + , ddump_eval = def &= help "Dump code with evaluated expressions" + &= groupname "Debugging" + , ddump_expand = def &= help "Dump code after seq expansion" + &= groupname "Debugging" + , ddump_opt = def &= help "Dump code after optimization passes" + &= groupname "Debugging" + , ddump_target = def &= help "Dump code after targeting it to a given platform" + &= groupname "Debugging" + , ddump_prec = def &= help "Dump code after preprocessing to a C translation" + &= groupname "Debugging" + , dgen_cfg = def &= opt "pdf" + &= typ "FORMAT" + &= help "Generate Cao CFG in the specified\ + \ output format (Must be supported\ + \ by graphviz 'dot'!. Default = pdf)" + &= groupname "Debugging" + , dgen_ssa = def &= opt "pdf" + &= typ "FORMAT" + &= help "Generate Cao CFG in SSA in the\ + \ output format (Must be supported\ + \ by graphviz 'dot'!. Default = pdf)" + &= groupname "Debugging" + , dcheck = def &= help "Type check dumped code" + &= groupname "Debugging" + + , fexpand = def &= explicit + &= name "fexpand" + &= help "Expand seqs" + &= groupname "Optimization options" + , optimize = def &= explicit + &= name "O" + &= help "Run optimization passes" + &= groupname "Optimization options" + , findist_fun = def &= explicit + &= name "findist-fun" + &= typ "FUN,FUN" + &= help "Apply side channel countermeasures\ + \ to two function definitions." + &= groupname "Optimization options" + } + &= help "CAO to C compiler" + +chelp :: Options +chelp = Help + &= help "Display help about CAO modes" + +mode :: Mode (CmdArgs Options) +mode = cmdArgsMode $ + modes [comp, chelp] + &= help "CAO compiler infraestructure" + &= summary "cao v0.1 \n\ + \(C) SMART Team 2011 - DI/HasLab - Univ. Minho,\ + \ Braga, Portugal" + +printHelp :: IO () +printHelp = withArgs ["--help"] $ cmdArgsRun mode >> return () + +getOpts :: IO Options +getOpts = getArgs >>= doGetOpts + where + doGetOpts as + | null as = withArgs ["help"] $ cmdArgsRun mode + | otherwise = cmdArgsRun mode + diff --git a/src/Main/Main.hs b/src/Main/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main/Main.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-cse #-} +{- +Module : $Header$ +Description : Main +Copyright : (c) SMART Team / HASLab +License : GPL + +Maintainer : Paulo Silva +Stability : experimental +Portability : non-portable + +-} + +module Main where + +import Main.Flags +import Main.Compiler + +main :: IO () +main = do + opts <- getOpts + case opts of + Help -> printHelp + Comp {} -> caoComp opts