packages feed

cao (empty) → 0.1

raw patch · 94 files changed

+23251/−0 lines, 94 filesdep +ConfigFiledep +arraydep +basesetup-changed

Dependencies added: ConfigFile, array, base, cmdargs, containers, directory, dlist, filepath, language-c, mtl, pretty, process, yices

Files

+ LICENSE view
@@ -0,0 +1,165 @@+                   GNU LESSER GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ 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.
+ README.txt view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ backend_lib/C_generic/CAO_bool.cpp view
@@ -0,0 +1,7 @@+#include "CAO_bool.h"++CAO_RES CAO_bool_dump(CAO_bool b)+{+	std::cout << b << "\n";+	return CAO_OK;+}
+ backend_lib/C_generic/CAO_bool.h view
@@ -0,0 +1,28 @@+#ifndef CAO_BOOL_H+#define CAO_BOOL_H++#include "CAO_globals.h"++#ifdef __cplusplus++#include <iostream>++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
+ backend_lib/C_generic/CAO_globalOp.cpp view
@@ -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;+}
+ backend_lib/C_generic/CAO_globalOp.h view
@@ -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 <iostream>+#include <cstring>+#include <cstdlib>++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
+ backend_lib/C_generic/CAO_globals.h view
@@ -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
+ backend_lib/C_generic/CAO_int.cpp view
@@ -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;+}
+ backend_lib/C_generic/CAO_int.h view
@@ -0,0 +1,57 @@+#ifndef CAO_INT_H+#define CAO_INT_H++#include "CAO_globals.h"+#include "CAO_bool.h"++#ifdef __cplusplus++#include <NTL/ZZ.h>+#include <iostream>++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
+ backend_lib/C_generic/CAO_matrix.cpp view
@@ -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;+}
+ backend_lib/C_generic/CAO_matrix.h view
@@ -0,0 +1,68 @@+#ifndef CAO_MATRIX_H+#define CAO_MATRIX_H++#include "CAO_globals.h"+#include "CAO_globalOp.h"++#ifdef __cplusplus++#include <NTL/ZZ.h>+#include <iostream>++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
+ backend_lib/C_generic/CAO_mod.cpp view
@@ -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;+}
+ backend_lib/C_generic/CAO_mod.h view
@@ -0,0 +1,55 @@+#ifndef CAO_MOD_H+#define CAO_MOD_H++#include "CAO_globals.h"++#ifdef __cplusplus++#include <NTL/ZZ_p.h>+#include <iostream>+#include <sstream>++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
+ backend_lib/C_generic/CAO_modpol.cpp view
@@ -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;+}
+ backend_lib/C_generic/CAO_modpol.h view
@@ -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 <NTL/ZZ_pE.h>+#include <iostream>+#include <sstream>+#include <cstring>+#include <cstdlib>++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
+ backend_lib/C_generic/CAO_rint.cpp view
@@ -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;+}
+ backend_lib/C_generic/CAO_rint.h view
@@ -0,0 +1,37 @@+#ifndef CAO_RINT_H+#define CAO_RINT_H++#include "CAO_globals.h"++#ifdef __cplusplus++#include <NTL/ZZ.h>+#include <iostream>++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
+ backend_lib/C_generic/CAO_sbits.cpp view
@@ -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;+}
+ backend_lib/C_generic/CAO_sbits.h view
@@ -0,0 +1,54 @@+#ifndef CAO_SBITS_H+#define CAO_SBITS_H++#include "CAO_globals.h"++#ifdef __cplusplus++#include <NTL/ZZ.h>+#include <iostream>++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
+ backend_lib/C_generic/CAO_struct.cpp view
@@ -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;+}
+ backend_lib/C_generic/CAO_struct.h view
@@ -0,0 +1,46 @@+#ifndef CAO_STRUCT_H+#define CAO_STRUCT_H++#include "CAO_globals.h"++#ifdef __cplusplus++#include "CAO_globalOp.h"+#include <cstdlib>+#include <iostream>++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
+ backend_lib/C_generic/CAO_ubits.cpp view
@@ -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;+}
+ backend_lib/C_generic/CAO_ubits.h view
@@ -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 <NTL/ZZ.h>+#include <iostream>++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
+ backend_lib/C_generic/CAO_vector.cpp view
@@ -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;+}
+ backend_lib/C_generic/CAO_vector.h view
@@ -0,0 +1,54 @@+#ifndef CAO_VECTOR_H+#define CAO_VECTOR_H++#include "CAO_globals.h"++#ifdef __cplusplus++#include "CAO_matrix.h"++#include <iostream>++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
+ cao.cabal view
@@ -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 <paufil@di.uminho.pt>+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+
+ default.plat view
@@ -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+
+ example/Makefile view
@@ -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+
+ example/main_sha1.c view
@@ -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 */+
+ example/sha1.cao view
@@ -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);+}
+ src/Language/CAO/Analysis/CFG.hs view
@@ -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 <paufil@di.uminho.pt>+    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
+ src/Language/CAO/Analysis/Dominance.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE PatternGuards #-}+{- |+Module      :  $Header$+Description :  Graph dominance algorithm.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 $ "<Language.CAO.Analysis.Dominance>.\+        \<updDomTree>: 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+
+ src/Language/CAO/Analysis/PhiInsert.hs view
@@ -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 <paufil@di.uminho.pt>+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 _                  = []
+ src/Language/CAO/Analysis/SSA.hs view
@@ -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 <paufil@di.uminho.pt>+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 "<Language.CAO.Analysis.SSA>.<renameStatements>:\+            \ 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 "<SSA>.<renameLVal>: 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 "<SSA>.<whichPredecessor>: 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 "<SSA.hs>.<variableId>: 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 "<SSA>.<restoreLVal>: 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
+ src/Language/CAO/Analysis/SsaBack.hs view
@@ -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 <paufil@di.uminho.pt>+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
+ src/Language/CAO/Common/Error.hs view
@@ -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 <paufil@di.uminho.pt>+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 "<unknown>" +        ((UnknownErr "noMsg")::ErrorCode String)+    strMsg mstr = CaoError defSrcLoc "<unknonw>" +        ((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"
+ src/Language/CAO/Common/Fresh.hs view
@@ -0,0 +1,70 @@++{-# LANGUAGE FlexibleContexts #-}+{-+Module      :  $Header$+Description :  Generation of new simbols.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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+
+ src/Language/CAO/Common/Literal.hs view
@@ -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 <paufil@di.uminho.pt>+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"
+ src/Language/CAO/Common/Monad.hs view
@@ -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 <paufil@di.uminho.pt>+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+
+ src/Language/CAO/Common/Name.hs view
@@ -0,0 +1,118 @@+{-+Module      :  $Header$+Description :  Variable names+Copyright   :  (c) SMART Team / HASLab+License     :  GPL+ +Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+Stability   :  experimental+Portability :  non-portable (<reason>)++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
+ src/Language/CAO/Common/Operator.hs view
@@ -0,0 +1,98 @@++{-+Module      :  $Header$+Description :  Operatators+Copyright   :  (c) SMART Team / HASLab+License     :  GPL+ +Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+Stability   :  experimental+Portability :  non-portable (<reason>)++-}++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+
+ src/Language/CAO/Common/Outputable.hs view
@@ -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 <paufil@di.uminho.pt>+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)+
+ src/Language/CAO/Common/Polynomial.hs view
@@ -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 <paufil@di.uminho.pt>+Stability   :  experimental+Portability :  non-portable (<reason>)++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 "<<TODO>><Ord>: 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 "<Language.CAO.Semantics>:<polyToMono>:\+    \ 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 "<Language.CAO.Common>:<checkPol_>: \ +    \ unexpected empty list of monomials"++checkMon_ :: Eq id => Mon id -> Bool+checkMon_ (Mon (CoefI _) _) = True+checkMon_ (Mon (CoefP p) _) = isValid (monomials p)+
+ src/Language/CAO/Common/Representation.hs view
@@ -0,0 +1,24 @@++{-+Module      :  $Header$+Description :  String representations.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 = '_'
+ src/Language/CAO/Common/SrcLoc.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-+Module      :  $Header$+Description :  Source Location+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+Stability   :  experimental+Portability :  non-portable (<reason>)++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 "<no location info>"++-- | Create unknown 'SrcLoc'+--+{-# INLINE unkSrcLoc #-}+unkSrcLoc :: SrcLoc+unkSrcLoc = defSrcLoc++-- | Create generated 'SrcLoc'+--+genSrcLoc :: SrcLoc+genSrcLoc = UnhelpfulLoc "<compiler-generated code>"+++-- | 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+
+ src/Language/CAO/Common/State.hs view
@@ -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 <paufil@di.uminho.pt>+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   = "<Unknown file name>"+    , 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
+ src/Language/CAO/Common/Utils.hs view
@@ -0,0 +1,271 @@++{- |+Module      :  $Header$+Description :  Useful functions used in other modules.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 "<initLast>: 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 "<Utilities>.<getPos>: 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
+ src/Language/CAO/Common/Var.hs view
@@ -0,0 +1,891 @@+{-+Module      :  $Header$+Description :  Variables+Copyright   :  (c) SMART Team / HASLab+License     :  GPL+ +Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+Stability   :  experimental+Portability :  non-portable (<reason>)++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 $ "<Language.CAO.Common.Var>.<varType>:\+    \ 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
+ src/Language/CAO/Index.hs view
@@ -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 <paufil@di.uminho.pt>+Stability   :  experimental+Portability :  non-portable (<reason>)++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+
+ src/Language/CAO/Index/Eval.hs view
@@ -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 <paufil@di.uminho.pt>+Stability   :  experimental+Portability :  non-portable (<reason>)++--}++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 "<deMorgan>: 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 "<distrOr>: 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 "<flatTimes>: not expected"++toMult :: Integer -> [IExpr id] -> IExpr id+toMult n [] = IInt n+toMult n xs@(_:_) = IArith ITimes (IInt n) (aux xs)+    where+    aux [] = error "<toMult>: 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 "<<TODO>><sepTimes: not implemented"++constSum :: [IExpr id] -> 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 "<constSum>: 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 "<iTimesConcat>: 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 "<iTimes>: 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 "<distrSym>: <<TODO>> mod"+    IArith IPower _ _ -> error "<distrSym>: should never reach a power"+    IInd _ -> error "<distrSym>: should never reach a index variable"+    _ -> error "<<TODO>><distrSym>: 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 "<cmpIAOp>: 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+
+ src/Language/CAO/Index/Utils.hs view
@@ -0,0 +1,78 @@++{- |+Module      :  $Header$+Description :  Useful function to manipulate indexes.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 "<Utils.hs><ind2Expr>: 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 "<queryIndexTy>: not expected"++mapAOp :: AOp -> (IExpr id -> IExpr id -> IExpr id)+mapAOp Minus = (.-.)+mapAOp Times = (.*.)+mapAOp Power = (.**.)+mapAOp Div   = (./.)+mapAOp ModOp = (.%.)+mapAOp _ = error "<mapAOp>: not expected"++mapBOp :: BOp -> (ICond id -> ICond id -> ICond id)+mapBOp Or  = (.||.)+mapBOp Xor = (.^^.)+mapBOp _ = error "<mapBOp>: not expected"++mapCOp :: COp -> (IExpr id -> IExpr id -> ICond id)+mapCOp Eq  = (.==.)+mapCOp Neq = (./=.)+mapCOp Lt  = (.<.)+mapCOp Leq = (.<=.)+mapCOp Gt  = (.>.)+mapCOp Geq = (.>=.)+
+ src/Language/CAO/Parser/Config.hs view
@@ -0,0 +1,331 @@++{-+Module      :  $Header$+Description :  Parsing of the platform configuration.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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)))+
+ src/Language/CAO/Parser/Lexer.x view
@@ -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 <paufil@di.uminho.pt>+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 }+<comment> \/\*              { embedComment    }+<comment> \*\/              { unembedComment  }++<0>       $white+           ;+<comment> $white+           ;+<0>       .                 { lexerTokenInfoFunc handleError     }+<comment> .                 ;++{++-- 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 "<EOF>" (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 ()++}+
+ src/Language/CAO/Parser/Parser.y view
@@ -0,0 +1,556 @@+{++{-+Module      :  $Header$+Description :  CAO language parser.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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) ++}+
+ src/Language/CAO/Parser/Tokens.hs view
@@ -0,0 +1,94 @@++{-+Module      :  $Header$+Description :  CAO language tokens.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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+
+ src/Language/CAO/Platform/Literals.hs view
@@ -0,0 +1,354 @@++{- |+Module      :  $Header$+Description :  Sizes of the representation of CAO types.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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"+
+ src/Language/CAO/Platform/Naming.hs view
@@ -0,0 +1,155 @@++{-+Module      :  $Header$+Description :  Operation codes and naming+Copyright   :  (c) SMART Team / HASLab+License     :  GPL+ +Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+Stability   :  experimental+Portability :  non-portable (<reason>)++-}++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"
+ src/Language/CAO/Platform/Query.hs view
@@ -0,0 +1,218 @@++{- |+Module      :  $Header$+Description :  Queries about the target platform.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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+
+ src/Language/CAO/Platform/Specification.hs view
@@ -0,0 +1,118 @@++{- |+Module      :  $Header$+Description :  Information about the target platform.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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+
+ src/Language/CAO/Semantics/Bits.hs view
@@ -0,0 +1,78 @@++{- |+Module      :  $Header$+Description :  Bit operations semantics.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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) ""+
+ src/Language/CAO/Semantics/Bool.hs view
@@ -0,0 +1,29 @@++{- |+Module      :  $Header$+Description :  Boolean operations semantics.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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+
+ src/Language/CAO/Semantics/Casts.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE ViewPatterns      #-}+{-+Module      :  $Header$+Description :  Semantics of casts.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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
+ src/Language/CAO/Semantics/Integer.hs view
@@ -0,0 +1,59 @@++{- |+Module      :  $Header$+Description :  Integer operations semantics.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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)+
+ src/Language/CAO/Syntax.hs view
@@ -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 <paufil@di.uminho.pt>+Stability   :  experimental+Portability :  non-portable (<reason>)+  +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 [ <int expr> ]@+    = ModNum (LExpr id)+    -- | Modular extention: @mod [ <type><ind> / <pol> ]@+    | 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+
+ src/Language/CAO/Syntax/Codes.hs view
@@ -0,0 +1,100 @@++{- |+Module      :  $Header$+Description :  Mapping of CAO syntax to operation codes.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 $ "<CaoToC.h>.<opCode> - 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+
+ src/Language/CAO/Syntax/Tidy.hs view
@@ -0,0 +1,306 @@++{-+Module      :  $Header$+Description :  Tidy CAO variable names.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 "<tidyType>: 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)+
+ src/Language/CAO/Syntax/Utils.hs view
@@ -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 <paufil@di.uminho.pt>+Stability   :  experimental+Portability :  non-portable (<reason>)++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 $ "<Language.CAO.Syntax.Utils>.\+          \<rename>: 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 "<Language.CAO.Syntax.Utils>.\+        \<instance RN [Def a]>: Not defined!"++    substLst [] _ = []+    substLst (d:ds) f+      | captures f (bvs d) (fvs ds)+        = error "<Language.CAO.Syntax.Utils>.\+            \<instance RN [Def a]>: 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 "<Language.CAO.Syntax.Utils>.\+            \<instance RN (Fun a)>: 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 "<Language.CAO.Syntax.Utils>.<instance RN Stmt>:\+              \ 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 "<Language.CAO.Syntax.Utils>.\+        \<instance RN [Stmt a]>: Not defined!"++    substLst [] _+      = []+    substLst (s:ss) f+      | captures f (bvs s) (fvs ss)+        = error "<Language.CAO.Syntax.Utils>.\+            \<instance RN [Stmt a]>: 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 "<Language.CAO.Syntax.Utils>.\+        \<instance RN [Arg a]>: Not defined!"++    substLst []     _ = []+    substLst (a:as) f+      | captures f (fvs a) (fvs as)+        = error "<Language.CAO.Syntax.Utils>.\+            \<instance RN [Arg a]>: 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 "<Language.CAO.Syntax.Utils>.\+        \<instance Subst [Stmt a]>: 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 "<Language.CAO.Syntax.Utils>.\+        \<instance Subst [Type a]>: 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 "<isAscSeq>: 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 $ "<Utils.hs>.<type2TyDecl>: " ++ 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+
+ src/Language/CAO/Transformation/Eval.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE ViewPatterns #-}+{- |+Module      :  $Header$+Description :  Expression evaluation.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 "<Language.CAO.Transformation.Eval>.\+                       \<evalLV>: 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 "<Language.CAO.Transformation.Eval>.<reduceAssoc>: 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 $ "<Language.CAO.Transformation.Eval>.<reduceTimesPlus>:\+      \ 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+--+-- <FIXME reduceAssoc>+-- 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+-- </FIXME reduceAssoc>+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 $ "<Language.CAO.Transformation.Eval>.\+              \<reducePats>: 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 $ "<Language.CAO.Transformation.Eval>.\+              \<reduceRngs>: 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
+ src/Language/CAO/Transformation/Expand.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE PatternGuards #-}+{-|+Module      :  $Header$+Description :  Sequence unrolling.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 "<Language.CAO.Transformation.Expand>.\+    \<seqCase>: 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
+ src/Language/CAO/Transformation/Indist.hs view
@@ -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 <paufil@di.uminho.pt>+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.
+ src/Language/CAO/Transformation/Simplify.hs view
@@ -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 <paufil@di.uminho.pt>+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 "<Language.CAO.Transformation.Simplify>.\+            \<simplifyStmt>: 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+        "<Language.CAO.Transformation.Simplify>.\+            \<simplifyMultipleAssignment>: 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 "<Language.CAO.Transformation.Simplify>.\+    \<toExp>: undefined case"++moduleName :: String+moduleName = "<Language.CAO.Transformation.Simplify>"++internalError :: String -> String -> a+internalError funcName msg = error $+    moduleName ++ ".<" ++ funcName ++ ">: " ++ msg
+ src/Language/CAO/Transformation/Target.hs view
@@ -0,0 +1,721 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-|+Module      :  $Header$+Description :  CAO target.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 "<procedure call>" 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 "<return>" 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 "<constant assign>" 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 +    "<targetConstDeclaration" "Not expected multiple constant declarations"+++targetVarDeclaration +    :: CaoMonad m+    => 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" "<<TODO>>: 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 "<function call>" 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 "<targetIndChoice>: 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 "<constIndType'>: Polynomial extension"+indType _ _ (Mod _ _ _) = error "<indType><<TODO>>: 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 "<<TODO>><indType>: 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 "<indType><<TODO>>: 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 $+        "<Language.CAO.Transformation.Target>.\+            \<targetIndChoice>: 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 = "<Language.CAO.Transformation.Target>"++internalError :: String -> String -> a+internalError funcName msg = error $+    moduleName ++ ".<" ++ funcName ++ ">: " ++ msg ++rintLit :: Integer -> TLExpr Var+rintLit = genLoc . annTyE RInt . Lit . ILit
+ src/Language/CAO/Translation/C.hs view
@@ -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 <paufil@di.uminho.pt>+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 "<mapConstDefinition>" "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 $ "<CaoToC.h>.<mapVarDefinition>:\+             \ 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 $ "<CaoToC.h>.<mapTypeDef>:\+             \ 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 $ "<CaoToC.h>.<mapConstDecl>:\+        \ 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 $ "<CaoToC.h>.<mapVarDefinition>:\+                 \ 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 $ "<CaoToC.h>.<mapVarDecl>:\+        \ 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 $ "<CaoToC.h>.<mapVarDefinition>:\+                 \ 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" "<<TODO>>: 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 "<CaoToC.h>.<mapMonomials>: precondition violation: empty list"+    Mon (CoefP _) _: _ -> error $ "<CaoToC.h>.<mapMonomials>:\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 = "<Language.CAO.Translation.C>"++internalError :: String -> String -> a+internalError funcName msg = error $+    moduleName ++ ".<" ++ funcName ++ ">: " ++ msg +
+ src/Language/CAO/Translation/C/Wrappers.hs view
@@ -0,0 +1,269 @@++{- |+Module      :  $Header$+Description :  C generation patterns.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 "<CaoToC.h>.<<+>>>: Not expected case"++(<<+>) :: [CBlockItem] -> CStat -> CStat+(<<+>) it (CCompound a1 lst a2) = CCompound a1 (it ++ lst) a2+(<<+>) _ _ = error "<CaoToC.h>.<<<+>>: Not expected case"+
+ src/Language/CAO/Translation/Names.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternGuards    #-}++{- |+Module      :  $Header$+Description :  CAO Translation naming.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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+
+ src/Language/CAO/Translation/PreC.hs view
@@ -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 <paufil@di.uminho.pt>+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 := <op>(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 = "<Language.CAO.Translation.PreC>"++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
+ src/Language/CAO/Translation/Yices.hs view
@@ -0,0 +1,64 @@+{-+Module      :  $Header$+Description :  The Yices expression translation+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 "<expr2Y>"++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 "<bOp2Y>"+-- XOr++type2Y :: Type id -> Maybe TypY+type2Y t = case t of+    Bool -> return $ VarT "bool"+    Int -> return $ VarT "int"+    _ -> Nothing
+ src/Language/CAO/Type.hs view
@@ -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 <paufil@di.uminho.pt>+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)
+ src/Language/CAO/Type/Utils.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE PatternGuards #-}+{- |+    Module      :  $Header$+    Description :  CAO type representation utilities+    Copyright   :  (c) SMART Team / HASLab+    License     :  GPL+    +    Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+    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 $ "<Utils>.<getStructName>: unexpected type "+                               ++ showPprDebug t+funClass :: PP id => Type id -> Class id+funClass (FuncSig _ _ c) = c+funClass f               = error $  "<Utils>.<funClass>: unexpected type "+                                 ++ showPprDebug f++retType :: PP id => Type id -> Type id+retType (FuncSig _ t _) = t+retType f               = error $  "<Utils>.<retType>: unexpected type "+                                ++ showPprDebug f++synType :: PP id => Type id -> Type id+synType (TySyn _ t) = t+synType t           = error $  "<Utils>.<synType>: 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 $ "<Utils>.<getPoly>: unexpected type "+                            ++ showPprDebug t++extractBaseType :: PP id => Type id -> Type id+extractBaseType (Mod (Just t) _ _)+    = t+extractBaseType t+    = error $ "<Utils>.<extractBaseType>: 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 $ "<Utils>.<sfType>: 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 $ "<Language.CAO.Types.Utils>.\+        \<fieldType>: unknown field " ++ showPprDebug fi ++ " of struct " +++        showPprDebug n+fieldType _  ty = error $ "<Language.CAO.Types.Utils>.\+      \<fieldType>: 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 $+      "<Language.CAO.Types.Utils>.<innerType>: 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 "<substTy>"++--------------------------------------------------------------------------------+-- Waste++getBVSize :: PP id => Type id -> IExpr id+getBVSize (Bits _ s)   = s+getBVSize (Vector s _) = s+getBVSize t            = error $ "<Utils>.<getBVSize>: unexpected type "+                             ++ showPprDebug t+
+ src/Language/CAO/Typechecker.hs view
@@ -0,0 +1,705 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternGuards    #-}++{- |+Module      :  $Header$+Description :  CAO type checker.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 "<<TODO>><checkArgs>: 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)+
+ src/Language/CAO/Typechecker/Check.hs view
@@ -0,0 +1,386 @@++{-# LANGUAGE PatternGuards    #-}++{- |+Module      :  $Header$+Description :  +Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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])+
+ src/Language/CAO/Typechecker/Constraint.hs view
@@ -0,0 +1,145 @@++{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}++{-+Module      :  $Header$+Description :  Constraints+Copyright   :  (c) SMART Team / HASLab+License     :  GPL+ +Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+Stability   :  experimental+Portability :  non-portable (<reason>)++-}++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)+
+ src/Language/CAO/Typechecker/Expr.hs view
@@ -0,0 +1,87 @@++{- |+Module      :  $Header$+Description :  Checks constraints over types+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 $+            "<TypeChecker.Expr>.<check>: <<TODO>>: 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)
+ src/Language/CAO/Typechecker/Heap.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE PatternGuards #-}+{- |+Module      :  $Header$+Description :  Heap for type checking.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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)+
+ src/Language/CAO/Typechecker/Index.hs view
@@ -0,0 +1,148 @@++{- |+Module      :  $Header$+Description :  Type checking indexes+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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++--------------------------------------------------------------------------------+
+ src/Language/CAO/Typechecker/PostProcessor.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE FlexibleContexts #-}++{- |+Module      :  $Header$+Description :  AST Post processor.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 "<PostProcessor>.<annotOp>: 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 "<PostProcessor>.<annotOp>: 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 "<PostProcessor>.<annotOp>: 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++--------------------------------------------------------------------------------
+ src/Language/CAO/Typechecker/SMT.hs view
@@ -0,0 +1,71 @@++{-+Module      :  $Header$+Description :  Interface with a SMT solver (Yices).+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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"]+
+ src/Language/CAO/Typechecker/Solver.hs view
@@ -0,0 +1,90 @@++{- |+Module      :  $Header$+Description :  Decision procedures for constraints+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 $ "<validEval>: 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)++
+ src/Language/CAO/Typechecker/Unification.hs view
@@ -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 <paufil@di.uminho.pt>+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: <<TODO>>: 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: <<TODO>>: eqCoef"++    eqBase EZero EZero = return []+    eqBase (MExpI v1 e1) (MExpI v2 e2) | v1 == v2 && e1 == e2 = return []+    eqBase _ _ = Left $ UnknownErr "eqPol: <<TODO>>: 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 "<Unification>.<unifiesL>: 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 "<Unification>.<unifiesL>: 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]+----------------------------
+ src/Main/Compiler.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE PatternGuards #-}+{-+Module      :  $Header$+Description :  Compiler main module+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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 "<Main.Compiler>: 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 ()+
+ src/Main/Dot.hs view
@@ -0,0 +1,86 @@++{-+Module      :  $Header$+Description :  Internal control flow graph printing.+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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+
+ src/Main/Flags.hs view
@@ -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 <paufil@di.uminho.pt>+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+
+ src/Main/Main.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-cse #-}+{-+Module      :  $Header$+Description :  Main+Copyright   :  (c) SMART Team / HASLab+License     :  GPL++Maintainer  :  Paulo Silva <paufil@di.uminho.pt>+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