diff --git a/Feldspar/C/feldspar_array.c b/Feldspar/C/feldspar_array.c deleted file mode 100644 --- a/Feldspar/C/feldspar_array.c +++ /dev/null @@ -1,61 +0,0 @@ -// -// Copyright (c) 2009-2011, ERICSSON AB -// All rights reserved. -// -// Redistribution and use in source and binary forms, with or without -// modification, are permitted provided that the following conditions are met: -// -// * Redistributions of source code must retain the above copyright notice, -// this list of conditions and the following disclaimer. -// * Redistributions in binary form must reproduce the above copyright -// notice, this list of conditions and the following disclaimer in the -// documentation and/or other materials provided with the distribution. -// * Neither the name of the ERICSSON AB nor the names of its contributors -// may be used to endorse or promote products derived from this software -// without specific prior written permission. -// -// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -// - -#include "feldspar_array.h" -#include -#include -#include - -/* Deep array copy with a given length */ -void copyArrayLen(struct array *to, struct array *from, int32_t len) -{ - assert(to); - assert(from); - if( from->elemSize < 0 ) - { - unsigned i; - for( i = 0; i < len; ++i ) - copyArray( &at(struct array, to, i), &at(struct array, from, i) ); - } - else - { - assert(to->buffer); - assert(from->buffer); - memcpy( to->buffer, from->buffer, len * from->elemSize ); - } -} - - -/* Reset array length by increasing it */ -void increaseLength(struct array *arr, int32_t len) -{ - assert(arr); - assert(arr->bytes >= abs(arr->elemSize) * (len + arr->length)); - arr->length += len; -} - diff --git a/Feldspar/C/feldspar_array.h b/Feldspar/C/feldspar_array.h deleted file mode 100644 --- a/Feldspar/C/feldspar_array.h +++ /dev/null @@ -1,112 +0,0 @@ -// -// Copyright (c) 2009-2011, ERICSSON AB -// All rights reserved. -// -// Redistribution and use in source and binary forms, with or without -// modification, are permitted provided that the following conditions are met: -// -// * Redistributions of source code must retain the above copyright notice, -// this list of conditions and the following disclaimer. -// * Redistributions in binary form must reproduce the above copyright -// notice, this list of conditions and the following disclaimer in the -// documentation and/or other materials provided with the distribution. -// * Neither the name of the ERICSSON AB nor the names of its contributors -// may be used to endorse or promote products derived from this software -// without specific prior written permission. -// -// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -// - -#ifndef FELDSPAR_ARRAY_H -#define FELDSPAR_ARRAY_H - -#include -#include -#include -#include - -// TODO qualify the names to avoid clashes with Haskell names - -struct array -{ - void* buffer; /* pointer to the buffer of elements */ - int32_t length; /* number of elements in the array */ - int32_t elemSize; /* size of elements in bytes; (- sizeof(struct array)) for nested arrays */ - uint32_t bytes; /* The number of bytes the buffer can hold */ -}; - -/* Indexing into an array: */ -/* Result: element of type 'type' */ -#define at(type,arr,idx) (((type*)((arr)->buffer))[idx]) - - -/* Deep array copy */ -static inline void copyArray(struct array *to, struct array *from) -{ - assert(to); - assert(from); - if( from->elemSize < 0 ) - { - unsigned i; - for( i = 0; i < from->length; ++i ) - copyArray( &at(struct array, to, i), &at(struct array, from, i) ); - } - else - { - assert(to->buffer); - assert(from->buffer); - memcpy( to->buffer, from->buffer, to->length * to->elemSize ); - } -} - -/* Deep array copy to a given position */ -static inline void copyArrayPos(struct array *to, unsigned pos, struct array *from) -{ - assert(to); - assert(from); - if( from->elemSize < 0 ) - { - unsigned i; - for( i = 0; i < from->length; ++i ) - copyArray( &at(struct array, to, i + pos), &at(struct array, from, i) ); - } - else - { - assert(to->buffer); - assert(from->buffer); - memcpy( (char*)(to->buffer) + pos * to->elemSize, from->buffer, to->length * to->elemSize ); - } -} - - -/* Deep array copy with a given length */ -void copyArrayLen(struct array *to, struct array *from, int32_t len); - -/* Array length */ -static inline int32_t getLength(struct array *arr) -{ - assert(arr); - return arr->length; -} - -/* (Re)set array length */ -static inline void setLength(struct array *arr, int32_t len) -{ - assert(arr); - assert(arr->bytes >= arr->length * abs(arr->elemSize)); - arr->length = len; -} - -/* Reset array length by increasing it */ -void increaseLength(struct array *arr, int32_t len); - -#endif diff --git a/Feldspar/C/feldspar_c99.c b/Feldspar/C/feldspar_c99.c deleted file mode 100644 --- a/Feldspar/C/feldspar_c99.c +++ /dev/null @@ -1,1893 +0,0 @@ -// -// Copyright (c) 2009-2011, ERICSSON AB -// All rights reserved. -// -// Redistribution and use in source and binary forms, with or without -// modification, are permitted provided that the following conditions are met: -// -// * Redistributions of source code must retain the above copyright notice, -// this list of conditions and the following disclaimer. -// * Redistributions in binary form must reproduce the above copyright -// notice, this list of conditions and the following disclaimer in the -// documentation and/or other materials provided with the distribution. -// * Neither the name of the ERICSSON AB nor the names of its contributors -// may be used to endorse or promote products derived from this software -// without specific prior written permission. -// -// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -// - -#include "feldspar_c99.h" - -#include -#include -#include -#include -#include - -#if defined(WIN32) - #include -#else - #include - #include -#endif /* WIN32 */ - - - -/*--------------------------------------------------------------------------* - * pow(), abs(), signum(), logBase() * - *--------------------------------------------------------------------------*/ - -int8_t pow_fun_int8( int8_t a, int8_t b ) -{ - int8_t r = 1; - int i; - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); - exit(1); - } - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -int16_t pow_fun_int16( int16_t a, int16_t b ) -{ - int16_t r = 1; - int i; - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); - exit(1); - } - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -int32_t pow_fun_int32( int32_t a, int32_t b ) -{ - int32_t r = 1; - int i; - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); - exit(1); - } - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -int64_t pow_fun_int64( int64_t a, int64_t b ) -{ - int64_t r = 1; - int i; - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %lld `pow` %lld", a, b); - exit(1); - } - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -uint8_t pow_fun_uint8( uint8_t a, uint8_t b ) -{ - uint8_t r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -uint16_t pow_fun_uint16( uint16_t a, uint16_t b ) -{ - uint16_t r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -uint32_t pow_fun_uint32( uint32_t a, uint32_t b ) -{ - uint32_t r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -uint64_t pow_fun_uint64( uint64_t a, uint64_t b ) -{ - uint64_t r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - - - -int8_t abs_fun_int8( int8_t a ) -{ - // From Bit Twiddling Hacks: - // "Compute the integer absolute value (abs) without branching" - int8_t mask = a >> 7; - return (a + mask) ^ mask; -} - -int16_t abs_fun_int16( int16_t a ) -{ - // From Bit Twiddling Hacks: - // "Compute the integer absolute value (abs) without branching" - int16_t mask = a >> 15; - return (a + mask) ^ mask; -} - -int32_t abs_fun_int32( int32_t a ) -{ - // From Bit Twiddling Hacks: - // "Compute the integer absolute value (abs) without branching" - int32_t mask = a >> 31; - return (a + mask) ^ mask; -} - -int64_t abs_fun_int64( int64_t a ) -{ - // From Bit Twiddling Hacks: - // "Compute the integer absolute value (abs) without branching" - int64_t mask = a >> 63; - return (a + mask) ^ mask; -} - - - -int8_t signum_fun_int8( int8_t a ) -{ - // From Bit Twiddling Hacks: "Compute the sign of an integer" - return (a != 0) | (a >> 7); -} - -int16_t signum_fun_int16( int16_t a ) -{ - // From Bit Twiddling Hacks: "Compute the sign of an integer" - return (a != 0) | (a >> 15); -} - -int32_t signum_fun_int32( int32_t a ) -{ - // From Bit Twiddling Hacks: "Compute the sign of an integer" - return (a != 0) | (a >> 31); -} - -int64_t signum_fun_int64( int64_t a ) -{ - // From Bit Twiddling Hacks: "Compute the sign of an integer" - return (a != 0) | (a >> 63); -} - -uint8_t signum_fun_uint8( uint8_t a ) -{ - return (a > 0); -} - -uint16_t signum_fun_uint16( uint16_t a ) -{ - return (a > 0); -} - -uint32_t signum_fun_uint32( uint32_t a ) -{ - return (a > 0); -} - -uint64_t signum_fun_uint64( uint64_t a ) -{ - return (a > 0); -} - -float signum_fun_float( float a ) -{ - // From Bit Twiddling Hacks: "Compute the sign of an integer" - return (a > 0) - (a < 0); -} - - - -float logBase_fun_float( float a, float b ) -{ - return logf(b) / logf(a); -} - - - -/*--------------------------------------------------------------------------* - * Bit operations * - *--------------------------------------------------------------------------*/ - -int8_t setBit_fun_int8( int8_t x, uint32_t i ) -{ - return x | 1 << i; -} - -int16_t setBit_fun_int16( int16_t x, uint32_t i ) -{ - return x | 1 << i; -} - -int32_t setBit_fun_int32( int32_t x, uint32_t i ) -{ - return x | 1 << i; -} - -int64_t setBit_fun_int64( int64_t x, uint32_t i ) -{ - return x | 1 << i; -} - -uint8_t setBit_fun_uint8( uint8_t x, uint32_t i ) -{ - return x | 1 << i; -} - -uint16_t setBit_fun_uint16( uint16_t x, uint32_t i ) -{ - return x | 1 << i; -} - -uint32_t setBit_fun_uint32( uint32_t x, uint32_t i ) -{ - return x | 1 << i; -} - -uint64_t setBit_fun_uint64( uint64_t x, uint32_t i ) -{ - return x | 1 << i; -} - - - -int8_t clearBit_fun_int8( int8_t x, uint32_t i ) -{ - return x & ~(1 << i); -} - -int16_t clearBit_fun_int16( int16_t x, uint32_t i ) -{ - return x & ~(1 << i); -} - -int32_t clearBit_fun_int32( int32_t x, uint32_t i ) -{ - return x & ~(1 << i); -} - -int64_t clearBit_fun_int64( int64_t x, uint32_t i ) -{ - return x & ~(1 << i); -} - -uint8_t clearBit_fun_uint8( uint8_t x, uint32_t i ) -{ - return x & ~(1 << i); -} - -uint16_t clearBit_fun_uint16( uint16_t x, uint32_t i ) -{ - return x & ~(1 << i); -} - -uint32_t clearBit_fun_uint32( uint32_t x, uint32_t i ) -{ - return x & ~(1 << i); -} - -uint64_t clearBit_fun_uint64( uint64_t x, uint32_t i ) -{ - return x & ~(1 << i); -} - - - -int8_t complementBit_fun_int8( int8_t x, uint32_t i ) -{ - return x ^ 1 << i; -} - -int16_t complementBit_fun_int16( int16_t x, uint32_t i ) -{ - return x ^ 1 << i; -} - -int32_t complementBit_fun_int32( int32_t x, uint32_t i ) -{ - return x ^ 1 << i; -} - -int64_t complementBit_fun_int64( int64_t x, uint32_t i ) -{ - return x ^ 1 << i; -} - -uint8_t complementBit_fun_uint8( uint8_t x, uint32_t i ) -{ - return x ^ 1 << i; -} - -uint16_t complementBit_fun_uint16( uint16_t x, uint32_t i ) -{ - return x ^ 1 << i; -} - -uint32_t complementBit_fun_uint32( uint32_t x, uint32_t i ) -{ - return x ^ 1 << i; -} - -uint64_t complementBit_fun_uint64( uint64_t x, uint32_t i ) -{ - return x ^ 1 << i; -} - - - -int testBit_fun_int8( int8_t x, uint32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_int16( int16_t x, uint32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_int32( int32_t x, uint32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_int64( int64_t x, uint32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uint8( uint8_t x, uint32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uint16( uint16_t x, uint32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uint32( uint32_t x, uint32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uint64( uint64_t x, uint32_t i ) -{ - return (x & 1 << i) != 0; -} - - - -int8_t rotateL_fun_int8( int8_t x, int32_t i ) -{ - if ((i %= 8) == 0) return x; - return (x << i) | ((0x7f >> (7 - i)) & (x >> (8 - i))); -} - -int16_t rotateL_fun_int16( int16_t x, int32_t i ) -{ - if ((i %= 16) == 0) return x; - return (x << i) | ((0x7fff >> (15 - i)) & (x >> (16 - i))); -} - -int32_t rotateL_fun_int32( int32_t x, int32_t i ) -{ - if ((i %= 32) == 0) return x; - return (x << i) | ((0x7fffffff >> (31 - i)) & (x >> (32 - i))); -} - -int64_t rotateL_fun_int64( int64_t x, int32_t i ) -{ - if ((i %= 64) == 0) return x; - return (x << i) | ((0x7fffffffffffffffll >> (63 - i)) & (x >> (64 - i))); -} - -uint8_t rotateL_fun_uint8( uint8_t x, int32_t i ) -{ - if ((i %= 8) == 0) return x; - return (x << i) | (x >> (8 - i)); -} - -uint16_t rotateL_fun_uint16( uint16_t x, int32_t i ) -{ - if ((i %= 16) == 0) return x; - return (x << i) | (x >> (16 - i)); -} - -uint32_t rotateL_fun_uint32( uint32_t x, int32_t i ) -{ - if ((i %= 32) == 0) return x; - return (x << i) | (x >> (32 - i)); -} - -uint64_t rotateL_fun_uint64( uint64_t x, int32_t i ) -{ - if ((i %= 64) == 0) return x; - return (x << i) | (x >> (64 - i)); -} - - - -int8_t rotateR_fun_int8( int8_t x, int32_t i ) -{ - if ((i %= 8) == 0) return x; - return (x << (8 - i)) | ((0x7f >> (i - 1)) & (x >> i)); -} - -int16_t rotateR_fun_int16( int16_t x, int32_t i ) -{ - if ((i %= 16) == 0) return x; - return (x << (16 - i)) | ((0x7fff >> (i - 1)) & (x >> i)); -} - -int32_t rotateR_fun_int32( int32_t x, int32_t i ) -{ - if ((i %= 32) == 0) return x; - return (x << (32 - i)) | ((0x7fffffff >> (i - 1)) & (x >> i)); -} - -int64_t rotateR_fun_int64( int64_t x, int32_t i ) -{ - if ((i %= 64) == 0) return x; - return (x << (64 - i)) | ((0x7fffffffffffffffll >> (i - 1)) & (x >> i)); -} - -uint8_t rotateR_fun_uint8( uint8_t x, int32_t i ) -{ - if ((i %= 8) == 0) return x; - return (x << (8 - i)) | (x >> i); -} - -uint16_t rotateR_fun_uint16( uint16_t x, int32_t i ) -{ - if ((i %= 16) == 0) return x; - return (x << (16 - i)) | (x >> i); -} - -uint32_t rotateR_fun_uint32( uint32_t x, int32_t i ) -{ - if ((i %= 32) == 0) return x; - return (x << (32 - i)) | (x >> i); -} - -uint64_t rotateR_fun_uint64( uint64_t x, int32_t i ) -{ - if ((i %= 64) == 0) return x; - return (x << (64 - i)) | (x >> i); -} - - - -int8_t reverseBits_fun_int8( int8_t x ) -{ - int8_t r = x; - int i = 7; - for (x = x >> 1 & 0x7f; x; x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -int16_t reverseBits_fun_int16( int16_t x ) -{ - int16_t r = x; - int i = 15; - for (x = x >> 1 & 0x7fff; x; x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -int32_t reverseBits_fun_int32( int32_t x ) -{ - int32_t r = x; - int i = 31; - for (x = x >> 1 & 0x7fffffff; x; x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -int64_t reverseBits_fun_int64( int64_t x ) -{ - int64_t r = x; - int i = 63; - for (x = x >> 1 & 0x7fffffffffffffffll; x; x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -uint8_t reverseBits_fun_uint8( uint8_t x ) -{ - uint8_t r = x; - int i = 7; - while (x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -uint16_t reverseBits_fun_uint16( uint16_t x ) -{ - uint16_t r = x; - int i = 15; - while (x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -uint32_t reverseBits_fun_uint32( uint32_t x ) -{ - uint32_t r = x; - int i = 31; - while (x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -uint64_t reverseBits_fun_uint64( uint64_t x ) -{ - uint64_t r = x; - int i = 63; - while (x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - - - -uint32_t bitScan_fun_int8( int8_t x ) -{ - uint32_t r = 0; - int8_t s = (x & 0x80); - if (x == 0) return 7; - while ((int8_t)((x <<= 1) & 0x80) == s) - ++r; - return r; -} - -uint32_t bitScan_fun_int16( int16_t x ) -{ - uint32_t r = 0; - int16_t s = (x & 0x8000); - if (x == 0) return 15; - while ((int16_t)((x <<= 1) & 0x8000) == s) - ++r; - return r; -} - -uint32_t bitScan_fun_int32( int32_t x ) -{ - uint32_t r = 0; - int32_t s = (x & 0x80000000); - if (x == 0) return 31; - while ((int32_t)((x <<= 1) & 0x80000000) == s) - ++r; - return r; -} - -uint32_t bitScan_fun_int64( int64_t x ) -{ - uint32_t r = 0; - int64_t s = (x & 0x8000000000000000ll); - if (x == 0) return 63; - while ((int64_t)((x <<= 1) & 0x8000000000000000ll) == s) - ++r; - return r; -} - -uint32_t bitScan_fun_uint8( uint8_t x ) -{ - uint32_t r = 8; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -uint32_t bitScan_fun_uint16( uint16_t x ) -{ - uint32_t r = 16; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -uint32_t bitScan_fun_uint32( uint32_t x ) -{ - uint32_t r = 32; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -uint32_t bitScan_fun_uint64( uint64_t x ) -{ - uint32_t r = 64; - while (x) - { - --r; - x >>= 1; - } - return r; -} - - - -uint32_t bitCount_fun_int8( int8_t x ) -{ - uint32_t r = x & 1; - for (x = x >> 1 & 0x7f; x; x >>= 1) - r += x & 1; - return r; -} - -uint32_t bitCount_fun_int16( int16_t x ) -{ - uint32_t r = x & 1; - for (x = x >> 1 & 0x7fff; x; x >>= 1) - r += x & 1; - return r; -} - -uint32_t bitCount_fun_int32( int32_t x ) -{ - uint32_t r = x & 1; - for (x = x >> 1 & 0x7fffffff; x; x >>= 1) - r += x & 1; - return r; -} - -uint32_t bitCount_fun_int64( int64_t x ) -{ - uint32_t r = x & 1; - for (x = x >> 1 & 0x7fffffffffffffffll; x; x >>= 1) - r += x & 1; - return r; -} - -uint32_t bitCount_fun_uint8( uint8_t x ) -{ - uint32_t r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -uint32_t bitCount_fun_uint16( uint16_t x ) -{ - uint32_t r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -uint32_t bitCount_fun_uint32( uint32_t x ) -{ - uint32_t r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -uint32_t bitCount_fun_uint64( uint64_t x ) -{ - uint32_t r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - - - -/*--------------------------------------------------------------------------* - * Complex numbers * - *--------------------------------------------------------------------------*/ - -int equal_fun_complexOf_int8( complexOf_int8 a, complexOf_int8 b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_int16( complexOf_int16 a, complexOf_int16 b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_int32( complexOf_int32 a, complexOf_int32 b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_int64( complexOf_int64 a, complexOf_int64 b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_uint8( complexOf_uint8 a, complexOf_uint8 b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_uint16( complexOf_uint16 a, complexOf_uint16 b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_uint32( complexOf_uint32 a, complexOf_uint32 b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_uint64( complexOf_uint64 a, complexOf_uint64 b ) -{ - return a.re == b.re && a.im == b.im; -} - - - -complexOf_int8 negate_fun_complexOf_int8( complexOf_int8 a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_int16 negate_fun_complexOf_int16( complexOf_int16 a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_int32 negate_fun_complexOf_int32( complexOf_int32 a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_int64 negate_fun_complexOf_int64( complexOf_int64 a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_uint8 negate_fun_complexOf_uint8( complexOf_uint8 a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_uint16 negate_fun_complexOf_uint16( complexOf_uint16 a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_uint32 negate_fun_complexOf_uint32( complexOf_uint32 a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_uint64 negate_fun_complexOf_uint64( complexOf_uint64 a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - - - -complexOf_int8 abs_fun_complexOf_int8( complexOf_int8 a ) -{ - a.re = magnitude_fun_complexOf_int8(a); - a.im = 0; - return a; -} - -complexOf_int16 abs_fun_complexOf_int16( complexOf_int16 a ) -{ - a.re = magnitude_fun_complexOf_int16(a); - a.im = 0; - return a; -} - -complexOf_int32 abs_fun_complexOf_int32( complexOf_int32 a ) -{ - a.re = magnitude_fun_complexOf_int32(a); - a.im = 0; - return a; -} - -complexOf_int64 abs_fun_complexOf_int64( complexOf_int64 a ) -{ - a.re = magnitude_fun_complexOf_int64(a); - a.im = 0; - return a; -} - -complexOf_uint8 abs_fun_complexOf_uint8( complexOf_uint8 a ) -{ - a.re = magnitude_fun_complexOf_uint8(a); - a.im = 0; - return a; -} - -complexOf_uint16 abs_fun_complexOf_uint16( complexOf_uint16 a ) -{ - a.re = magnitude_fun_complexOf_uint16(a); - a.im = 0; - return a; -} - -complexOf_uint32 abs_fun_complexOf_uint32( complexOf_uint32 a ) -{ - a.re = magnitude_fun_complexOf_uint32(a); - a.im = 0; - return a; -} - -complexOf_uint64 abs_fun_complexOf_uint64( complexOf_uint64 a ) -{ - a.re = magnitude_fun_complexOf_uint64(a); - a.im = 0; - return a; -} - - - -complexOf_int8 signum_fun_complexOf_int8( complexOf_int8 a ) -{ - int8_t m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_int8(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_int16 signum_fun_complexOf_int16( complexOf_int16 a ) -{ - int16_t m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_int16(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_int32 signum_fun_complexOf_int32( complexOf_int32 a ) -{ - int32_t m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_int32(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_int64 signum_fun_complexOf_int64( complexOf_int64 a ) -{ - int64_t m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_int64(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_uint8 signum_fun_complexOf_uint8( complexOf_uint8 a ) -{ - uint8_t m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_uint8(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_uint16 signum_fun_complexOf_uint16( complexOf_uint16 a ) -{ - uint16_t m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_uint16(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_uint32 signum_fun_complexOf_uint32( complexOf_uint32 a ) -{ - uint32_t m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_uint32(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_uint64 signum_fun_complexOf_uint64( complexOf_uint64 a ) -{ - uint64_t m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_uint64(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -float complex signum_fun_complexOf_float( float complex a ) -{ - float m; - if (a == 0) { - return a; - } else { - m = cabsf(a); - return crealf(a) / m + cimagf(a) / m * I; - } -} - - - -complexOf_int8 add_fun_complexOf_int8( complexOf_int8 a, complexOf_int8 b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_int16 add_fun_complexOf_int16( complexOf_int16 a, complexOf_int16 b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_int32 add_fun_complexOf_int32( complexOf_int32 a, complexOf_int32 b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_int64 add_fun_complexOf_int64( complexOf_int64 a, complexOf_int64 b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_uint8 add_fun_complexOf_uint8( complexOf_uint8 a, complexOf_uint8 b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_uint16 add_fun_complexOf_uint16( complexOf_uint16 a, complexOf_uint16 b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_uint32 add_fun_complexOf_uint32( complexOf_uint32 a, complexOf_uint32 b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_uint64 add_fun_complexOf_uint64( complexOf_uint64 a, complexOf_uint64 b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - - - -complexOf_int8 sub_fun_complexOf_int8( complexOf_int8 a, complexOf_int8 b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_int16 sub_fun_complexOf_int16( complexOf_int16 a, complexOf_int16 b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_int32 sub_fun_complexOf_int32( complexOf_int32 a, complexOf_int32 b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_int64 sub_fun_complexOf_int64( complexOf_int64 a, complexOf_int64 b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_uint8 sub_fun_complexOf_uint8( complexOf_uint8 a, complexOf_uint8 b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_uint16 sub_fun_complexOf_uint16( complexOf_uint16 a, complexOf_uint16 b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_uint32 sub_fun_complexOf_uint32( complexOf_uint32 a, complexOf_uint32 b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_uint64 sub_fun_complexOf_uint64( complexOf_uint64 a, complexOf_uint64 b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - - - -complexOf_int8 mult_fun_complexOf_int8( complexOf_int8 a, complexOf_int8 b ) -{ - complexOf_int8 r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_int16 mult_fun_complexOf_int16( complexOf_int16 a, complexOf_int16 b ) -{ - complexOf_int16 r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_int32 mult_fun_complexOf_int32( complexOf_int32 a, complexOf_int32 b ) -{ - complexOf_int32 r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_int64 mult_fun_complexOf_int64( complexOf_int64 a, complexOf_int64 b ) -{ - complexOf_int64 r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_uint8 mult_fun_complexOf_uint8( complexOf_uint8 a, complexOf_uint8 b ) -{ - complexOf_uint8 r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_uint16 mult_fun_complexOf_uint16( complexOf_uint16 a, complexOf_uint16 b ) -{ - complexOf_uint16 r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_uint32 mult_fun_complexOf_uint32( complexOf_uint32 a, complexOf_uint32 b ) -{ - complexOf_uint32 r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_uint64 mult_fun_complexOf_uint64( complexOf_uint64 a, complexOf_uint64 b ) -{ - complexOf_uint64 r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -#ifdef __FreeBSD__ -float complex clogf( float complex x ) -{ - return (I * atan2f(cimagf(x), crealf(x))) + logf(cabsf(x)); -} -#endif - - -float complex logBase_fun_complexOf_float( float complex a, float complex b ) -{ - return clogf(b) / clogf(a); -} - - - -complexOf_int8 complex_fun_int8( int8_t re, int8_t im ) -{ - complexOf_int8 r; - r.re = re; - r.im = im; - return r; -} - -complexOf_int16 complex_fun_int16( int16_t re, int16_t im ) -{ - complexOf_int16 r; - r.re = re; - r.im = im; - return r; -} - -complexOf_int32 complex_fun_int32( int32_t re, int32_t im ) -{ - complexOf_int32 r; - r.re = re; - r.im = im; - return r; -} - -complexOf_int64 complex_fun_int64( int64_t re, int64_t im ) -{ - complexOf_int64 r; - r.re = re; - r.im = im; - return r; -} - -complexOf_uint8 complex_fun_uint8( uint8_t re, uint8_t im ) -{ - complexOf_uint8 r; - r.re = re; - r.im = im; - return r; -} - -complexOf_uint16 complex_fun_uint16( uint16_t re, uint16_t im ) -{ - complexOf_uint16 r; - r.re = re; - r.im = im; - return r; -} - -complexOf_uint32 complex_fun_uint32( uint32_t re, uint32_t im ) -{ - complexOf_uint32 r; - r.re = re; - r.im = im; - return r; -} - -complexOf_uint64 complex_fun_uint64( uint64_t re, uint64_t im ) -{ - complexOf_uint64 r; - r.re = re; - r.im = im; - return r; -} - -float complex complex_fun_float( float re, float im ) -{ - return ( re + im * I ); -} - - - -int8_t creal_fun_complexOf_int8( complexOf_int8 a ) -{ - return a.re; -} - -int16_t creal_fun_complexOf_int16( complexOf_int16 a ) -{ - return a.re; -} - -int32_t creal_fun_complexOf_int32( complexOf_int32 a ) -{ - return a.re; -} - -int64_t creal_fun_complexOf_int64( complexOf_int64 a ) -{ - return a.re; -} - -uint8_t creal_fun_complexOf_uint8( complexOf_uint8 a ) -{ - return a.re; -} - -uint16_t creal_fun_complexOf_uint16( complexOf_uint16 a ) -{ - return a.re; -} - -uint32_t creal_fun_complexOf_uint32( complexOf_uint32 a ) -{ - return a.re; -} - -uint64_t creal_fun_complexOf_uint64( complexOf_uint64 a ) -{ - return a.re; -} - - - -int8_t cimag_fun_complexOf_int8( complexOf_int8 a ) -{ - return a.im; -} - -int16_t cimag_fun_complexOf_int16( complexOf_int16 a ) -{ - return a.im; -} - -int32_t cimag_fun_complexOf_int32( complexOf_int32 a ) -{ - return a.im; -} - -int64_t cimag_fun_complexOf_int64( complexOf_int64 a ) -{ - return a.im; -} - -uint8_t cimag_fun_complexOf_uint8( complexOf_uint8 a ) -{ - return a.im; -} - -uint16_t cimag_fun_complexOf_uint16( complexOf_uint16 a ) -{ - return a.im; -} - -uint32_t cimag_fun_complexOf_uint32( complexOf_uint32 a ) -{ - return a.im; -} - -uint64_t cimag_fun_complexOf_uint64( complexOf_uint64 a ) -{ - return a.im; -} - - - -complexOf_int8 conj_fun_complexOf_int8( complexOf_int8 a ) -{ - a.im = -a.im; - return a; -} - -complexOf_int16 conj_fun_complexOf_int16( complexOf_int16 a ) -{ - a.im = -a.im; - return a; -} - -complexOf_int32 conj_fun_complexOf_int32( complexOf_int32 a ) -{ - a.im = -a.im; - return a; -} - -complexOf_int64 conj_fun_complexOf_int64( complexOf_int64 a ) -{ - a.im = -a.im; - return a; -} - -complexOf_uint8 conj_fun_complexOf_uint8( complexOf_uint8 a ) -{ - a.im = -a.im; - return a; -} - -complexOf_uint16 conj_fun_complexOf_uint16( complexOf_uint16 a ) -{ - a.im = -a.im; - return a; -} - -complexOf_uint32 conj_fun_complexOf_uint32( complexOf_uint32 a ) -{ - a.im = -a.im; - return a; -} - -complexOf_uint64 conj_fun_complexOf_uint64( complexOf_uint64 a ) -{ - a.im = -a.im; - return a; -} - - - -int8_t magnitude_fun_complexOf_int8( complexOf_int8 a ) -{ - return lroundf(hypotf(a.re, a.im)); -} - -int16_t magnitude_fun_complexOf_int16( complexOf_int16 a ) -{ - return lroundf(hypotf(a.re, a.im)); -} - -int32_t magnitude_fun_complexOf_int32( complexOf_int32 a ) -{ - return lroundf(hypotf(a.re, a.im)); -} - -int64_t magnitude_fun_complexOf_int64( complexOf_int64 a ) -{ - return llroundf(hypotf(a.re, a.im)); -} - -uint8_t magnitude_fun_complexOf_uint8( complexOf_uint8 a ) -{ - return lroundf(hypotf(a.re, a.im)); -} - -uint16_t magnitude_fun_complexOf_uint16( complexOf_uint16 a ) -{ - return lroundf(hypotf(a.re, a.im)); -} - -uint32_t magnitude_fun_complexOf_uint32( complexOf_uint32 a ) -{ - return lroundf(hypotf(a.re, a.im)); -} - -uint64_t magnitude_fun_complexOf_uint64( complexOf_uint64 a ) -{ - return llroundf(hypotf(a.re, a.im)); -} - - - -int8_t phase_fun_complexOf_int8( complexOf_int8 a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return lroundf(atan2f(a.im, a.re)); -} - -int16_t phase_fun_complexOf_int16( complexOf_int16 a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return lroundf(atan2f(a.im, a.re)); -} - -int32_t phase_fun_complexOf_int32( complexOf_int32 a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return lroundf(atan2f(a.im, a.re)); -} - -int64_t phase_fun_complexOf_int64( complexOf_int64 a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return llroundf(atan2f(a.im, a.re)); -} - -uint8_t phase_fun_complexOf_uint8( complexOf_uint8 a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return lroundf(atan2f(a.im, a.re)); -} - -uint16_t phase_fun_complexOf_uint16( complexOf_uint16 a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return lroundf(atan2f(a.im, a.re)); -} - -uint32_t phase_fun_complexOf_uint32( complexOf_uint32 a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return lroundf(atan2f(a.im, a.re)); -} - -uint64_t phase_fun_complexOf_uint64( complexOf_uint64 a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return llroundf(atan2f(a.im, a.re)); -} - - - -complexOf_int8 mkPolar_fun_int8( int8_t r, int8_t t ) -{ - complexOf_int8 a; - a.re = lroundf(r * cosf(t)); - a.im = lroundf(r * sinf(t)); - return a; -} - -complexOf_int16 mkPolar_fun_int16( int16_t r, int16_t t ) -{ - complexOf_int16 a; - a.re = lroundf(r * cosf(t)); - a.im = lroundf(r * sinf(t)); - return a; -} - -complexOf_int32 mkPolar_fun_int32( int32_t r, int32_t t ) -{ - complexOf_int32 a; - a.re = lroundf(r * cosf(t)); - a.im = lroundf(r * sinf(t)); - return a; -} - -complexOf_int64 mkPolar_fun_int64( int64_t r, int64_t t ) -{ - complexOf_int64 a; - a.re = llroundf(r * cosf(t)); - a.im = llroundf(r * sinf(t)); - return a; -} - -complexOf_uint8 mkPolar_fun_uint8( uint8_t r, uint8_t t ) -{ - complexOf_uint8 a; - a.re = lroundf(r * cosf(t)); - a.im = lroundf(r * sinf(t)); - return a; -} - -complexOf_uint16 mkPolar_fun_uint16( uint16_t r, uint16_t t ) -{ - complexOf_uint16 a; - a.re = lroundf(r * cosf(t)); - a.im = lroundf(r * sinf(t)); - return a; -} - -complexOf_uint32 mkPolar_fun_uint32( uint32_t r, uint32_t t ) -{ - complexOf_uint32 a; - a.re = lroundf(r * cosf(t)); - a.im = lroundf(r * sinf(t)); - return a; -} - -complexOf_uint64 mkPolar_fun_uint64( uint64_t r, uint64_t t ) -{ - complexOf_uint64 a; - a.re = llroundf(r * cosf(t)); - a.im = llroundf(r * sinf(t)); - return a; -} - -float complex mkPolar_fun_float( float r, float t ) -{ - return r * cosf(t) + r * sinf(t) * I; -} - - - -complexOf_int8 cis_fun_int8( int8_t t ) -{ - complexOf_int8 r; - r.re = lroundf(cosf(t)); - r.im = lroundf(sinf(t)); - return r; -} - -complexOf_int16 cis_fun_int16( int16_t t ) -{ - complexOf_int16 r; - r.re = lroundf(cosf(t)); - r.im = lroundf(sinf(t)); - return r; -} - -complexOf_int32 cis_fun_int32( int32_t t ) -{ - complexOf_int32 r; - r.re = lroundf(cosf(t)); - r.im = lroundf(sinf(t)); - return r; -} - -complexOf_int64 cis_fun_int64( int64_t t ) -{ - complexOf_int64 r; - r.re = llroundf(cosf(t)); - r.im = llroundf(sinf(t)); - return r; -} - -complexOf_uint8 cis_fun_uint8( uint8_t t ) -{ - complexOf_uint8 r; - r.re = lroundf(cosf(t)); - r.im = lroundf(sinf(t)); - return r; -} - -complexOf_uint16 cis_fun_uint16( uint16_t t ) -{ - complexOf_uint16 r; - r.re = lroundf(cosf(t)); - r.im = lroundf(sinf(t)); - return r; -} - -complexOf_uint32 cis_fun_uint32( uint32_t t ) -{ - complexOf_uint32 r; - r.re = lroundf(cosf(t)); - r.im = lroundf(sinf(t)); - return r; -} - -complexOf_uint64 cis_fun_uint64( uint64_t t ) -{ - complexOf_uint64 r; - r.re = llroundf(cosf(t)); - r.im = llroundf(sinf(t)); - return r; -} - -float complex cis_fun_float( float t ) -{ - return cosf(t) + sinf(t) * I; -} - - - -/*--------------------------------------------------------------------------* - * Trace functions * - *--------------------------------------------------------------------------*/ - -static FILE *trace_log_file; - -#if defined(WIN32) - -static DWORD trace_start_time; - -void traceStart() -{ - SYSTEMTIME lt; - GetLocalTime(<); - char str [256]; - sprintf(str, "trace-%04d%02d%02d-%02d%02d%02d.log", - lt.wYear, lt.wMonth, lt.wDay, lt.wHour, lt.wMinute, lt.wSecond); - trace_log_file = fopen(str, "a"); - if (trace_log_file == NULL) { - fprintf(stderr,"Can not open trace file.\n"); - exit (8); - } - fprintf(trace_log_file, - "Logging started at %02d-%02d-%04d %02d:%02d:%02d.\n", - lt.wDay, lt.wMonth, lt.wYear, lt.wHour, lt.wMinute, lt.wSecond); - fflush(trace_log_file); - trace_start_time = GetTickCount(); -} - -void elapsedTimeString( char* str ) -{ - DWORD diff_ms = GetTickCount() - trace_start_time; - DWORD diff = diff_ms / 1000; - diff_ms = diff_ms % 1000; - sprintf(str, "%d.%.3d", diff, diff_ms); -} - -#else - -static struct timeval trace_start_time; - -void traceStart() -{ - gettimeofday(&trace_start_time, NULL); - struct tm * timeinfo = localtime(&(trace_start_time.tv_sec)); - char timestr [80]; - char str [256]; - strftime(timestr, 80, "%Y%m%d-%H%M%S", timeinfo); - sprintf(str, "trace-%s.log", timestr); - trace_log_file = fopen(str, "a"); - if (trace_log_file == NULL) { - fprintf(stderr,"Can not open trace file.\n"); - exit (8); - } - strftime(timestr, 80, "%d-%b-%Y %H:%M:%S", timeinfo); - fprintf(trace_log_file, "Logging started at %s.\n", timestr); - fflush(trace_log_file); - gettimeofday(&trace_start_time, NULL); -} - -void elapsedTimeString( char* str ) -{ - struct timeval tv; - gettimeofday (&tv, NULL); - if (trace_start_time.tv_usec <= tv.tv_usec) { - tv.tv_sec = tv.tv_sec - trace_start_time.tv_sec; - tv.tv_usec = tv.tv_usec - trace_start_time.tv_usec; - } else { - tv.tv_sec = tv.tv_sec - trace_start_time.tv_sec - 1; - tv.tv_usec = 1000000 + tv.tv_usec - trace_start_time.tv_usec; - } - sprintf(str, "%ld.%06d", tv.tv_sec, tv.tv_usec); -} - -#endif /* WIN32 */ - -void traceEnd() -{ - fprintf(trace_log_file, "Logging finished.\n"); - fclose(trace_log_file); -} - -void trace_int8( int8_t val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_int16( int16_t val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_int32( int32_t val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_int64( int64_t val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%lld\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_uint8( uint8_t val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_uint16( uint16_t val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_uint32( uint32_t val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_uint64( uint64_t val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%llu\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_float( float val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%f\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_complexOf_int8( complexOf_int8 val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_int16( complexOf_int16 val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_int32( complexOf_int32 val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_int64( complexOf_int64 val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%lld+%lld*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_uint8( complexOf_uint8 val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_uint16( complexOf_uint16 val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_uint32( complexOf_uint32 val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_uint64( complexOf_uint64 val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%llu+%llu*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_float( float complex val, int32_t id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%f+%f*I\n", id, timestr, creal(val), cimag(val)); - fflush(trace_log_file); -} - diff --git a/Feldspar/C/feldspar_c99.h b/Feldspar/C/feldspar_c99.h deleted file mode 100644 --- a/Feldspar/C/feldspar_c99.h +++ /dev/null @@ -1,356 +0,0 @@ -// -// Copyright (c) 2009-2011, ERICSSON AB -// All rights reserved. -// -// Redistribution and use in source and binary forms, with or without -// modification, are permitted provided that the following conditions are met: -// -// * Redistributions of source code must retain the above copyright notice, -// this list of conditions and the following disclaimer. -// * Redistributions in binary form must reproduce the above copyright -// notice, this list of conditions and the following disclaimer in the -// documentation and/or other materials provided with the distribution. -// * Neither the name of the ERICSSON AB nor the names of its contributors -// may be used to endorse or promote products derived from this software -// without specific prior written permission. -// -// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -// - -#ifndef FELDSPAR_C99_H -#define FELDSPAR_C99_H - -#include -#include - - - -#define min(X, Y) ((X) < (Y) ? (X) : (Y)) -#define max(X, Y) ((X) > (Y) ? (X) : (Y)) - -int8_t pow_fun_int8( int8_t, int8_t ); -int16_t pow_fun_int16( int16_t, int16_t ); -int32_t pow_fun_int32( int32_t, int32_t ); -int64_t pow_fun_int64( int64_t, int64_t ); -uint8_t pow_fun_uint8( uint8_t, uint8_t ); -uint16_t pow_fun_uint16( uint16_t, uint16_t ); -uint32_t pow_fun_uint32( uint32_t, uint32_t ); -uint64_t pow_fun_uint64( uint64_t, uint64_t ); - -int8_t abs_fun_int8( int8_t ); -int16_t abs_fun_int16( int16_t ); -int32_t abs_fun_int32( int32_t ); -int64_t abs_fun_int64( int64_t ); - -int8_t signum_fun_int8( int8_t ); -int16_t signum_fun_int16( int16_t ); -int32_t signum_fun_int32( int32_t ); -int64_t signum_fun_int64( int64_t ); -uint8_t signum_fun_uint8( uint8_t ); -uint16_t signum_fun_uint16( uint16_t ); -uint32_t signum_fun_uint32( uint32_t ); -uint64_t signum_fun_uint64( uint64_t ); -float signum_fun_float( float ); - -float logBase_fun_float( float, float ); - - - -int8_t setBit_fun_int8( int8_t, uint32_t ); -int16_t setBit_fun_int16( int16_t, uint32_t ); -int32_t setBit_fun_int32( int32_t, uint32_t ); -int64_t setBit_fun_int64( int64_t, uint32_t ); -uint8_t setBit_fun_uint8( uint8_t, uint32_t ); -uint16_t setBit_fun_uint16( uint16_t, uint32_t ); -uint32_t setBit_fun_uint32( uint32_t, uint32_t ); -uint64_t setBit_fun_uint64( uint64_t, uint32_t ); - -int8_t clearBit_fun_int8( int8_t, uint32_t ); -int16_t clearBit_fun_int16( int16_t, uint32_t ); -int32_t clearBit_fun_int32( int32_t, uint32_t ); -int64_t clearBit_fun_int64( int64_t, uint32_t ); -uint8_t clearBit_fun_uint8( uint8_t, uint32_t ); -uint16_t clearBit_fun_uint16( uint16_t, uint32_t ); -uint32_t clearBit_fun_uint32( uint32_t, uint32_t ); -uint64_t clearBit_fun_uint64( uint64_t, uint32_t ); - -int8_t complementBit_fun_int8( int8_t, uint32_t ); -int16_t complementBit_fun_int16( int16_t, uint32_t ); -int32_t complementBit_fun_int32( int32_t, uint32_t ); -int64_t complementBit_fun_int64( int64_t, uint32_t ); -uint8_t complementBit_fun_uint8( uint8_t, uint32_t ); -uint16_t complementBit_fun_uint16( uint16_t, uint32_t ); -uint32_t complementBit_fun_uint32( uint32_t, uint32_t ); -uint64_t complementBit_fun_uint64( uint64_t, uint32_t ); - -int testBit_fun_int8( int8_t, uint32_t ); -int testBit_fun_int16( int16_t, uint32_t ); -int testBit_fun_int32( int32_t, uint32_t ); -int testBit_fun_int64( int64_t, uint32_t ); -int testBit_fun_uint8( uint8_t, uint32_t ); -int testBit_fun_uint16( uint16_t, uint32_t ); -int testBit_fun_uint32( uint32_t, uint32_t ); -int testBit_fun_uint64( uint64_t, uint32_t ); - -int8_t rotateL_fun_int8( int8_t, int32_t ); -int16_t rotateL_fun_int16( int16_t, int32_t ); -int32_t rotateL_fun_int32( int32_t, int32_t ); -int64_t rotateL_fun_int64( int64_t, int32_t ); -uint8_t rotateL_fun_uint8( uint8_t, int32_t ); -uint16_t rotateL_fun_uint16( uint16_t, int32_t ); -uint32_t rotateL_fun_uint32( uint32_t, int32_t ); -uint64_t rotateL_fun_uint64( uint64_t, int32_t ); - -int8_t rotateR_fun_int8( int8_t, int32_t ); -int16_t rotateR_fun_int16( int16_t, int32_t ); -int32_t rotateR_fun_int32( int32_t, int32_t ); -int64_t rotateR_fun_int64( int64_t, int32_t ); -uint8_t rotateR_fun_uint8( uint8_t, int32_t ); -uint16_t rotateR_fun_uint16( uint16_t, int32_t ); -uint32_t rotateR_fun_uint32( uint32_t, int32_t ); -uint64_t rotateR_fun_uint64( uint64_t, int32_t ); - -int8_t reverseBits_fun_int8( int8_t ); -int16_t reverseBits_fun_int16( int16_t ); -int32_t reverseBits_fun_int32( int32_t ); -int64_t reverseBits_fun_int64( int64_t ); -uint8_t reverseBits_fun_uint8( uint8_t ); -uint16_t reverseBits_fun_uint16( uint16_t ); -uint32_t reverseBits_fun_uint32( uint32_t ); -uint64_t reverseBits_fun_uint64( uint64_t ); - -uint32_t bitScan_fun_int8( int8_t ); -uint32_t bitScan_fun_int16( int16_t ); -uint32_t bitScan_fun_int32( int32_t ); -uint32_t bitScan_fun_int64( int64_t ); -uint32_t bitScan_fun_uint8( uint8_t ); -uint32_t bitScan_fun_uint16( uint16_t ); -uint32_t bitScan_fun_uint32( uint32_t ); -uint32_t bitScan_fun_uint64( uint64_t ); - -uint32_t bitCount_fun_int8( int8_t ); -uint32_t bitCount_fun_int16( int16_t ); -uint32_t bitCount_fun_int32( int32_t ); -uint32_t bitCount_fun_int64( int64_t ); -uint32_t bitCount_fun_uint8( uint8_t ); -uint32_t bitCount_fun_uint16( uint16_t ); -uint32_t bitCount_fun_uint32( uint32_t ); -uint32_t bitCount_fun_uint64( uint64_t ); - - - -typedef struct { - int8_t re; - int8_t im; -} complexOf_int8; - -typedef struct { - int16_t re; - int16_t im; -} complexOf_int16; - -typedef struct { - int32_t re; - int32_t im; -} complexOf_int32; - -typedef struct { - int64_t re; - int64_t im; -} complexOf_int64; - -typedef struct { - uint8_t re; - uint8_t im; -} complexOf_uint8; - -typedef struct { - uint16_t re; - uint16_t im; -} complexOf_uint16; - -typedef struct { - uint32_t re; - uint32_t im; -} complexOf_uint32; - -typedef struct { - uint64_t re; - uint64_t im; -} complexOf_uint64; - -int equal_fun_complexOf_int8( complexOf_int8, complexOf_int8 ); -int equal_fun_complexOf_int16( complexOf_int16, complexOf_int16 ); -int equal_fun_complexOf_int32( complexOf_int32, complexOf_int32 ); -int equal_fun_complexOf_int64( complexOf_int64, complexOf_int64 ); -int equal_fun_complexOf_uint8( complexOf_uint8, complexOf_uint8 ); -int equal_fun_complexOf_uint16( complexOf_uint16, complexOf_uint16 ); -int equal_fun_complexOf_uint32( complexOf_uint32, complexOf_uint32 ); -int equal_fun_complexOf_uint64( complexOf_uint64, complexOf_uint64 ); - -complexOf_int8 negate_fun_complexOf_int8( complexOf_int8 ); -complexOf_int16 negate_fun_complexOf_int16( complexOf_int16 ); -complexOf_int32 negate_fun_complexOf_int32( complexOf_int32 ); -complexOf_int64 negate_fun_complexOf_int64( complexOf_int64 ); -complexOf_uint8 negate_fun_complexOf_uint8( complexOf_uint8 ); -complexOf_uint16 negate_fun_complexOf_uint16( complexOf_uint16 ); -complexOf_uint32 negate_fun_complexOf_uint32( complexOf_uint32 ); -complexOf_uint64 negate_fun_complexOf_uint64( complexOf_uint64 ); - -complexOf_int8 abs_fun_complexOf_int8( complexOf_int8 ); -complexOf_int16 abs_fun_complexOf_int16( complexOf_int16 ); -complexOf_int32 abs_fun_complexOf_int32( complexOf_int32 ); -complexOf_int64 abs_fun_complexOf_int64( complexOf_int64 ); -complexOf_uint8 abs_fun_complexOf_uint8( complexOf_uint8 ); -complexOf_uint16 abs_fun_complexOf_uint16( complexOf_uint16 ); -complexOf_uint32 abs_fun_complexOf_uint32( complexOf_uint32 ); -complexOf_uint64 abs_fun_complexOf_uint64( complexOf_uint64 ); - -complexOf_int8 signum_fun_complexOf_int8( complexOf_int8 ); -complexOf_int16 signum_fun_complexOf_int16( complexOf_int16 ); -complexOf_int32 signum_fun_complexOf_int32( complexOf_int32 ); -complexOf_int64 signum_fun_complexOf_int64( complexOf_int64 ); -complexOf_uint8 signum_fun_complexOf_uint8( complexOf_uint8 ); -complexOf_uint16 signum_fun_complexOf_uint16( complexOf_uint16 ); -complexOf_uint32 signum_fun_complexOf_uint32( complexOf_uint32 ); -complexOf_uint64 signum_fun_complexOf_uint64( complexOf_uint64 ); -float complex signum_fun_complexOf_float( float complex ); - -complexOf_int8 add_fun_complexOf_int8( complexOf_int8, complexOf_int8 ); -complexOf_int16 add_fun_complexOf_int16( complexOf_int16, complexOf_int16 ); -complexOf_int32 add_fun_complexOf_int32( complexOf_int32, complexOf_int32 ); -complexOf_int64 add_fun_complexOf_int64( complexOf_int64, complexOf_int64 ); -complexOf_uint8 add_fun_complexOf_uint8( complexOf_uint8, complexOf_uint8 ); -complexOf_uint16 add_fun_complexOf_uint16( complexOf_uint16, complexOf_uint16 ); -complexOf_uint32 add_fun_complexOf_uint32( complexOf_uint32, complexOf_uint32 ); -complexOf_uint64 add_fun_complexOf_uint64( complexOf_uint64, complexOf_uint64 ); - -complexOf_int8 sub_fun_complexOf_int8( complexOf_int8, complexOf_int8 ); -complexOf_int16 sub_fun_complexOf_int16( complexOf_int16, complexOf_int16 ); -complexOf_int32 sub_fun_complexOf_int32( complexOf_int32, complexOf_int32 ); -complexOf_int64 sub_fun_complexOf_int64( complexOf_int64, complexOf_int64 ); -complexOf_uint8 sub_fun_complexOf_uint8( complexOf_uint8, complexOf_uint8 ); -complexOf_uint16 sub_fun_complexOf_uint16( complexOf_uint16, complexOf_uint16 ); -complexOf_uint32 sub_fun_complexOf_uint32( complexOf_uint32, complexOf_uint32 ); -complexOf_uint64 sub_fun_complexOf_uint64( complexOf_uint64, complexOf_uint64 ); - -complexOf_int8 mult_fun_complexOf_int8( complexOf_int8, complexOf_int8 ); -complexOf_int16 mult_fun_complexOf_int16( complexOf_int16, complexOf_int16 ); -complexOf_int32 mult_fun_complexOf_int32( complexOf_int32, complexOf_int32 ); -complexOf_int64 mult_fun_complexOf_int64( complexOf_int64, complexOf_int64 ); -complexOf_uint8 mult_fun_complexOf_uint8( complexOf_uint8, complexOf_uint8 ); -complexOf_uint16 mult_fun_complexOf_uint16( complexOf_uint16, complexOf_uint16 ); -complexOf_uint32 mult_fun_complexOf_uint32( complexOf_uint32, complexOf_uint32 ); -complexOf_uint64 mult_fun_complexOf_uint64( complexOf_uint64, complexOf_uint64 ); - -float complex logBase_fun_complexOf_float( float complex, float complex ); - -complexOf_int8 complex_fun_int8( int8_t, int8_t ); -complexOf_int16 complex_fun_int16( int16_t, int16_t ); -complexOf_int32 complex_fun_int32( int32_t, int32_t ); -complexOf_int64 complex_fun_int64( int64_t, int64_t ); -complexOf_uint8 complex_fun_uint8( uint8_t, uint8_t ); -complexOf_uint16 complex_fun_uint16( uint16_t, uint16_t ); -complexOf_uint32 complex_fun_uint32( uint32_t, uint32_t ); -complexOf_uint64 complex_fun_uint64( uint64_t, uint64_t ); -float complex complex_fun_float( float, float ); - -int8_t creal_fun_complexOf_int8( complexOf_int8 ); -int16_t creal_fun_complexOf_int16( complexOf_int16 ); -int32_t creal_fun_complexOf_int32( complexOf_int32 ); -int64_t creal_fun_complexOf_int64( complexOf_int64 ); -uint8_t creal_fun_complexOf_uint8( complexOf_uint8 ); -uint16_t creal_fun_complexOf_uint16( complexOf_uint16 ); -uint32_t creal_fun_complexOf_uint32( complexOf_uint32 ); -uint64_t creal_fun_complexOf_uint64( complexOf_uint64 ); - -int8_t cimag_fun_complexOf_int8( complexOf_int8 ); -int16_t cimag_fun_complexOf_int16( complexOf_int16 ); -int32_t cimag_fun_complexOf_int32( complexOf_int32 ); -int64_t cimag_fun_complexOf_int64( complexOf_int64 ); -uint8_t cimag_fun_complexOf_uint8( complexOf_uint8 ); -uint16_t cimag_fun_complexOf_uint16( complexOf_uint16 ); -uint32_t cimag_fun_complexOf_uint32( complexOf_uint32 ); -uint64_t cimag_fun_complexOf_uint64( complexOf_uint64 ); - -complexOf_int8 conj_fun_complexOf_int8( complexOf_int8 ); -complexOf_int16 conj_fun_complexOf_int16( complexOf_int16 ); -complexOf_int32 conj_fun_complexOf_int32( complexOf_int32 ); -complexOf_int64 conj_fun_complexOf_int64( complexOf_int64 ); -complexOf_uint8 conj_fun_complexOf_uint8( complexOf_uint8 ); -complexOf_uint16 conj_fun_complexOf_uint16( complexOf_uint16 ); -complexOf_uint32 conj_fun_complexOf_uint32( complexOf_uint32 ); -complexOf_uint64 conj_fun_complexOf_uint64( complexOf_uint64 ); - -int8_t magnitude_fun_complexOf_int8( complexOf_int8 ); -int16_t magnitude_fun_complexOf_int16( complexOf_int16 ); -int32_t magnitude_fun_complexOf_int32( complexOf_int32 ); -int64_t magnitude_fun_complexOf_int64( complexOf_int64 ); -uint8_t magnitude_fun_complexOf_uint8( complexOf_uint8 ); -uint16_t magnitude_fun_complexOf_uint16( complexOf_uint16 ); -uint32_t magnitude_fun_complexOf_uint32( complexOf_uint32 ); -uint64_t magnitude_fun_complexOf_uint64( complexOf_uint64 ); - -int8_t phase_fun_complexOf_int8( complexOf_int8 ); -int16_t phase_fun_complexOf_int16( complexOf_int16 ); -int32_t phase_fun_complexOf_int32( complexOf_int32 ); -int64_t phase_fun_complexOf_int64( complexOf_int64 ); -uint8_t phase_fun_complexOf_uint8( complexOf_uint8 ); -uint16_t phase_fun_complexOf_uint16( complexOf_uint16 ); -uint32_t phase_fun_complexOf_uint32( complexOf_uint32 ); -uint64_t phase_fun_complexOf_uint64( complexOf_uint64 ); - -complexOf_int8 mkPolar_fun_int8( int8_t, int8_t ); -complexOf_int16 mkPolar_fun_int16( int16_t, int16_t ); -complexOf_int32 mkPolar_fun_int32( int32_t, int32_t ); -complexOf_int64 mkPolar_fun_int64( int64_t, int64_t ); -complexOf_uint8 mkPolar_fun_uint8( uint8_t, uint8_t ); -complexOf_uint16 mkPolar_fun_uint16( uint16_t, uint16_t ); -complexOf_uint32 mkPolar_fun_uint32( uint32_t, uint32_t ); -complexOf_uint64 mkPolar_fun_uint64( uint64_t, uint64_t ); -float complex mkPolar_fun_float( float, float ); - -complexOf_int8 cis_fun_int8( int8_t ); -complexOf_int16 cis_fun_int16( int16_t ); -complexOf_int32 cis_fun_int32( int32_t ); -complexOf_int64 cis_fun_int64( int64_t ); -complexOf_uint8 cis_fun_uint8( uint8_t ); -complexOf_uint16 cis_fun_uint16( uint16_t ); -complexOf_uint32 cis_fun_uint32( uint32_t ); -complexOf_uint64 cis_fun_uint64( uint64_t ); -float complex cis_fun_float( float ); - - - -void traceStart(); -void traceEnd(); - -void trace_int8( int8_t, int32_t ); -void trace_int16( int16_t, int32_t ); -void trace_int32( int32_t, int32_t ); -void trace_int64( int64_t, int32_t ); -void trace_uint8( uint8_t, int32_t ); -void trace_uint16( uint16_t, int32_t ); -void trace_uint32( uint32_t, int32_t ); -void trace_uint64( uint64_t, int32_t ); -void trace_float( float, int32_t ); -void trace_complexOf_int8( complexOf_int8, int32_t ); -void trace_complexOf_int16( complexOf_int16, int32_t ); -void trace_complexOf_int32( complexOf_int32, int32_t ); -void trace_complexOf_int64( complexOf_int64, int32_t ); -void trace_complexOf_uint8( complexOf_uint8, int32_t ); -void trace_complexOf_uint16( complexOf_uint16, int32_t ); -void trace_complexOf_uint32( complexOf_uint32, int32_t ); -void trace_complexOf_uint64( complexOf_uint64, int32_t ); -void trace_complexOf_float( float complex, int32_t ); - -#endif /* FELDSPAR_C99_H */ diff --git a/Feldspar/C/feldspar_tic64x.c b/Feldspar/C/feldspar_tic64x.c deleted file mode 100644 --- a/Feldspar/C/feldspar_tic64x.c +++ /dev/null @@ -1,2364 +0,0 @@ -// -// Copyright (c) 2009-2011, ERICSSON AB -// All rights reserved. -// -// Redistribution and use in source and binary forms, with or without -// modification, are permitted provided that the following conditions are met: -// -// * Redistributions of source code must retain the above copyright notice, -// this list of conditions and the following disclaimer. -// * Redistributions in binary form must reproduce the above copyright -// notice, this list of conditions and the following disclaimer in the -// documentation and/or other materials provided with the distribution. -// * Neither the name of the ERICSSON AB nor the names of its contributors -// may be used to endorse or promote products derived from this software -// without specific prior written permission. -// -// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -// - -#include "feldspar_tic64x.h" - -#include -#include -#include -#include - -float hypotf(float x, float y) { - return sqrtf(x * x + y * y); -} - - - -/*--------------------------------------------------------------------------* - * pow(), abs(), signum(), logBase() * - *--------------------------------------------------------------------------*/ - -char pow_fun_char( char a, char b ) -{ - char r = 1; - int i; - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); - exit(1); - } - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -short pow_fun_short( short a, short b ) -{ - short r = 1; - int i; - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); - exit(1); - } - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -int pow_fun_int( int a, int b ) -{ - int r = 1; - int i; - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); - exit(1); - } - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -long pow_fun_long( long a, long b ) -{ - long r = 1; - int i; - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %ld `pow` %ld", a, b); - exit(1); - } - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -long long pow_fun_llong( long long a, long long b ) -{ - long long r = 1; - int i; - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %lld `pow` %lld", a, b); - exit(1); - } - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -unsigned char pow_fun_uchar( unsigned char a, unsigned char b ) -{ - unsigned char r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -unsigned short pow_fun_ushort( unsigned short a, unsigned short b ) -{ - unsigned short r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -unsigned pow_fun_uint( unsigned a, unsigned b ) -{ - unsigned r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -unsigned long pow_fun_ulong( unsigned long a, unsigned long b ) -{ - unsigned long r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -unsigned long long pow_fun_ullong( unsigned long long a, unsigned long long b ) -{ - unsigned long long r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - - - -char abs_fun_char( char a ) -{ - // From Bit Twiddling Hacks: - // "Compute the integer absolute value (abs) without branching" - char mask = a >> 7; - return (a + mask) ^ mask; -} - -short abs_fun_short( short a ) -{ - // From Bit Twiddling Hacks: - // "Compute the integer absolute value (abs) without branching" - short mask = a >> 15; - return (a + mask) ^ mask; -} - -long abs_fun_long( long a ) -{ - // From Bit Twiddling Hacks: - // "Compute the integer absolute value (abs) without branching" - long mask = a >> 39; - return (a + mask) ^ mask; -} - -long long abs_fun_llong( long long a ) -{ - // From Bit Twiddling Hacks: - // "Compute the integer absolute value (abs) without branching" - long long mask = a >> 63; - return (a + mask) ^ mask; -} - - - -char signum_fun_char( char a ) -{ - // From Bit Twiddling Hacks: "Compute the sign of an integer" - return (a != 0) | (a >> 7); -} - -short signum_fun_short( short a ) -{ - // From Bit Twiddling Hacks: "Compute the sign of an integer" - return (a != 0) | (a >> 15); -} - -int signum_fun_int( int a ) -{ - // From Bit Twiddling Hacks: "Compute the sign of an integer" - return (a != 0) | (a >> 31); -} - -long signum_fun_long( long a ) -{ - // From Bit Twiddling Hacks: "Compute the sign of an integer" - return (a != 0) | (a >> 39); -} - -long long signum_fun_llong( long long a ) -{ - // From Bit Twiddling Hacks: "Compute the sign of an integer" - return (a != 0) | (a >> 63); -} - -unsigned char signum_fun_uchar( unsigned char a ) -{ - return (a > 0); -} - -unsigned short signum_fun_ushort( unsigned short a ) -{ - return (a > 0); -} - -unsigned signum_fun_uint( unsigned a ) -{ - return (a > 0); -} - -unsigned long signum_fun_ulong( unsigned long a ) -{ - return (a > 0); -} - -unsigned long long signum_fun_ullong( unsigned long long a ) -{ - return (a > 0); -} - -float signum_fun_float( float a ) -{ - // From Bit Twiddling Hacks: "Compute the sign of an integer" - return (a > 0) - (a < 0); -} - - - -float logBase_fun_float( float a, float b ) -{ - return logf(b) / logf(a); -} - - - -/*--------------------------------------------------------------------------* - * Bit operations * - *--------------------------------------------------------------------------*/ - -char setBit_fun_char( char x, unsigned i ) -{ - return x | 1 << i; -} - -short setBit_fun_short( short x, unsigned i ) -{ - return x | 1 << i; -} - -int setBit_fun_int( int x, unsigned i ) -{ - return x | 1 << i; -} - -long setBit_fun_long( long x, unsigned i ) -{ - return x | 1 << i; -} - -long long setBit_fun_llong( long long x, unsigned i ) -{ - return x | 1 << i; -} - -unsigned char setBit_fun_uchar( unsigned char x, unsigned i ) -{ - return x | 1 << i; -} - -unsigned short setBit_fun_ushort( unsigned short x, unsigned i ) -{ - return x | 1 << i; -} - -unsigned setBit_fun_uint( unsigned x, unsigned i ) -{ - return x | 1 << i; -} - -unsigned long setBit_fun_ulong( unsigned long x, unsigned i ) -{ - return x | 1 << i; -} - -unsigned long long setBit_fun_ullong( unsigned long long x, unsigned i ) -{ - return x | 1 << i; -} - - - -char clearBit_fun_char( char x, unsigned i ) -{ - return x & ~(1 << i); -} - -short clearBit_fun_short( short x, unsigned i ) -{ - return x & ~(1 << i); -} - -int clearBit_fun_int( int x, unsigned i ) -{ - return x & ~(1 << i); -} - -long clearBit_fun_long( long x, unsigned i ) -{ - return x & ~(1 << i); -} - -long long clearBit_fun_llong( long long x, unsigned i ) -{ - return x & ~(1 << i); -} - -unsigned char clearBit_fun_uchar( unsigned char x, unsigned i ) -{ - return x & ~(1 << i); -} - -unsigned short clearBit_fun_ushort( unsigned short x, unsigned i ) -{ - return x & ~(1 << i); -} - -unsigned clearBit_fun_uint( unsigned x, unsigned i ) -{ - return x & ~(1 << i); -} - -unsigned long clearBit_fun_ulong( unsigned long x, unsigned i ) -{ - return x & ~(1 << i); -} - -unsigned long long clearBit_fun_ullong( unsigned long long x, unsigned i ) -{ - return x & ~(1 << i); -} - - - -char complementBit_fun_char( char x, unsigned i ) -{ - return x ^ 1 << i; -} - -short complementBit_fun_short( short x, unsigned i ) -{ - return x ^ 1 << i; -} - -int complementBit_fun_int( int x, unsigned i ) -{ - return x ^ 1 << i; -} - -long complementBit_fun_long( long x, unsigned i ) -{ - return x ^ 1 << i; -} - -long long complementBit_fun_llong( long long x, unsigned i ) -{ - return x ^ 1 << i; -} - -unsigned char complementBit_fun_uchar( unsigned char x, unsigned i ) -{ - return x ^ 1 << i; -} - -unsigned short complementBit_fun_ushort( unsigned short x, unsigned i ) -{ - return x ^ 1 << i; -} - -unsigned complementBit_fun_uint( unsigned x, unsigned i ) -{ - return x ^ 1 << i; -} - -unsigned long complementBit_fun_ulong( unsigned long x, unsigned i ) -{ - return x ^ 1 << i; -} - -unsigned long long complementBit_fun_ullong( unsigned long long x, unsigned i ) -{ - return x ^ 1 << i; -} - - - -int testBit_fun_char( char x, unsigned i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_short( short x, unsigned i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_int( int x, unsigned i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_long( long x, unsigned i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_llong( long long x, unsigned i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uchar( unsigned char x, unsigned i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_ushort( unsigned short x, unsigned i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uint( unsigned x, unsigned i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_ulong( unsigned long x, unsigned i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_ullong( unsigned long long x, unsigned i ) -{ - return (x & 1 << i) != 0; -} - - - -char rotateL_fun_char( char x, int i ) -{ - if ((i %= 8) == 0) return x; - return (x << i) | ((0x7f >> (7 - i)) & (x >> (8 - i))); -} - -short rotateL_fun_short( short x, int i ) -{ - if ((i %= 16) == 0) return x; - return (x << i) | ((0x7fff >> (15 - i)) & (x >> (16 - i))); -} - -long rotateL_fun_long( long x, int i ) -{ - if ((i %= 40) == 0) return x; - return (x << i) | ((0x7fffffffffl >> (39 - i)) & (x >> (40 - i))); -} - -long long rotateL_fun_llong( long long x, int i ) -{ - if ((i %= 64) == 0) return x; - return (x << i) | ((0x7fffffffffffffffll >> (63 - i)) & (x >> (64 - i))); -} - -int rotateL_fun_int( int x, int i ) -{ - return (int)_rotl((unsigned)x, (unsigned)i); -} - -unsigned char rotateL_fun_uchar( unsigned char x, int i ) -{ - if ((i %= 8) == 0) return x; - return (x << i) | (x >> (8 - i)); -} - -unsigned short rotateL_fun_ushort( unsigned short x, int i ) -{ - if ((i %= 16) == 0) return x; - return (x << i) | (x >> (16 - i)); -} - -unsigned long rotateL_fun_ulong( unsigned long x, int i ) -{ - if ((i %= 40) == 0) return x; - return (x << i) | (x >> (40 - i)); -} - -unsigned long long rotateL_fun_ullong( unsigned long long x, int i ) -{ - if ((i %= 64) == 0) return x; - return (x << i) | (x >> (64 - i)); -} - - - -char rotateR_fun_char( char x, int i ) -{ - if ((i %= 8) == 0) return x; - return (x << (8 - i)) | ((0x7f >> (i - 1)) & (x >> i)); -} - -short rotateR_fun_short( short x, int i ) -{ - if ((i %= 16) == 0) return x; - return (x << (16 - i)) | ((0x7fff >> (i - 1)) & (x >> i)); -} - -int rotateR_fun_int( int x, int i ) -{ - if ((i %= 32) == 0) return x; - return (x << (32 - i)) | ((0x7fffffff >> (i - 1)) & (x >> i)); -} - -long rotateR_fun_long( long x, int i ) -{ - if ((i %= 40) == 0) return x; - return (x << (40 - i)) | ((0x7fffffffffl >> (i - 1)) & (x >> i)); -} - -long long rotateR_fun_llong( long long x, int i ) -{ - if ((i %= 64) == 0) return x; - return (x << (64 - i)) | ((0x7fffffffffffffffll >> (i - 1)) & (x >> i)); -} - -unsigned char rotateR_fun_uchar( unsigned char x, int i ) -{ - if ((i %= 8) == 0) return x; - return (x << (8 - i)) | (x >> i); -} - -unsigned short rotateR_fun_ushort( unsigned short x, int i ) -{ - if ((i %= 16) == 0) return x; - return (x << (16 - i)) | (x >> i); -} - -unsigned rotateR_fun_uint( unsigned x, int i ) -{ - if ((i %= 32) == 0) return x; - return (x << (32 - i)) | (x >> i); -} - -unsigned long rotateR_fun_ulong( unsigned long x, int i ) -{ - if ((i %= 40) == 0) return x; - return (x << (40 - i)) | (x >> i); -} - -unsigned long long rotateR_fun_ullong( unsigned long long x, int i ) -{ - if ((i %= 64) == 0) return x; - return (x << (64 - i)) | (x >> i); -} - - - -char reverseBits_fun_char( char x ) -{ - char r = x; - int i = 7; - for (x = x >> 1 & 0x7f; x; x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -short reverseBits_fun_short( short x ) -{ - short r = x; - int i = 15; - for (x = x >> 1 & 0x7fff; x; x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -int reverseBits_fun_int( int x ) -{ - int r = x; - int i = 31; - for (x = x >> 1 & 0x7fffffff; x; x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -long reverseBits_fun_long( long x ) -{ - long r = x; - int i = 39; - for (x = x >> 1 & 0x7fffffffffl; x; x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -long long reverseBits_fun_llong( long long x ) -{ - long long r = x; - int i = 63; - for (x = x >> 1 & 0x7fffffffffffffffll; x; x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -unsigned char reverseBits_fun_uchar( unsigned char x ) -{ - unsigned char r = x; - int i = 7; - while (x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -unsigned short reverseBits_fun_ushort( unsigned short x ) -{ - unsigned short r = x; - int i = 15; - while (x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -unsigned long reverseBits_fun_ulong( unsigned long x ) -{ - unsigned long r = x; - int i = 39; - while (x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - -unsigned long long reverseBits_fun_ullong( unsigned long long x ) -{ - unsigned long long r = x; - int i = 63; - while (x >>= 1) - { - r = (r << 1) | (x & 1); - --i; - } - return r << i; -} - - - -unsigned bitScan_fun_char( char x ) -{ - unsigned r = 0; - char s = (x & 0x80); - if (x == 0) return 7; - while (((x <<= 1) & 0x80) == s) - ++r; - return r; -} - -unsigned bitScan_fun_short( short x ) -{ - unsigned r = 0; - short s = (x & 0x8000); - if (x == 0) return 15; - while (((x <<= 1) & 0x8000) == s) - ++r; - return r; -} - -unsigned bitScan_fun_int( int x ) -{ - unsigned r = 0; - int s = (x & 0x80000000); - if (x == 0) return 31; - while (((x <<= 1) & 0x80000000) == s) - ++r; - return r; -} - -unsigned bitScan_fun_long( long x ) -{ - unsigned r = 0; - long s = (x & 0x8000000000l); - if (x == 0) return 39; - while (((x <<= 1) & 0x8000000000l) == s) - ++r; - return r; -} - -unsigned bitScan_fun_llong( long long x ) -{ - unsigned r = 0; - long long s = (x & 0x8000000000000000ll); - if (x == 0) return 63; - while (((x <<= 1) & 0x8000000000000000ll) == s) - ++r; - return r; -} - -unsigned bitScan_fun_uchar( unsigned char x ) -{ - unsigned r = 8; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -unsigned bitScan_fun_ushort( unsigned short x ) -{ - unsigned r = 16; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -unsigned bitScan_fun_uint( unsigned x ) -{ - unsigned r = 32; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -unsigned bitScan_fun_ulong( unsigned long x ) -{ - unsigned r = 40; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -unsigned bitScan_fun_ullong( unsigned long long x ) -{ - unsigned r = 64; - while (x) - { - --r; - x >>= 1; - } - return r; -} - - - -unsigned bitCount_fun_char( char x ) -{ - unsigned r = x & 1; - for (x = x >> 1 & 0x7f; x; x >>= 1) - r += x & 1; - return r; -} - -unsigned bitCount_fun_short( short x ) -{ - unsigned r = x & 1; - for (x = x >> 1 & 0x7fff; x; x >>= 1) - r += x & 1; - return r; -} - -unsigned bitCount_fun_int( int x ) -{ - unsigned r = x & 1; - for (x = x >> 1 & 0x7fffffff; x; x >>= 1) - r += x & 1; - return r; -} - -unsigned bitCount_fun_long( long x ) -{ - unsigned r = x & 1; - for (x = x >> 1 & 0x7fffffffffl; x; x >>= 1) - r += x & 1; - return r; -} - -unsigned bitCount_fun_llong( long long x ) -{ - unsigned r = x & 1; - for (x = x >> 1 & 0x7fffffffffffffffll; x; x >>= 1) - r += x & 1; - return r; -} - -unsigned bitCount_fun_uchar( unsigned char x ) -{ - unsigned r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -unsigned bitCount_fun_ushort( unsigned short x ) -{ - unsigned r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -unsigned bitCount_fun_ulong( unsigned long x ) -{ - unsigned r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -unsigned bitCount_fun_ullong( unsigned long long x ) -{ - unsigned r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - - - -/*--------------------------------------------------------------------------* - * Complex numbers * - *--------------------------------------------------------------------------*/ - -int equal_fun_complexOf_char( complexOf_char a, complexOf_char b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_int( complexOf_int a, complexOf_int b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_long( complexOf_long a, complexOf_long b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_llong( complexOf_llong a, complexOf_llong b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_uchar( complexOf_uchar a, complexOf_uchar b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_uint( complexOf_uint a, complexOf_uint b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_ulong( complexOf_ulong a, complexOf_ulong b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_ullong( complexOf_ullong a, complexOf_ullong b ) -{ - return a.re == b.re && a.im == b.im; -} - -int equal_fun_complexOf_float( complexOf_float a, complexOf_float b ) -{ - return a.re == b.re && a.im == b.im; -} - - - -complexOf_char negate_fun_complexOf_char( complexOf_char a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_int negate_fun_complexOf_int( complexOf_int a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_long negate_fun_complexOf_long( complexOf_long a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_llong negate_fun_complexOf_llong( complexOf_llong a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_uchar negate_fun_complexOf_uchar( complexOf_uchar a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_uint negate_fun_complexOf_uint( complexOf_uint a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_ulong negate_fun_complexOf_ulong( complexOf_ulong a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_ullong negate_fun_complexOf_ullong( complexOf_ullong a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - -complexOf_float negate_fun_complexOf_float( complexOf_float a ) -{ - a.re = -a.re; - a.im = -a.im; - return a; -} - - - -complexOf_char abs_fun_complexOf_char( complexOf_char a ) -{ - a.re = magnitude_fun_complexOf_char(a); - a.im = 0; - return a; -} - -complexOf_int abs_fun_complexOf_int( complexOf_int a ) -{ - a.re = magnitude_fun_complexOf_int(a); - a.im = 0; - return a; -} - -complexOf_long abs_fun_complexOf_long( complexOf_long a ) -{ - a.re = magnitude_fun_complexOf_long(a); - a.im = 0; - return a; -} - -complexOf_llong abs_fun_complexOf_llong( complexOf_llong a ) -{ - a.re = magnitude_fun_complexOf_llong(a); - a.im = 0; - return a; -} - -complexOf_uchar abs_fun_complexOf_uchar( complexOf_uchar a ) -{ - a.re = magnitude_fun_complexOf_uchar(a); - a.im = 0; - return a; -} - -complexOf_uint abs_fun_complexOf_uint( complexOf_uint a ) -{ - a.re = magnitude_fun_complexOf_uint(a); - a.im = 0; - return a; -} - -complexOf_ulong abs_fun_complexOf_ulong( complexOf_ulong a ) -{ - a.re = magnitude_fun_complexOf_ulong(a); - a.im = 0; - return a; -} - -complexOf_ullong abs_fun_complexOf_ullong( complexOf_ullong a ) -{ - a.re = magnitude_fun_complexOf_ullong(a); - a.im = 0; - return a; -} - -complexOf_float abs_fun_complexOf_float( complexOf_float a ) -{ - a.re = magnitude_fun_complexOf_float(a); - a.im = 0; - return a; -} - -unsigned abs_fun_complexOf_short( unsigned a ) -{ - return _pack2(magnitude_fun_complexOf_short(a), 0); -} - -unsigned abs_fun_complexOf_ushort( unsigned a ) -{ - return _pack2(magnitude_fun_complexOf_ushort(a), 0); -} - - - -complexOf_char signum_fun_complexOf_char( complexOf_char a ) -{ - char m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_char(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_int signum_fun_complexOf_int( complexOf_int a ) -{ - int m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_int(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_long signum_fun_complexOf_long( complexOf_long a ) -{ - long m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_long(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_llong signum_fun_complexOf_llong( complexOf_llong a ) -{ - long long m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_llong(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_uchar signum_fun_complexOf_uchar( complexOf_uchar a ) -{ - unsigned char m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_uchar(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_uint signum_fun_complexOf_uint( complexOf_uint a ) -{ - unsigned m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_uint(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_ulong signum_fun_complexOf_ulong( complexOf_ulong a ) -{ - unsigned long m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_ulong(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_ullong signum_fun_complexOf_ullong( complexOf_ullong a ) -{ - unsigned long long m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_ullong(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -complexOf_float signum_fun_complexOf_float( complexOf_float a ) -{ - float m; - if (a.re == 0 && a.im == 0) { - return a; - } else { - m = magnitude_fun_complexOf_float(a); - a.re = a.re / m; - a.im = a.im / m; - return a; - } -} - -unsigned signum_fun_complexOf_short( unsigned a ) -{ - short m; - if (a == 0) { - return a; - } else { - m = magnitude_fun_complexOf_short(a); - return _pack2((a >> 16) / m, (a & 0x0000ffff) / m); - } -} - -unsigned signum_fun_complexOf_ushort( unsigned a ) -{ - unsigned short m; - if (a == 0) { - return a; - } else { - m = magnitude_fun_complexOf_ushort(a); - return _pack2((a >> 16) / m, (a & 0x0000ffff) / m); - } -} - - - -complexOf_char add_fun_complexOf_char( complexOf_char a, complexOf_char b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_int add_fun_complexOf_int( complexOf_int a, complexOf_int b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_long add_fun_complexOf_long( complexOf_long a, complexOf_long b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_llong add_fun_complexOf_llong( complexOf_llong a, complexOf_llong b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_uchar add_fun_complexOf_uchar( complexOf_uchar a, complexOf_uchar b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_uint add_fun_complexOf_uint( complexOf_uint a, complexOf_uint b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_ulong add_fun_complexOf_ulong( complexOf_ulong a, complexOf_ulong b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_ullong add_fun_complexOf_ullong( complexOf_ullong a, complexOf_ullong b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - -complexOf_float add_fun_complexOf_float( complexOf_float a, complexOf_float b ) -{ - a.re = a.re + b.re; - a.im = a.im + b.im; - return a; -} - - - -complexOf_char sub_fun_complexOf_char( complexOf_char a, complexOf_char b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_int sub_fun_complexOf_int( complexOf_int a, complexOf_int b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_long sub_fun_complexOf_long( complexOf_long a, complexOf_long b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_llong sub_fun_complexOf_llong( complexOf_llong a, complexOf_llong b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_uchar sub_fun_complexOf_uchar( complexOf_uchar a, complexOf_uchar b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_uint sub_fun_complexOf_uint( complexOf_uint a, complexOf_uint b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_ulong sub_fun_complexOf_ulong( complexOf_ulong a, complexOf_ulong b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_ullong sub_fun_complexOf_ullong( complexOf_ullong a, complexOf_ullong b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - -complexOf_float sub_fun_complexOf_float( complexOf_float a, complexOf_float b ) -{ - a.re = a.re - b.re; - a.im = a.im - b.im; - return a; -} - - - -complexOf_char mult_fun_complexOf_char( complexOf_char a, complexOf_char b ) -{ - complexOf_char r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_int mult_fun_complexOf_int( complexOf_int a, complexOf_int b ) -{ - complexOf_int r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_long mult_fun_complexOf_long( complexOf_long a, complexOf_long b ) -{ - complexOf_long r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_llong mult_fun_complexOf_llong( complexOf_llong a, complexOf_llong b ) -{ - complexOf_llong r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_uchar mult_fun_complexOf_uchar( complexOf_uchar a, complexOf_uchar b ) -{ - complexOf_uchar r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_uint mult_fun_complexOf_uint( complexOf_uint a, complexOf_uint b ) -{ - complexOf_uint r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_ulong mult_fun_complexOf_ulong( complexOf_ulong a, complexOf_ulong b ) -{ - complexOf_ulong r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_ullong mult_fun_complexOf_ullong( complexOf_ullong a, complexOf_ullong b ) -{ - complexOf_ullong r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -complexOf_float mult_fun_complexOf_float( complexOf_float a, complexOf_float b ) -{ - complexOf_float r; - r.re = a.re * b.re - a.im * b.im; - r.im = a.im * b.re + a.re * b.im; - return r; -} - -unsigned mult_fun_complexOf_short( unsigned a, unsigned b ) -{ - short are = (short)(a >> 16); - short aim = (short)(a & 0x0000ffff); - short bre = (short)(b >> 16); - short bim = (short)(b & 0x0000ffff); - return _pack2(are * bre - aim * bim, aim * bre + are * bim); -} - -unsigned mult_fun_complexOf_ushort( unsigned a, unsigned b ) -{ - unsigned short are = (unsigned short)(a >> 16); - unsigned short aim = (unsigned short)(a & 0x0000ffff); - unsigned short bre = (unsigned short)(b >> 16); - unsigned short bim = (unsigned short)(b & 0x0000ffff); - return _pack2(are * bre - aim * bim, aim * bre + are * bim); -} - - - -complexOf_float div_fun_complexOf_float( complexOf_float a, complexOf_float b ) -{ - float x = b.re * b.re + b.im * b.im; - complexOf_float r; - r.re = (a.re * b.re + a.im * b.im) / x; - r.im = (a.im * b.re - a.re * b.im) / x; - return r; -} - - - -complexOf_float exp_fun_complexOf_float( complexOf_float a ) -{ - float expre = expf(a.re); - a.re = expre * cosf(a.im); - a.im = expre * sinf(a.im); - return a; -} - - - -complexOf_float sqrt_fun_complexOf_float( complexOf_float a ) -{ - float magare = magnitude_fun_complexOf_float(a) + a.re; - a.re = sqrtf(magare / 2); - a.im = a.im / sqrtf(2 * magare); - return a; -} - - - -complexOf_float log_fun_complexOf_float( complexOf_float a ) -{ - complexOf_float r; - r.re = logf(magnitude_fun_complexOf_float(a)); - r.im = phase_fun_complexOf_float(a); - return r; -} - - - -complexOf_float pow_fun_complexOf_float( complexOf_float a, complexOf_float b ) -{ - return exp_fun_complexOf_float(mult_fun_complexOf_float(log_fun_complexOf_float(a), b)); -} - - - -complexOf_float logBase_fun_complexOf_float( complexOf_float a, complexOf_float b ) -{ - return div_fun_complexOf_float(log_fun_complexOf_float(b), log_fun_complexOf_float(a)); -} - - - -complexOf_float sin_fun_complexOf_float( complexOf_float a ) -{ - complexOf_float r; - r.re = sinf(a.re) * coshf(a.im); - r.im = cosf(a.re) * sinhf(a.im); - return r; -} - - - -complexOf_float cos_fun_complexOf_float( complexOf_float a ) -{ - complexOf_float r; - r.re = cosf(a.re) * coshf(a.im); - r.im = - sinf(a.re) * sinhf(a.im); - return r; -} - - - -complexOf_float tan_fun_complexOf_float( complexOf_float a ) -{ - return div_fun_complexOf_float(sin_fun_complexOf_float(a), cos_fun_complexOf_float(a)); -} - - - -complexOf_float sinh_fun_complexOf_float( complexOf_float a ) -{ - complexOf_float r; - r.re = sinhf(a.re) * cosf(a.im); - r.im = coshf(a.re) * sinf(a.im); - return r; -} - - - -complexOf_float cosh_fun_complexOf_float( complexOf_float a ) -{ - complexOf_float r; - r.re = cosf(a.re) * coshf(a.im); - r.im = sinhf(a.re) * sinf(a.im); - return r; -} - - - -complexOf_float tanh_fun_complexOf_float( complexOf_float a ) -{ - return div_fun_complexOf_float(sinh_fun_complexOf_float(a), cosh_fun_complexOf_float(a)); -} - - - -complexOf_float asin_fun_complexOf_float( complexOf_float a ) -{ - complexOf_float b = add_fun_complexOf_float(log_fun_complexOf_float(complex_fun_float(-a.im, a.re)), sqrt_fun_complexOf_float(sub_fun_complexOf_float(complex_fun_float(1, 0), mult_fun_complexOf_float(a, a)))); - a.re = b.im; - a.im = -b.re; - return a; -} - - - -complexOf_float acos_fun_complexOf_float( complexOf_float a ) -{ - complexOf_float b = sqrt_fun_complexOf_float(sub_fun_complexOf_float(complex_fun_float(1, 0), mult_fun_complexOf_float(a, a))); - complexOf_float c = log_fun_complexOf_float(add_fun_complexOf_float(a, complex_fun_float(-b.im, b.re))); - a.re = c.im; - a.im = -c.re; - return a; -} - - - -complexOf_float atan_fun_complexOf_float( complexOf_float a ) -{ - complexOf_float b = log_fun_complexOf_float(div_fun_complexOf_float(complex_fun_float(1 - a.im, a.re), sqrt_fun_complexOf_float(add_fun_complexOf_float(complex_fun_float(1, 0), mult_fun_complexOf_float(a, a))))); - a.re = b.im; - a.im = -b.re; - return a; -} - - - -complexOf_float asinh_fun_complexOf_float( complexOf_float a ) -{ - return log_fun_complexOf_float(add_fun_complexOf_float(a, sqrt_fun_complexOf_float(add_fun_complexOf_float(complex_fun_float(1, 0), mult_fun_complexOf_float(a, a))))); -} - - - -complexOf_float acosh_fun_complexOf_float( complexOf_float a ) -{ - complexOf_float b = {1, 0}; - complexOf_float c = add_fun_complexOf_float(a, b); - return log_fun_complexOf_float(add_fun_complexOf_float(a, mult_fun_complexOf_float(c, sqrt_fun_complexOf_float(div_fun_complexOf_float(sub_fun_complexOf_float(a, b), c))))); -} - - - -complexOf_float atanh_fun_complexOf_float( complexOf_float a ) -{ - complexOf_float b = {1, 0}; - return log_fun_complexOf_float(div_fun_complexOf_float(add_fun_complexOf_float(b, a), sqrt_fun_complexOf_float(sub_fun_complexOf_float(b, mult_fun_complexOf_float(a, a))))); -} - - - -complexOf_char complex_fun_char( char re, char im ) -{ - complexOf_char r; - r.re = re; - r.im = im; - return r; -} - -complexOf_int complex_fun_int( int re, int im ) -{ - complexOf_int r; - r.re = re; - r.im = im; - return r; -} - -complexOf_long complex_fun_long( long re, long im ) -{ - complexOf_long r; - r.re = re; - r.im = im; - return r; -} - -complexOf_llong complex_fun_llong( long long re, long long im ) -{ - complexOf_llong r; - r.re = re; - r.im = im; - return r; -} - -complexOf_uchar complex_fun_uchar( unsigned char re, unsigned char im ) -{ - complexOf_uchar r; - r.re = re; - r.im = im; - return r; -} - -complexOf_uint complex_fun_uint( unsigned re, unsigned im ) -{ - complexOf_uint r; - r.re = re; - r.im = im; - return r; -} - -complexOf_ulong complex_fun_ulong( unsigned long re, unsigned long im ) -{ - complexOf_ulong r; - r.re = re; - r.im = im; - return r; -} - -complexOf_ullong complex_fun_ullong( unsigned long long re, unsigned long long im ) -{ - complexOf_ullong r; - r.re = re; - r.im = im; - return r; -} - -complexOf_float complex_fun_float( float re, float im ) -{ - complexOf_float r; - r.re = re; - r.im = im; - return r; -} - - - -char creal_fun_complexOf_char( complexOf_char a ) -{ - return a.re; -} - -int creal_fun_complexOf_int( complexOf_int a ) -{ - return a.re; -} - -long creal_fun_complexOf_long( complexOf_long a ) -{ - return a.re; -} - -long long creal_fun_complexOf_llong( complexOf_llong a ) -{ - return a.re; -} - -unsigned char creal_fun_complexOf_uchar( complexOf_uchar a ) -{ - return a.re; -} - -unsigned creal_fun_complexOf_uint( complexOf_uint a ) -{ - return a.re; -} - -unsigned long creal_fun_complexOf_ulong( complexOf_ulong a ) -{ - return a.re; -} - -unsigned long long creal_fun_complexOf_ullong( complexOf_ullong a ) -{ - return a.re; -} - -float creal_fun_complexOf_float( complexOf_float a ) -{ - return a.re; -} - -short creal_fun_complexOf_short( unsigned a ) -{ - return a >> 16; -} - -unsigned short creal_fun_complexOf_ushort( unsigned a ) -{ - return a >> 16; -} - - - -char cimag_fun_complexOf_char( complexOf_char a ) -{ - return a.im; -} - -int cimag_fun_complexOf_int( complexOf_int a ) -{ - return a.im; -} - -long cimag_fun_complexOf_long( complexOf_long a ) -{ - return a.im; -} - -long long cimag_fun_complexOf_llong( complexOf_llong a ) -{ - return a.im; -} - -unsigned char cimag_fun_complexOf_uchar( complexOf_uchar a ) -{ - return a.im; -} - -unsigned cimag_fun_complexOf_uint( complexOf_uint a ) -{ - return a.im; -} - -unsigned long cimag_fun_complexOf_ulong( complexOf_ulong a ) -{ - return a.im; -} - -unsigned long long cimag_fun_complexOf_ullong( complexOf_ullong a ) -{ - return a.im; -} - -float cimag_fun_complexOf_float( complexOf_float a ) -{ - return a.im; -} - -short cimag_fun_complexOf_short( unsigned a ) -{ - return a & 0x0000ffff; -} - -unsigned short cimag_fun_complexOf_ushort( unsigned a ) -{ - return a & 0x0000ffff; -} - - - -complexOf_char conj_fun_complexOf_char( complexOf_char a ) -{ - a.im = -a.im; - return a; -} - -complexOf_int conj_fun_complexOf_int( complexOf_int a ) -{ - a.im = -a.im; - return a; -} - -complexOf_long conj_fun_complexOf_long( complexOf_long a ) -{ - a.im = -a.im; - return a; -} - -complexOf_llong conj_fun_complexOf_llong( complexOf_llong a ) -{ - a.im = -a.im; - return a; -} - -complexOf_uchar conj_fun_complexOf_uchar( complexOf_uchar a ) -{ - a.im = -a.im; - return a; -} - -complexOf_uint conj_fun_complexOf_uint( complexOf_uint a ) -{ - a.im = -a.im; - return a; -} - -complexOf_ulong conj_fun_complexOf_ulong( complexOf_ulong a ) -{ - a.im = -a.im; - return a; -} - -complexOf_ullong conj_fun_complexOf_ullong( complexOf_ullong a ) -{ - a.im = -a.im; - return a; -} - -complexOf_float conj_fun_complexOf_float( complexOf_float a ) -{ - a.im = -a.im; - return a; -} - -unsigned conj_fun_complexOf_short( unsigned a ) -{ - return _pack2(a >> 16, -(a & 0x0000ffff)); -} - -unsigned conj_fun_complexOf_ushort( unsigned a ) -{ - return _pack2(a >> 16, -(a & 0x0000ffff)); -} - - - -char magnitude_fun_complexOf_char( complexOf_char a ) -{ - return roundf(hypotf(a.re, a.im)); -} - -int magnitude_fun_complexOf_int( complexOf_int a ) -{ - return roundf(hypotf(a.re, a.im)); -} - -long magnitude_fun_complexOf_long( complexOf_long a ) -{ - return roundf(hypotf(a.re, a.im)); -} - -long long magnitude_fun_complexOf_llong( complexOf_llong a ) -{ - return roundf(hypotf(a.re, a.im)); -} - -unsigned char magnitude_fun_complexOf_uchar( complexOf_uchar a ) -{ - return roundf(hypotf(a.re, a.im)); -} - -unsigned magnitude_fun_complexOf_uint( complexOf_uint a ) -{ - return roundf(hypotf(a.re, a.im)); -} - -unsigned long magnitude_fun_complexOf_ulong( complexOf_ulong a ) -{ - return roundf(hypotf(a.re, a.im)); -} - -unsigned long long magnitude_fun_complexOf_ullong( complexOf_ullong a ) -{ - return roundf(hypotf(a.re, a.im)); -} - -float magnitude_fun_complexOf_float( complexOf_float a ) -{ - return (hypotf(a.re, a.im)); -} - -short magnitude_fun_complexOf_short( unsigned a ) -{ - return roundf(hypotf((a >> 16), (a & 0x0000ffff))); -} - -unsigned short magnitude_fun_complexOf_ushort( unsigned a ) -{ - return roundf(hypotf((a >> 16), (a & 0x0000ffff))); -} - - - -char phase_fun_complexOf_char( complexOf_char a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return roundf(atan2f(a.im, a.re)); -} - -int phase_fun_complexOf_int( complexOf_int a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return roundf(atan2f(a.im, a.re)); -} - -long phase_fun_complexOf_long( complexOf_long a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return roundf(atan2f(a.im, a.re)); -} - -long long phase_fun_complexOf_llong( complexOf_llong a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return roundf(atan2f(a.im, a.re)); -} - -unsigned char phase_fun_complexOf_uchar( complexOf_uchar a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return roundf(atan2f(a.im, a.re)); -} - -unsigned phase_fun_complexOf_uint( complexOf_uint a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return roundf(atan2f(a.im, a.re)); -} - -unsigned long phase_fun_complexOf_ulong( complexOf_ulong a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return roundf(atan2f(a.im, a.re)); -} - -unsigned long long phase_fun_complexOf_ullong( complexOf_ullong a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return roundf(atan2f(a.im, a.re)); -} - -float phase_fun_complexOf_float( complexOf_float a ) -{ - if (a.re == 0 && a.im == 0) return 0; - else return (atan2f(a.im, a.re)); -} - -short phase_fun_complexOf_short( unsigned a ) -{ - short re = (a >> 16); - short im = (a & 0x0000ffff); - if (re == 0 && im == 0) return 0; - else return roundf(atan2f(im, re)); -} - -unsigned short phase_fun_complexOf_ushort( unsigned a ) -{ - unsigned short re = (a >> 16); - unsigned short im = (a & 0x0000ffff); - if (re == 0 && im == 0) return 0; - else return roundf(atan2f(im, re)); -} - - - -complexOf_char mkPolar_fun_char( char r, char t ) -{ - complexOf_char a; - a.re = roundf(r * cosf(t)); - a.im = roundf(r * sinf(t)); - return a; -} - -complexOf_int mkPolar_fun_int( int r, int t ) -{ - complexOf_int a; - a.re = roundf(r * cosf(t)); - a.im = roundf(r * sinf(t)); - return a; -} - -complexOf_long mkPolar_fun_long( long r, long t ) -{ - complexOf_long a; - a.re = roundf(r * cosf(t)); - a.im = roundf(r * sinf(t)); - return a; -} - -complexOf_llong mkPolar_fun_llong( long long r, long long t ) -{ - complexOf_llong a; - a.re = roundf(r * cosf(t)); - a.im = roundf(r * sinf(t)); - return a; -} - -complexOf_uchar mkPolar_fun_uchar( unsigned char r, unsigned char t ) -{ - complexOf_uchar a; - a.re = roundf(r * cosf(t)); - a.im = roundf(r * sinf(t)); - return a; -} - -complexOf_uint mkPolar_fun_uint( unsigned r, unsigned t ) -{ - complexOf_uint a; - a.re = roundf(r * cosf(t)); - a.im = roundf(r * sinf(t)); - return a; -} - -complexOf_ulong mkPolar_fun_ulong( unsigned long r, unsigned long t ) -{ - complexOf_ulong a; - a.re = roundf(r * cosf(t)); - a.im = roundf(r * sinf(t)); - return a; -} - -complexOf_ullong mkPolar_fun_ullong( unsigned long long r, unsigned long long t ) -{ - complexOf_ullong a; - a.re = roundf(r * cosf(t)); - a.im = roundf(r * sinf(t)); - return a; -} - -complexOf_float mkPolar_fun_float( float r, float t ) -{ - complexOf_float a; - a.re = (r * cosf(t)); - a.im = (r * sinf(t)); - return a; -} - -unsigned mkPolar_fun_short( short r, short t ) -{ - return _pack2(roundf(r * cosf(t)), roundf(r * sinf(t))); -} - -unsigned mkPolar_fun_ushort( unsigned short r, unsigned short t ) -{ - return _pack2(roundf(r * cosf(t)), roundf(r * sinf(t))); -} - - - -complexOf_char cis_fun_char( char t ) -{ - complexOf_char r; - r.re = roundf(cosf(t)); - r.im = roundf(sinf(t)); - return r; -} - -complexOf_int cis_fun_int( int t ) -{ - complexOf_int r; - r.re = roundf(cosf(t)); - r.im = roundf(sinf(t)); - return r; -} - -complexOf_long cis_fun_long( long t ) -{ - complexOf_long r; - r.re = roundf(cosf(t)); - r.im = roundf(sinf(t)); - return r; -} - -complexOf_llong cis_fun_llong( long long t ) -{ - complexOf_llong r; - r.re = roundf(cosf(t)); - r.im = roundf(sinf(t)); - return r; -} - -complexOf_uchar cis_fun_uchar( unsigned char t ) -{ - complexOf_uchar r; - r.re = roundf(cosf(t)); - r.im = roundf(sinf(t)); - return r; -} - -complexOf_uint cis_fun_uint( unsigned t ) -{ - complexOf_uint r; - r.re = roundf(cosf(t)); - r.im = roundf(sinf(t)); - return r; -} - -complexOf_ulong cis_fun_ulong( unsigned long t ) -{ - complexOf_ulong r; - r.re = roundf(cosf(t)); - r.im = roundf(sinf(t)); - return r; -} - -complexOf_ullong cis_fun_ullong( unsigned long long t ) -{ - complexOf_ullong r; - r.re = roundf(cosf(t)); - r.im = roundf(sinf(t)); - return r; -} - -complexOf_float cis_fun_float( float t ) -{ - complexOf_float r; - r.re = (cosf(t)); - r.im = (sinf(t)); - return r; -} - -unsigned cis_fun_short( short t ) -{ - return _pack2(roundf(cosf(t)), roundf(sinf(t))); -} - -unsigned cis_fun_ushort( unsigned short t ) -{ - return _pack2(roundf(cosf(t)), roundf(sinf(t))); -} - - - -/*--------------------------------------------------------------------------* - * Trace functions * - *--------------------------------------------------------------------------*/ - -static FILE *trace_log_file; -static time_t trace_start_time; - -void traceStart() -{ - char timestr [80]; - char str [256]; - struct tm * timeinfo; - trace_start_time = time(NULL); - timeinfo = localtime(&(trace_start_time)); - strftime(timestr, 80, "%Y%m%d-%H%M%S", timeinfo); - sprintf(str, "trace-%s.log", timestr); - trace_log_file = fopen(str, "a"); - if (trace_log_file == NULL) { - fprintf(stderr,"Can not open trace file.\n"); - exit (8); - } - strftime(timestr, 80, "%d-%b-%Y %H:%M:%S", timeinfo); - fprintf(trace_log_file, "Logging started at %s.\n", timestr); - fflush(trace_log_file); - trace_start_time = time(NULL); -} - -void elapsedTimeString( char* str ) -{ - sprintf(str, "%ld.000", time(NULL) - trace_start_time); -} - -void traceEnd() -{ - fprintf(trace_log_file, "Logging finished.\n"); - fclose(trace_log_file); -} - -void trace_char( char val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_short( short val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_int( int val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_long( long val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%ld\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_llong( long long val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%lld\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_uchar( unsigned char val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_ushort( unsigned short val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_uint( unsigned val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_ulong( unsigned long val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%lu\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_ullong( unsigned long long val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%llu\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_float( float val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%f\n", id, timestr, val); - fflush(trace_log_file); -} - -void trace_complexOf_char( complexOf_char val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_short( unsigned val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, (short)(val >> 16), (short)(val & 0x0000ffff)); - fflush(trace_log_file); -} - -void trace_complexOf_int( complexOf_int val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_long( complexOf_long val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%ld+%ld*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_llong( complexOf_llong val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%lld+%lld*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_uchar( complexOf_uchar val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_ushort( unsigned val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, (val >> 16), (val & 0x0000ffff)); - fflush(trace_log_file); -} - -void trace_complexOf_uint( complexOf_uint val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_ulong( complexOf_ulong val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%lu+%lu*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_ullong( complexOf_ullong val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%llu+%llu*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - -void trace_complexOf_float( complexOf_float val, int id ) -{ - char timestr [80]; - elapsedTimeString(timestr); - fprintf(trace_log_file, "id=%d, time=%s, value=%f+%f*I\n", id, timestr, val.re, val.im); - fflush(trace_log_file); -} - diff --git a/Feldspar/C/feldspar_tic64x.h b/Feldspar/C/feldspar_tic64x.h deleted file mode 100644 --- a/Feldspar/C/feldspar_tic64x.h +++ /dev/null @@ -1,443 +0,0 @@ -// -// Copyright (c) 2009-2011, ERICSSON AB -// All rights reserved. -// -// Redistribution and use in source and binary forms, with or without -// modification, are permitted provided that the following conditions are met: -// -// * Redistributions of source code must retain the above copyright notice, -// this list of conditions and the following disclaimer. -// * Redistributions in binary form must reproduce the above copyright -// notice, this list of conditions and the following disclaimer in the -// documentation and/or other materials provided with the distribution. -// * Neither the name of the ERICSSON AB nor the names of its contributors -// may be used to endorse or promote products derived from this software -// without specific prior written permission. -// -// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -// - -#ifndef FELDSPAR_TI_C64X_H -#define FELDSPAR_TI_C64X_H - - - -char pow_fun_char( char, char ); -short pow_fun_short( short, short ); -int pow_fun_int( int, int ); -long pow_fun_long( long, long ); -long long pow_fun_llong( long long, long long ); -unsigned char pow_fun_uchar( unsigned char, unsigned char ); -unsigned short pow_fun_ushort( unsigned short, unsigned short ); -unsigned pow_fun_uint( unsigned, unsigned ); -unsigned long pow_fun_ulong( unsigned long, unsigned long ); -unsigned long long pow_fun_ullong( unsigned long long, unsigned long long ); - -char abs_fun_char( char ); -short abs_fun_short( short ); -long abs_fun_long( long ); -long long abs_fun_llong( long long ); - -char signum_fun_char( char ); -short signum_fun_short( short ); -int signum_fun_int( int ); -long signum_fun_long( long ); -long long signum_fun_llong( long long ); -unsigned char signum_fun_uchar( unsigned char ); -unsigned short signum_fun_ushort( unsigned short ); -unsigned signum_fun_uint( unsigned ); -unsigned long signum_fun_ulong( unsigned long ); -unsigned long long signum_fun_ullong( unsigned long long ); -float signum_fun_float( float ); - -float logBase_fun_float( float, float ); - - - -char setBit_fun_char( char, unsigned ); -short setBit_fun_short( short, unsigned ); -int setBit_fun_int( int, unsigned ); -long setBit_fun_long( long, unsigned ); -long long setBit_fun_llong( long long, unsigned ); -unsigned char setBit_fun_uchar( unsigned char, unsigned ); -unsigned short setBit_fun_ushort( unsigned short, unsigned ); -unsigned setBit_fun_uint( unsigned, unsigned ); -unsigned long setBit_fun_ulong( unsigned long, unsigned ); -unsigned long long setBit_fun_ullong( unsigned long long, unsigned ); - -char clearBit_fun_char( char, unsigned ); -short clearBit_fun_short( short, unsigned ); -int clearBit_fun_int( int, unsigned ); -long clearBit_fun_long( long, unsigned ); -long long clearBit_fun_llong( long long, unsigned ); -unsigned char clearBit_fun_uchar( unsigned char, unsigned ); -unsigned short clearBit_fun_ushort( unsigned short, unsigned ); -unsigned clearBit_fun_uint( unsigned, unsigned ); -unsigned long clearBit_fun_ulong( unsigned long, unsigned ); -unsigned long long clearBit_fun_ullong( unsigned long long, unsigned ); - -char complementBit_fun_char( char, unsigned ); -short complementBit_fun_short( short, unsigned ); -int complementBit_fun_int( int, unsigned ); -long complementBit_fun_long( long, unsigned ); -long long complementBit_fun_llong( long long, unsigned ); -unsigned char complementBit_fun_uchar( unsigned char, unsigned ); -unsigned short complementBit_fun_ushort( unsigned short, unsigned ); -unsigned complementBit_fun_uint( unsigned, unsigned ); -unsigned long complementBit_fun_ulong( unsigned long, unsigned ); -unsigned long long complementBit_fun_ullong( unsigned long long, unsigned ); - -int testBit_fun_char( char, unsigned ); -int testBit_fun_short( short, unsigned ); -int testBit_fun_int( int, unsigned ); -int testBit_fun_long( long, unsigned ); -int testBit_fun_llong( long long, unsigned ); -int testBit_fun_uchar( unsigned char, unsigned ); -int testBit_fun_ushort( unsigned short, unsigned ); -int testBit_fun_uint( unsigned, unsigned ); -int testBit_fun_ulong( unsigned long, unsigned ); -int testBit_fun_ullong( unsigned long long, unsigned ); - -char rotateL_fun_char( char, int ); -short rotateL_fun_short( short, int ); -long rotateL_fun_long( long, int ); -long long rotateL_fun_llong( long long, int ); -int rotateL_fun_int( int, int ); -unsigned char rotateL_fun_uchar( unsigned char, int ); -unsigned short rotateL_fun_ushort( unsigned short, int ); -unsigned long rotateL_fun_ulong( unsigned long, int ); -unsigned long long rotateL_fun_ullong( unsigned long long, int ); - -char rotateR_fun_char( char, int ); -short rotateR_fun_short( short, int ); -int rotateR_fun_int( int, int ); -long rotateR_fun_long( long, int ); -long long rotateR_fun_llong( long long, int ); -unsigned char rotateR_fun_uchar( unsigned char, int ); -unsigned short rotateR_fun_ushort( unsigned short, int ); -unsigned rotateR_fun_uint( unsigned, int ); -unsigned long rotateR_fun_ulong( unsigned long, int ); -unsigned long long rotateR_fun_ullong( unsigned long long, int ); - -char reverseBits_fun_char( char ); -short reverseBits_fun_short( short ); -int reverseBits_fun_int( int ); -long reverseBits_fun_long( long ); -long long reverseBits_fun_llong( long long ); -unsigned char reverseBits_fun_uchar( unsigned char ); -unsigned short reverseBits_fun_ushort( unsigned short ); -unsigned long reverseBits_fun_ulong( unsigned long ); -unsigned long long reverseBits_fun_ullong( unsigned long long ); - -unsigned bitScan_fun_char( char ); -unsigned bitScan_fun_short( short ); -unsigned bitScan_fun_int( int ); -unsigned bitScan_fun_long( long ); -unsigned bitScan_fun_llong( long long ); -unsigned bitScan_fun_uchar( unsigned char ); -unsigned bitScan_fun_ushort( unsigned short ); -unsigned bitScan_fun_uint( unsigned ); -unsigned bitScan_fun_ulong( unsigned long ); -unsigned bitScan_fun_ullong( unsigned long long ); - -unsigned bitCount_fun_char( char ); -unsigned bitCount_fun_short( short ); -unsigned bitCount_fun_int( int ); -unsigned bitCount_fun_long( long ); -unsigned bitCount_fun_llong( long long ); -unsigned bitCount_fun_uchar( unsigned char ); -unsigned bitCount_fun_ushort( unsigned short ); -unsigned bitCount_fun_ulong( unsigned long ); -unsigned bitCount_fun_ullong( unsigned long long ); - - - -typedef struct { - char re; - char im; -} complexOf_char; - -typedef struct { - int re; - int im; -} complexOf_int; - -typedef struct { - long re; - long im; -} complexOf_long; - -typedef struct { - long long re; - long long im; -} complexOf_llong; - -typedef struct { - unsigned char re; - unsigned char im; -} complexOf_uchar; - -typedef struct { - unsigned re; - unsigned im; -} complexOf_uint; - -typedef struct { - unsigned long re; - unsigned long im; -} complexOf_ulong; - -typedef struct { - unsigned long long re; - unsigned long long im; -} complexOf_ullong; - -typedef struct { - float re; - float im; -} complexOf_float; - -int equal_fun_complexOf_char( complexOf_char, complexOf_char ); -int equal_fun_complexOf_int( complexOf_int, complexOf_int ); -int equal_fun_complexOf_long( complexOf_long, complexOf_long ); -int equal_fun_complexOf_llong( complexOf_llong, complexOf_llong ); -int equal_fun_complexOf_uchar( complexOf_uchar, complexOf_uchar ); -int equal_fun_complexOf_uint( complexOf_uint, complexOf_uint ); -int equal_fun_complexOf_ulong( complexOf_ulong, complexOf_ulong ); -int equal_fun_complexOf_ullong( complexOf_ullong, complexOf_ullong ); -int equal_fun_complexOf_float( complexOf_float, complexOf_float ); - -complexOf_char negate_fun_complexOf_char( complexOf_char ); -complexOf_int negate_fun_complexOf_int( complexOf_int ); -complexOf_long negate_fun_complexOf_long( complexOf_long ); -complexOf_llong negate_fun_complexOf_llong( complexOf_llong ); -complexOf_uchar negate_fun_complexOf_uchar( complexOf_uchar ); -complexOf_uint negate_fun_complexOf_uint( complexOf_uint ); -complexOf_ulong negate_fun_complexOf_ulong( complexOf_ulong ); -complexOf_ullong negate_fun_complexOf_ullong( complexOf_ullong ); -complexOf_float negate_fun_complexOf_float( complexOf_float ); - -complexOf_char abs_fun_complexOf_char( complexOf_char ); -complexOf_int abs_fun_complexOf_int( complexOf_int ); -complexOf_long abs_fun_complexOf_long( complexOf_long ); -complexOf_llong abs_fun_complexOf_llong( complexOf_llong ); -complexOf_uchar abs_fun_complexOf_uchar( complexOf_uchar ); -complexOf_uint abs_fun_complexOf_uint( complexOf_uint ); -complexOf_ulong abs_fun_complexOf_ulong( complexOf_ulong ); -complexOf_ullong abs_fun_complexOf_ullong( complexOf_ullong ); -complexOf_float abs_fun_complexOf_float( complexOf_float ); -unsigned abs_fun_complexOf_short( unsigned ); -unsigned abs_fun_complexOf_ushort( unsigned ); - -complexOf_char signum_fun_complexOf_char( complexOf_char ); -complexOf_int signum_fun_complexOf_int( complexOf_int ); -complexOf_long signum_fun_complexOf_long( complexOf_long ); -complexOf_llong signum_fun_complexOf_llong( complexOf_llong ); -complexOf_uchar signum_fun_complexOf_uchar( complexOf_uchar ); -complexOf_uint signum_fun_complexOf_uint( complexOf_uint ); -complexOf_ulong signum_fun_complexOf_ulong( complexOf_ulong ); -complexOf_ullong signum_fun_complexOf_ullong( complexOf_ullong ); -complexOf_float signum_fun_complexOf_float( complexOf_float ); -unsigned signum_fun_complexOf_short( unsigned ); -unsigned signum_fun_complexOf_ushort( unsigned ); - -complexOf_char add_fun_complexOf_char( complexOf_char, complexOf_char ); -complexOf_int add_fun_complexOf_int( complexOf_int, complexOf_int ); -complexOf_long add_fun_complexOf_long( complexOf_long, complexOf_long ); -complexOf_llong add_fun_complexOf_llong( complexOf_llong, complexOf_llong ); -complexOf_uchar add_fun_complexOf_uchar( complexOf_uchar, complexOf_uchar ); -complexOf_uint add_fun_complexOf_uint( complexOf_uint, complexOf_uint ); -complexOf_ulong add_fun_complexOf_ulong( complexOf_ulong, complexOf_ulong ); -complexOf_ullong add_fun_complexOf_ullong( complexOf_ullong, complexOf_ullong ); -complexOf_float add_fun_complexOf_float( complexOf_float, complexOf_float ); - -complexOf_char sub_fun_complexOf_char( complexOf_char, complexOf_char ); -complexOf_int sub_fun_complexOf_int( complexOf_int, complexOf_int ); -complexOf_long sub_fun_complexOf_long( complexOf_long, complexOf_long ); -complexOf_llong sub_fun_complexOf_llong( complexOf_llong, complexOf_llong ); -complexOf_uchar sub_fun_complexOf_uchar( complexOf_uchar, complexOf_uchar ); -complexOf_uint sub_fun_complexOf_uint( complexOf_uint, complexOf_uint ); -complexOf_ulong sub_fun_complexOf_ulong( complexOf_ulong, complexOf_ulong ); -complexOf_ullong sub_fun_complexOf_ullong( complexOf_ullong, complexOf_ullong ); -complexOf_float sub_fun_complexOf_float( complexOf_float, complexOf_float ); - -complexOf_char mult_fun_complexOf_char( complexOf_char, complexOf_char ); -complexOf_int mult_fun_complexOf_int( complexOf_int, complexOf_int ); -complexOf_long mult_fun_complexOf_long( complexOf_long, complexOf_long ); -complexOf_llong mult_fun_complexOf_llong( complexOf_llong, complexOf_llong ); -complexOf_uchar mult_fun_complexOf_uchar( complexOf_uchar, complexOf_uchar ); -complexOf_uint mult_fun_complexOf_uint( complexOf_uint, complexOf_uint ); -complexOf_ulong mult_fun_complexOf_ulong( complexOf_ulong, complexOf_ulong ); -complexOf_ullong mult_fun_complexOf_ullong( complexOf_ullong, complexOf_ullong ); -complexOf_float mult_fun_complexOf_float( complexOf_float, complexOf_float ); -unsigned mult_fun_complexOf_short( unsigned, unsigned ); -unsigned mult_fun_complexOf_ushort( unsigned, unsigned ); - -complexOf_float div_fun_complexOf_float( complexOf_float, complexOf_float ); - -complexOf_float exp_fun_complexOf_float( complexOf_float ); - -complexOf_float sqrt_fun_complexOf_float( complexOf_float ); - -complexOf_float log_fun_complexOf_float( complexOf_float ); - -complexOf_float pow_fun_complexOf_float( complexOf_float, complexOf_float ); - -complexOf_float logBase_fun_complexOf_float( complexOf_float, complexOf_float ); - -complexOf_float sin_fun_complexOf_float( complexOf_float ); - -complexOf_float cos_fun_complexOf_float( complexOf_float ); - -complexOf_float tan_fun_complexOf_float( complexOf_float ); - -complexOf_float sinh_fun_complexOf_float( complexOf_float ); - -complexOf_float cosh_fun_complexOf_float( complexOf_float ); - -complexOf_float tanh_fun_complexOf_float( complexOf_float ); - -complexOf_float asin_fun_complexOf_float( complexOf_float ); - -complexOf_float acos_fun_complexOf_float( complexOf_float ); - -complexOf_float atan_fun_complexOf_float( complexOf_float ); - -complexOf_float asinh_fun_complexOf_float( complexOf_float ); - -complexOf_float acosh_fun_complexOf_float( complexOf_float ); - -complexOf_float atanh_fun_complexOf_float( complexOf_float ); - -complexOf_char complex_fun_char( char, char ); -complexOf_int complex_fun_int( int, int ); -complexOf_long complex_fun_long( long, long ); -complexOf_llong complex_fun_llong( long long, long long ); -complexOf_uchar complex_fun_uchar( unsigned char, unsigned char ); -complexOf_uint complex_fun_uint( unsigned, unsigned ); -complexOf_ulong complex_fun_ulong( unsigned long, unsigned long ); -complexOf_ullong complex_fun_ullong( unsigned long long, unsigned long long ); -complexOf_float complex_fun_float( float, float ); - -char creal_fun_complexOf_char( complexOf_char ); -int creal_fun_complexOf_int( complexOf_int ); -long creal_fun_complexOf_long( complexOf_long ); -long long creal_fun_complexOf_llong( complexOf_llong ); -unsigned char creal_fun_complexOf_uchar( complexOf_uchar ); -unsigned creal_fun_complexOf_uint( complexOf_uint ); -unsigned long creal_fun_complexOf_ulong( complexOf_ulong ); -unsigned long long creal_fun_complexOf_ullong( complexOf_ullong ); -float creal_fun_complexOf_float( complexOf_float ); -short creal_fun_complexOf_short( unsigned ); -unsigned short creal_fun_complexOf_ushort( unsigned ); - -char cimag_fun_complexOf_char( complexOf_char ); -int cimag_fun_complexOf_int( complexOf_int ); -long cimag_fun_complexOf_long( complexOf_long ); -long long cimag_fun_complexOf_llong( complexOf_llong ); -unsigned char cimag_fun_complexOf_uchar( complexOf_uchar ); -unsigned cimag_fun_complexOf_uint( complexOf_uint ); -unsigned long cimag_fun_complexOf_ulong( complexOf_ulong ); -unsigned long long cimag_fun_complexOf_ullong( complexOf_ullong ); -float cimag_fun_complexOf_float( complexOf_float ); -short cimag_fun_complexOf_short( unsigned ); -unsigned short cimag_fun_complexOf_ushort( unsigned ); - -complexOf_char conj_fun_complexOf_char( complexOf_char ); -complexOf_int conj_fun_complexOf_int( complexOf_int ); -complexOf_long conj_fun_complexOf_long( complexOf_long ); -complexOf_llong conj_fun_complexOf_llong( complexOf_llong ); -complexOf_uchar conj_fun_complexOf_uchar( complexOf_uchar ); -complexOf_uint conj_fun_complexOf_uint( complexOf_uint ); -complexOf_ulong conj_fun_complexOf_ulong( complexOf_ulong ); -complexOf_ullong conj_fun_complexOf_ullong( complexOf_ullong ); -complexOf_float conj_fun_complexOf_float( complexOf_float ); -unsigned conj_fun_complexOf_short( unsigned ); -unsigned conj_fun_complexOf_ushort( unsigned ); - -char magnitude_fun_complexOf_char( complexOf_char ); -int magnitude_fun_complexOf_int( complexOf_int ); -long magnitude_fun_complexOf_long( complexOf_long ); -long long magnitude_fun_complexOf_llong( complexOf_llong ); -unsigned char magnitude_fun_complexOf_uchar( complexOf_uchar ); -unsigned magnitude_fun_complexOf_uint( complexOf_uint ); -unsigned long magnitude_fun_complexOf_ulong( complexOf_ulong ); -unsigned long long magnitude_fun_complexOf_ullong( complexOf_ullong ); -float magnitude_fun_complexOf_float( complexOf_float ); -short magnitude_fun_complexOf_short( unsigned ); -unsigned short magnitude_fun_complexOf_ushort( unsigned ); - -char phase_fun_complexOf_char( complexOf_char ); -int phase_fun_complexOf_int( complexOf_int ); -long phase_fun_complexOf_long( complexOf_long ); -long long phase_fun_complexOf_llong( complexOf_llong ); -unsigned char phase_fun_complexOf_uchar( complexOf_uchar ); -unsigned phase_fun_complexOf_uint( complexOf_uint ); -unsigned long phase_fun_complexOf_ulong( complexOf_ulong ); -unsigned long long phase_fun_complexOf_ullong( complexOf_ullong ); -float phase_fun_complexOf_float( complexOf_float ); -short phase_fun_complexOf_short( unsigned ); -unsigned short phase_fun_complexOf_ushort( unsigned ); - -complexOf_char mkPolar_fun_char( char, char ); -complexOf_int mkPolar_fun_int( int, int ); -complexOf_long mkPolar_fun_long( long, long ); -complexOf_llong mkPolar_fun_llong( long long, long long ); -complexOf_uchar mkPolar_fun_uchar( unsigned char, unsigned char ); -complexOf_uint mkPolar_fun_uint( unsigned, unsigned ); -complexOf_ulong mkPolar_fun_ulong( unsigned long, unsigned long ); -complexOf_ullong mkPolar_fun_ullong( unsigned long long, unsigned long long ); -complexOf_float mkPolar_fun_float( float, float ); -unsigned mkPolar_fun_short( short, short ); -unsigned mkPolar_fun_ushort( unsigned short, unsigned short ); - -complexOf_char cis_fun_char( char ); -complexOf_int cis_fun_int( int ); -complexOf_long cis_fun_long( long ); -complexOf_llong cis_fun_llong( long long ); -complexOf_uchar cis_fun_uchar( unsigned char ); -complexOf_uint cis_fun_uint( unsigned ); -complexOf_ulong cis_fun_ulong( unsigned long ); -complexOf_ullong cis_fun_ullong( unsigned long long ); -complexOf_float cis_fun_float( float ); -unsigned cis_fun_short( short ); -unsigned cis_fun_ushort( unsigned short ); - - - -void traceStart(); -void traceEnd(); - -void trace_char( char, int ); -void trace_short( short, int ); -void trace_int( int, int ); -void trace_long( long, int ); -void trace_llong( long long, int ); -void trace_uchar( unsigned char, int ); -void trace_ushort( unsigned short, int ); -void trace_uint( unsigned, int ); -void trace_ulong( unsigned long, int ); -void trace_ullong( unsigned long long, int ); -void trace_float( float, int ); -void trace_complexOf_char( complexOf_char, int ); -void trace_complexOf_short( unsigned, int ); -void trace_complexOf_int( complexOf_int, int ); -void trace_complexOf_long( complexOf_long, int ); -void trace_complexOf_llong( complexOf_llong, int ); -void trace_complexOf_uchar( complexOf_uchar, int ); -void trace_complexOf_ushort( unsigned, int ); -void trace_complexOf_uint( complexOf_uint, int ); -void trace_complexOf_ulong( complexOf_ulong, int ); -void trace_complexOf_ullong( complexOf_ullong, int ); -void trace_complexOf_float( complexOf_float, int ); - -#endif /* FELDSPAR_TI_C64X_H */ diff --git a/Feldspar/Compiler.hs b/Feldspar/Compiler.hs deleted file mode 100644 --- a/Feldspar/Compiler.hs +++ /dev/null @@ -1,44 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Feldspar.Compiler - ( defaultOptions - , c99PlatformOptions - , tic64xPlatformOptions - , unrollOptions - , noPrimitiveInstructionHandling - , noMemoryInformation - , module Feldspar.Compiler.Frontend.Interactive.Interface - , module Feldspar.Compiler.Backend.C.Options - , module Feldspar.Compiler.Imperative.Frontend - ) where - -import Feldspar.Compiler.Compiler -import Feldspar.Compiler.Frontend.Interactive.Interface -import Feldspar.Compiler.Backend.C.Options -- hiding (Var, Fun) -import Feldspar.Compiler.Imperative.Frontend hiding (Type) diff --git a/Feldspar/Compiler/Backend/C/CodeGeneration.hs b/Feldspar/Compiler/Backend/C/CodeGeneration.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/CodeGeneration.hs +++ /dev/null @@ -1,157 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE FlexibleInstances #-} - -module Feldspar.Compiler.Backend.C.CodeGeneration where - -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Error -import Feldspar.Compiler.Backend.C.Options -import Feldspar.Compiler.Backend.C.Library -import Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator - -import qualified Data.List as List (last,find) - --- ======================= --- == C code generation == --- ======================= - -codeGenerationError = handleError "CodeGeneration" - -defaultMemberName = "member" - -data Place = - Declaration_pl - --value of var, need type, type array-style - --declare variables - | MainParameter_pl - --value of var need type, type pointer-style - --main fun parameters - | ValueNeed_pl - --value of var, not need type - - --in Expressions - | AddressNeed_pl - --access of var, not need type - - --output of fun - | FunctionCallIn_pl - --value of var, not need type - SPEC ARRAY FORMAT - --input of fun - deriving (Eq,Show) - -class ToC a where - toC :: Options -> Place -> a -> String - -getStructTypeName :: Options -> Place -> Type -> String -getStructTypeName options place t@(StructType types) = - "_" ++ concat (map ((++"_") . getStructTypeName options place . snd) types) -getStructTypeName options place t@(ArrayType len innerType) = - "arr_T" ++ getStructTypeName options place innerType ++ "_S" ++ len2str len - where - len2str :: Length -> String - len2str UndefinedLen = "UD" - len2str (LiteralLen i) = show i -getStructTypeName options place t = replace (toC options place t) " " "" -- float complex -> floatcomplex - -instance ToC Type where - toC options place VoidType = "void" - toC options place t@(StructType types) = "struct s" ++ getStructTypeName options place t - toC options place (UserType u) = u - -- arraytype handled in variable - toC options place t = case (List.find (\(t',_,_) -> t == t') $ types $ platform options) of - Just (_,s,_) -> s - Nothing -> codeGenerationError InternalError $ - "Unhandled type in platform " ++ (name $ platform options) ++ ": " ++ show t ++ " place: " ++ show place - -instance ToC (Variable AllocationEliminatorSemanticInfo) where - toC options place a@(Variable name typ role _) = show_variable options place role typ name - -show_variable :: Options -> Place -> VariableRole -> Type -> String -> String -show_variable options place role typ name = listprint id " " [variableType, show_name role place typ name] where - variableType = show_type options place typ restr - restr - | place == MainParameter_pl = isRestrict $ platform options - | otherwise = NoRestrict - -show_type :: Options -> Place -> Type -> IsRestrict -> String -show_type options Declaration_pl (ArrayType s t) restr = arrayTypeName -show_type options MainParameter_pl (ArrayType s t) restr = arrayTypeName -show_type options Declaration_pl t _ = toC options Declaration_pl t -show_type options MainParameter_pl t _ = toC options MainParameter_pl t -show_type options _ _ _ = "" - -arrayTypeName = "struct array" - -show_name :: VariableRole -> Place -> Type -> String -> String -show_name Value place t n - | place == AddressNeed_pl = "&" ++ n - | otherwise = n -show_name Pointer MainParameter_pl (ArrayType _ _) n = "* " ++ n -show_name Pointer p (ArrayType _ _) n = n -show_name Pointer place t n - | place == AddressNeed_pl && List.last n == ']' = "&" ++ n - | place == AddressNeed_pl && List.last n /= ']' = n - | place == Declaration_pl = codeGenerationError InternalError $ "Output variable of the function declared!" - | place == MainParameter_pl = "* " ++ n - | List.last n == ']' = n - | otherwise = "(* " ++ n ++ ")" - --- show_array_in_fun :: (HasType a, ToC a) => Options -> Place -> a -> String --- show_array_in_fun options place exp = case typeof exp of - -- t@(ArrayType _ _) -> concat["&(", toC options place exp, genIndex t, ")"] - -- _ -> toC options place exp - --- genIndex :: Type -> String --- genIndex (ArrayType _ t) = "[0]" ++ genIndex t --- genIndex _ = "" - ----------------------- --- Helper functions -- ----------------------- - -ind :: (a-> String) -> a -> String -ind f x = unlines $ map (\a -> " " ++ a) $ lines $ f x - -listprint :: (a->String) -> String -> [a] -> String -listprint f s xs = listprint' s $ filter (\a -> a /= "") $ map f xs where - listprint' _ [] = "" - listprint' _ [x] = x - listprint' s (x:xs) = x ++ s ++ listprint' s (xs) - -decrArrayDepth :: Type -> Type -decrArrayDepth (ArrayType _ t) = t -decrArrayDepth t = codeGenerationError InternalError $ "Non-array variable of type " ++ show t ++ " is indexed!" - -getStructFieldType :: String -> Type -> Type -getStructFieldType f (StructType l) = case List.find (\(a,_) -> a == f) l of - Just (_,t) -> t - Nothing -> structFieldNotFound f -getStructFieldType f t = codeGenerationError InternalError $ - "Trying to get a struct field from not a struct typed expression\n" ++ "Field: " ++ f ++ "\nType: " ++ show t - -structFieldNotFound f = codeGenerationError InternalError $ "Not found struct field with this name: " ++ f diff --git a/Feldspar/Compiler/Backend/C/Library.hs b/Feldspar/Compiler/Backend/C/Library.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Library.hs +++ /dev/null @@ -1,85 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Feldspar.Compiler.Backend.C.Library - (module System.Console.ANSI, - module Feldspar.Compiler.Backend.C.Library) where - -import Control.Monad.State -import System.Console.ANSI -import System.FilePath -import qualified Feldspar.Compiler.Imperative.Representation as AIR - -data CompilationMode = Interactive | Standalone - deriving (Show, Eq) - -type AllocationInfo = ([AIR.Type],[AIR.Type],[AIR.Type]) - --- =========================================================================== --- == String tools --- =========================================================================== - -replace :: Eq a => [a] -> [a] -> [a] -> [a] -replace [] _ _ = [] -replace s find repl | take (length find) s == find = repl ++ (replace (drop (length find) s) find repl) - | otherwise = [head s] ++ (replace (tail s) find repl) - -fixFunctionName :: String -> String -fixFunctionName functionName = replace (replace functionName "_" "__") "'" "_prime" - -makeDebugHFileName :: String -> String -makeDebugHFileName = (<.> "h.dbg.txt") - -makeDebugCFileName :: String -> String -makeDebugCFileName = (<.> "c.dbg.txt") - -makeHFileName :: String -> String -makeHFileName = (<.> "h") - -makeCFileName :: String -> String -makeCFileName = (<.> "c") - --- =========================================================================== --- == Name generator --- =========================================================================== - -newName :: (Monad m) => String -> StateT Integer m String -newName name = do - n <- get - put $ n+1 - return $ name ++ show n - --- =========================================================================== --- == Console tools --- =========================================================================== - -withColor :: Color -> IO () -> IO () -withColor color action = do - setSGR [SetColor Foreground Vivid color, SetColor Background Dull Black] -- , SetConsoleIntensity BoldIntensity] - action - setSGR [Reset] diff --git a/Feldspar/Compiler/Backend/C/Options.hs b/Feldspar/Compiler/Backend/C/Options.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Options.hs +++ /dev/null @@ -1,99 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE TypeSynonymInstances #-} - -module Feldspar.Compiler.Backend.C.Options where - -import Data.Typeable - -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Imperative.Frontend hiding (UserType, Type, Var) -import Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator - -data Options = - Options - { platform :: Platform - , unroll :: UnrollStrategy - , debug :: DebugOption - , memoryInfoVisible :: Bool - , rules :: [Rule] - } deriving (Eq, Show) - -data UnrollStrategy = NoUnroll | Unroll Int - deriving (Eq, Show) - -data DebugOption = NoDebug | NoPrimitiveInstructionHandling - deriving (Eq, Show) - -data Platform = Platform { - name :: String, - types :: [(Type, String, String)], - values :: [(Type, ShowValue)], - includes :: [String], - platformRules :: [Rule], - isRestrict :: IsRestrict -} deriving (Eq, Show) - -type ShowValue = Constant AllocationEliminatorSemanticInfo -> String - -instance Eq ShowValue where - (==) _ _ = True - -instance Show ShowValue where - show _ = "<>" - -data IsRestrict = Restrict | NoRestrict - deriving (Show,Eq) - --- * Actions and rules - -data Action t - = Replace t - | Propagate Rule - | WithId (Int -> [Action t]) - | WithOptions (Options -> [Action t]) - deriving Typeable - -data Rule where - Rule :: (Typeable t) => (t -> [Action t]) -> Rule - -instance Show Rule where - show _ = "Transformation rule." - -instance Eq Rule where - _ == _ = False - -rule :: (Interface t, Typeable (Repr t)) => (t -> [Action (Repr t)]) -> Rule -rule f = Rule $ \x -> f $ toInterface x - -replaceWith :: (Interface t) => t -> Action (Repr t) -replaceWith = Replace . fromInterface - -propagate :: (Interface t, Typeable (Repr t)) => (t -> [Action (Repr t)]) -> Action t' -propagate = Propagate . rule diff --git a/Feldspar/Compiler/Backend/C/Platforms.hs b/Feldspar/Compiler/Backend/C/Platforms.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Platforms.hs +++ /dev/null @@ -1,268 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE ViewPatterns #-} - -module Feldspar.Compiler.Backend.C.Platforms - ( availablePlatforms - , c99 - , tic64x - , c99Rules - , tic64xRules - , traceRules - ) where - - -import Feldspar.Compiler.Backend.C.Options -import qualified Feldspar.Compiler.Backend.C.Options as Opts -import Feldspar.Compiler.Imperative.Representation hiding (Type, Cast, In, Out, Block) -import Feldspar.Compiler.Imperative.Frontend - -availablePlatforms :: [Platform] -availablePlatforms = [ c99, tic64x ] - -c99 = Platform { - name = "c99", - types = - [ (NumType Signed S8, "int8_t", "int8") - , (NumType Signed S16, "int16_t", "int16") - , (NumType Signed S32, "int32_t", "int32") - , (NumType Signed S64, "int64_t", "int64") - , (NumType Unsigned S8, "uint8_t", "uint8") - , (NumType Unsigned S16, "uint16_t", "uint16") - , (NumType Unsigned S32, "uint32_t", "uint32") - , (NumType Unsigned S64, "uint64_t", "uint64") - , (BoolType, "uint32_t", "uint32_t") -- TODO sizeof(bool) is implementation dependent - , (FloatType, "float", "float") - , (ComplexType FloatType, "float complex", "complexOf_float") - ] , - values = - [ (ComplexType FloatType, - (\cx -> "(" ++ showRe cx ++ "+" ++ showIm cx ++ "i)")) - , (BoolType, - (\b -> if boolValue b then "true" else "false")) - ] , - includes = ["\"feldspar_c99.h\"", "\"feldspar_array.h\"", "", "", "", "", ""], - platformRules = c99Rules ++ traceRules, - isRestrict = NoRestrict -} - -tic64x = Platform { - name = "tic64x", - types = - [ (NumType Signed S8, "char", "char") - , (NumType Signed S16, "short", "short") - , (NumType Signed S32, "int", "int") - , (NumType Signed S40, "long", "long") - , (NumType Signed S64, "long long","llong") - , (NumType Unsigned S8, "unsigned char", "uchar") - , (NumType Unsigned S16, "unsigned short", "ushort") - , (NumType Unsigned S32, "unsigned", "uint") - , (NumType Unsigned S40, "unsigned long", "ulong") - , (NumType Unsigned S64, "unsigned long long", "ullong") - , (BoolType, "int", "bool") - , (FloatType, "float", "float") - , (ComplexType FloatType, "complexOf_float", "complexOf_float") - ] , - values = - [ (ComplexType FloatType, - (\cx -> "complex_fun_float(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) - , (BoolType, - (\b -> if boolValue b then "1" else "0")) - ] , - includes = ["\"feldspar_tic64x.h\"", "\"feldspar_array.h\"", "", "", ""], - platformRules = tic64xRules ++ c99Rules ++ traceRules, - isRestrict = Restrict -} - -showRe = showConstant . realPartComplexValue -showIm = showConstant . imagPartComplexValue - -showConstant (IntConst c _ _ _) = show c -showConstant (FloatConst c _ _) = show c ++ "f" - -c99Rules = [rule copy, rule c99] - where - copy (Call "copy" [Out arg1, In arg2]) - | isArray (typeof arg1) = [replaceWith $ Call "copyArray" [Out arg1,In arg2]] - | otherwise = [replaceWith $ arg1 := arg2] - copy _ = [] - c99 (Fun t "(!)" [arg1,arg2]) = [replaceWith $ arg1 :!: arg2] - c99 (Fun t "getFst" [arg]) = [replaceWith $ arg :.: first] - c99 (Fun t "getSnd" [arg]) = [replaceWith $ arg :.: second] - c99 (Fun t "(==)" [arg1, arg2]) = [replaceWith $ Binop t "==" [arg1, arg2]] - c99 (Fun t "(/=)" [arg1, arg2]) = [replaceWith $ Binop t "!=" [arg1, arg2]] - c99 (Fun t "(<)" [arg1, arg2]) = [replaceWith $ Binop t "<" [arg1, arg2]] - c99 (Fun t "(>)" [arg1, arg2]) = [replaceWith $ Binop t ">" [arg1, arg2]] - c99 (Fun t "(<=)" [arg1, arg2]) = [replaceWith $ Binop t "<=" [arg1, arg2]] - c99 (Fun t "(>=)" [arg1, arg2]) = [replaceWith $ Binop t ">=" [arg1, arg2]] - c99 (Fun t "not" [arg]) = [replaceWith $ Fun t "!" [arg]] - c99 (Fun t "(&&)" [arg1, arg2]) = [replaceWith $ Binop t "&&" [arg1, arg2]] - c99 (Fun t "(||)" [arg1, arg2]) = [replaceWith $ Binop t "||" [arg1, arg2]] - c99 (Fun t "quot" [arg1, arg2]) = [replaceWith $ Binop t "/" [arg1, arg2]] - c99 (Fun t "rem" [arg1, arg2]) = [replaceWith $ Binop t "%" [arg1, arg2]] - c99 (Fun t "(^)" [arg1, arg2]) = [replaceWith $ Fun t (extend "pow" t) [arg1, arg2]] - c99 (Fun t "abs" [arg]) = [replaceWith $ Fun t (extend "abs" t) [arg]] - c99 (Fun t "signum" [arg]) = [replaceWith $ Fun t (extend "signum" t) [arg]] - c99 (Fun t "(+)" [arg1, arg2]) = [replaceWith $ Binop t "+" [arg1, arg2]] - c99 (Fun t "(-)" [LitI _ 0, arg2]) = [replaceWith $ Fun t "-" [arg2]] - c99 (Fun t "(-)" [LitF 0, arg2]) = [replaceWith $ Fun t "-" [arg2]] - c99 (Fun t "(-)" [arg1, arg2]) = [replaceWith $ Binop t "-" [arg1, arg2]] - c99 (Fun t "(*)" [LitI _ (log2 -> Just n), arg2]) = [replaceWith $ Binop t "<<" [arg2, LitI I32 n]] - c99 (Fun t "(*)" [arg1, LitI _ (log2 -> Just n)]) = [replaceWith $ Binop t "<<" [arg1, LitI I32 n]] - c99 (Fun t "(*)" [arg1, arg2]) = [replaceWith $ Binop t "*" [arg1, arg2]] - c99 (Fun t "(/)" [arg1, arg2]) = [replaceWith $ Binop t "/" [arg1, arg2]] - c99 (Fun t@(Complex _) "exp" [arg]) = [replaceWith $ Fun t "cexpf" [arg]] - c99 (Fun t "exp" [arg]) = [replaceWith $ Fun t "expf" [arg]] - c99 (Fun t@(Complex _) "sqrt" [arg]) = [replaceWith $ Fun t "csqrtf" [arg]] - c99 (Fun t "sqrt" [arg]) = [replaceWith $ Fun t "sqrtf" [arg]] - c99 (Fun t@(Complex _) "log" [arg]) = [replaceWith $ Fun t "clogf" [arg]] - c99 (Fun t "log" [arg]) = [replaceWith $ Fun t "logf" [arg]] - c99 (Fun t@(Complex _) "(**)" [arg1, arg2]) = [replaceWith $ Fun t "cpowf" [arg1,arg2]] - c99 (Fun t "(**)" [arg1, arg2]) = [replaceWith $ Fun t "powf" [arg1,arg2]] - c99 (Fun t "logBase" [arg1, arg2]) = [replaceWith $ Fun t (extend "logBase" t) [arg1,arg2]] - c99 (Fun t@(Complex _) "sin" [arg]) = [replaceWith $ Fun t "csinf" [arg]] - c99 (Fun t "sin" [arg]) = [replaceWith $ Fun t "sinf" [arg]] - c99 (Fun t@(Complex _) "tan" [arg]) = [replaceWith $ Fun t "ctanf" [arg]] - c99 (Fun t "tan" [arg]) = [replaceWith $ Fun t "tanf" [arg]] - c99 (Fun t@(Complex _) "cos" [arg]) = [replaceWith $ Fun t "ccosf" [arg]] - c99 (Fun t "cos" [arg]) = [replaceWith $ Fun t "cosf" [arg]] - c99 (Fun t@(Complex _) "asin" [arg]) = [replaceWith $ Fun t "casinf" [arg]] - c99 (Fun t "asin" [arg]) = [replaceWith $ Fun t "asinf" [arg]] - c99 (Fun t@(Complex _) "atan" [arg]) = [replaceWith $ Fun t "catanf" [arg]] - c99 (Fun t "atan" [arg]) = [replaceWith $ Fun t "atanf" [arg]] - c99 (Fun t@(Complex _) "acos" [arg]) = [replaceWith $ Fun t "cacosf" [arg]] - c99 (Fun t "acos" [arg]) = [replaceWith $ Fun t "acosf" [arg]] - c99 (Fun t@(Complex _) "sinh" [arg]) = [replaceWith $ Fun t "csinhf" [arg]] - c99 (Fun t "sinh" [arg]) = [replaceWith $ Fun t "sinhf" [arg]] - c99 (Fun t@(Complex _) "tanh" [arg]) = [replaceWith $ Fun t "ctanhf" [arg]] - c99 (Fun t "tanh" [arg]) = [replaceWith $ Fun t "tanhf" [arg]] - c99 (Fun t@(Complex _) "cosh" [arg]) = [replaceWith $ Fun t "ccoshf" [arg]] - c99 (Fun t "cosh" [arg]) = [replaceWith $ Fun t "coshf" [arg]] - c99 (Fun t@(Complex _) "asinh" [arg]) = [replaceWith $ Fun t "casinhf" [arg]] - c99 (Fun t "asinh" [arg]) = [replaceWith $ Fun t "asinhf" [arg]] - c99 (Fun t@(Complex _) "atanh" [arg]) = [replaceWith $ Fun t "catanhf" [arg]] - c99 (Fun t "atanh" [arg]) = [replaceWith $ Fun t "atanhf" [arg]] - c99 (Fun t@(Complex _) "acosh" [arg]) = [replaceWith $ Fun t "cacoshf" [arg]] - c99 (Fun t "acosh" [arg]) = [replaceWith $ Fun t "acoshf" [arg]] - c99 (Fun t "(.&.)" [arg1, arg2]) = [replaceWith $ Binop t "&" [arg1, arg2]] - c99 (Fun t "(.|.)" [arg1, arg2]) = [replaceWith $ Binop t "|" [arg1, arg2]] - c99 (Fun t "xor" [arg1, arg2]) = [replaceWith $ Binop t "^" [arg1, arg2]] - c99 (Fun t "complement" [arg]) = [replaceWith $ Fun t "~" [arg]] - c99 (Fun t "bit" [arg]) = [replaceWith $ Binop t "<<" [LitI t 1, arg]] - c99 (Fun t "setBit" [arg1, arg2]) = [replaceWith $ Fun t (extend "setBit" t) [arg1, arg2]] - c99 (Fun t "clearBit" [arg1, arg2]) = [replaceWith $ Fun t (extend "clearBit" t) [arg1, arg2]] - c99 (Fun t "complementBit" [arg1, arg2]) = [replaceWith $ Fun t (extend "complementBit" t) [arg1, arg2]] - c99 (Fun t "testBit" [arg1, arg2]) = [replaceWith $ Fun t (extend "testBit" $ typeof arg1) [arg1, arg2]] - c99 (Fun t "shiftL" [arg1, arg2]) = [replaceWith $ Binop t "<<" [arg1, arg2]] - c99 (Fun t "shiftR" [arg1, arg2]) = [replaceWith $ Binop t ">>" [arg1, arg2]] - c99 (Fun t "rotateL" [arg1, arg2]) = [replaceWith $ Fun t (extend "rotateL" t) [arg1, arg2]] - c99 (Fun t "rotateR" [arg1, arg2]) = [replaceWith $ Fun t (extend "rotateR" t) [arg1, arg2]] - c99 (Fun t "reverseBits" [arg]) = [replaceWith $ Fun t (extend "reverseBits" t) [arg]] - c99 (Fun t "bitScan" [arg]) = [replaceWith $ Fun t (extend "bitScan" $ typeof arg) [arg]] - c99 (Fun t "bitCount" [arg]) = [replaceWith $ Fun t (extend "bitCount" $ typeof arg) [arg]] - c99 (Fun t "bitSize" [intWidth . typeof -> Just n]) = [replaceWith $ LitI U32 n] - c99 (Fun t "isSigned" [intSigned . typeof -> Just b]) = [replaceWith $ litB b] - c99 (Fun t "complex" [arg1, arg2]) = [replaceWith $ Fun t (extend "complex" $ typeof arg1) [arg1,arg2]] - c99 (Fun t "creal" [arg]) = [replaceWith $ Fun t "crealf" [arg]] - c99 (Fun t "cimag" [arg]) = [replaceWith $ Fun t "cimagf" [arg]] - c99 (Fun t "conjugate" [arg]) = [replaceWith $ Fun t "conjf" [arg]] - c99 (Fun t "magnitude" [arg]) = [replaceWith $ Fun t "cabsf" [arg]] - c99 (Fun t "phase" [arg]) = [replaceWith $ Fun t "cargf" [arg]] - c99 (Fun t "mkPolar" [arg1, arg2]) = [replaceWith $ Fun t (extend "mkPolar" $ typeof arg1) [arg1, arg2]] - c99 (Fun t "cis" [arg]) = [replaceWith $ Fun t (extend "cis" $ typeof arg) [arg]] - c99 (Fun t "f2i" [arg]) = [replaceWith $ Cast t $ Fun Floating "truncf" [arg]] - c99 (Fun (Complex t) "i2n" [arg]) = [replaceWith $ Fun (Complex t) (extend "complex" t) [Cast t arg, LitF 0]] - c99 (Fun t "i2n" [arg]) = [replaceWith $ Cast t arg] - c99 (Fun t "b2i" [arg]) = [replaceWith $ Cast t arg] - c99 (Fun t "round" [arg]) = [replaceWith $ Cast t $ Fun Floating "roundf" [arg]] - c99 (Fun t "ceiling" [arg]) = [replaceWith $ Cast t $ Fun Floating "ceilf" [arg]] - c99 (Fun t "floor" [arg]) = [replaceWith $ Cast t $ Fun Floating "floorf" [arg]] - c99 _ = [] - -tic64xRules = [rule tic64x] - where - tic64x (Fun t "(==)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "equal" $ typeof arg1) [arg1, arg2]] - tic64x (Fun t "(/=)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t "!" [Fun t (extend "equal" $ typeof arg1) [arg1, arg2]]] - tic64x (Fun t "abs" [arg@(typeof -> Floating)]) = [replaceWith $ Fun t "_fabs" [arg]] - tic64x (Fun t "abs" [arg@(typeof -> I32)]) = [replaceWith $ Fun t "_abs" [arg]] - tic64x (Fun t "(+)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "add" $ typeof arg1) [arg1, arg2]] - tic64x (Fun t "(-)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "sub" $ typeof arg1) [arg1, arg2]] - tic64x (Fun t "(*)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "mult" $ typeof arg1) [arg1, arg2]] - tic64x (Fun t "(/)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "div" $ typeof arg1) [arg1, arg2]] - tic64x (Fun t "exp" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "exp" $ typeof arg1) [arg1, arg2]] - tic64x (Fun t "sqrt" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "sqrt" $ typeof arg1) [arg1, arg2]] - tic64x (Fun t "log" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "log" $ typeof arg1) [arg1, arg2]] - tic64x (Fun t "(**)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "cpow" $ typeof arg1) [arg1, arg2]] - tic64x (Fun t "logBase" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "logBase" $ typeof arg1) [arg1, arg2]] - tic64x (Fun t name [arg@(typeof -> Complex _)]) - | name `elem` ["sin","tan","cos","asin","atan","acos","sinh","tanh","cosh","asinh","atanh","acosh","creal","cimag","conjugate","magnitude","phase"] - = [replaceWith $ Fun t (extend name $ typeof arg) [arg]] - tic64x (Fun t "rotateL" [arg1@(typeof -> U32), arg2]) = [replaceWith $ Fun t "_rotl" [arg1, arg2]] - tic64x (Fun t "reverseBits" [arg@(typeof -> U32)]) = [replaceWith $ Fun t "_bitr" [arg]] - tic64x (Fun t "bitCount" [arg@(typeof -> U32)]) = [replaceWith $ Fun t "_dotpu4" [Fun t "_bitc4" [arg], LitI U32 0x01010101]] - tic64x (Fun t name [arg@(typeof -> Complex _)]) = [replaceWith $ Fun t (extend "creal" $ typeof arg) [arg]] - tic64x _ = [] - -traceRules = [rule trace] - where - trace (Fun t "trace" [lab, val]) = [WithId acts] - where - acts i = [replaceWith trcVar, propagate decl, propagate trc, propagate frame] - where - trcVar = Var t trcVarName - trcVarName = "trc" ++ show i - defTrcVar = Def t trcVarName - decl (Bl defs prg) = [replaceWith $ Bl (defs ++ [defTrcVar]) prg] - trc :: Prog -> [Action (Repr Prog)] - trc instr = [replaceWith $ Seq [init,trcCall,instr]] - trcCall = Call (extend' "trace" t) [In trcVar, In lab] - init = trcVar := val - frame (ProcDf pname ins outs prg) = [replaceWith $ ProcDf pname ins outs prg'] - where - prg' = case prg of - Seq (Call "traceStart" [] : _) -> prg - Block _ (Seq (Call "traceStart" [] : _)) -> prg - _ -> Seq [Call "traceStart" [], prg, Call "traceEnd" []] - trace _ = [] - -extend :: String -> Type -> String -extend s t = s ++ "_fun_" ++ show t - -extend' :: String -> Type -> String -extend' s t = s ++ "_" ++ show t - -log2 :: Integer -> Maybe Integer -log2 n - | n == 2 Prelude.^ l = Just l - | otherwise = Nothing - where - l = toInteger $ length $ takeWhile (<=n) $ map (2 Prelude.^) [1..] - -first = "member1" -second = "member2" diff --git a/Feldspar/Compiler/Backend/C/Plugin/AllocationEliminator.hs b/Feldspar/Compiler/Backend/C/Plugin/AllocationEliminator.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Plugin/AllocationEliminator.hs +++ /dev/null @@ -1,207 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator where - -import Data.Map (Map) -import qualified Data.Map as Map -import Feldspar.Transformation -import Feldspar.Compiler.Backend.C.Library - -data AllocationEliminator = AllocationEliminator - -data AllocationEliminatorSemanticInfo - -instance Annotation AllocationEliminatorSemanticInfo Module where - type Label AllocationEliminatorSemanticInfo Module = () - -instance Annotation AllocationEliminatorSemanticInfo Entity where - type Label AllocationEliminatorSemanticInfo Entity = () - -instance Annotation AllocationEliminatorSemanticInfo Struct where - type Label AllocationEliminatorSemanticInfo Struct = () - -instance Annotation AllocationEliminatorSemanticInfo ProcDef where - type Label AllocationEliminatorSemanticInfo ProcDef = AllocationInfo - -instance Annotation AllocationEliminatorSemanticInfo ProcDecl where - type Label AllocationEliminatorSemanticInfo ProcDecl = AllocationInfo - -instance Annotation AllocationEliminatorSemanticInfo StructMember where - type Label AllocationEliminatorSemanticInfo StructMember = () - -instance Annotation AllocationEliminatorSemanticInfo Block where - type Label AllocationEliminatorSemanticInfo Block = () - -instance Annotation AllocationEliminatorSemanticInfo Program where - type Label AllocationEliminatorSemanticInfo Program = () - -instance Annotation AllocationEliminatorSemanticInfo Empty where - type Label AllocationEliminatorSemanticInfo Empty = () - -instance Annotation AllocationEliminatorSemanticInfo Assign where - type Label AllocationEliminatorSemanticInfo Assign = () - -instance Annotation AllocationEliminatorSemanticInfo ProcedureCall where - type Label AllocationEliminatorSemanticInfo ProcedureCall = () - -instance Annotation AllocationEliminatorSemanticInfo Sequence where - type Label AllocationEliminatorSemanticInfo Sequence = () - -instance Annotation AllocationEliminatorSemanticInfo Branch where - type Label AllocationEliminatorSemanticInfo Branch = () - -instance Annotation AllocationEliminatorSemanticInfo SeqLoop where - type Label AllocationEliminatorSemanticInfo SeqLoop = () - -instance Annotation AllocationEliminatorSemanticInfo ParLoop where - type Label AllocationEliminatorSemanticInfo ParLoop = () - -instance Annotation AllocationEliminatorSemanticInfo ActualParameter where - type Label AllocationEliminatorSemanticInfo ActualParameter = () - -instance Annotation AllocationEliminatorSemanticInfo Declaration where - type Label AllocationEliminatorSemanticInfo Declaration = () - -instance Annotation AllocationEliminatorSemanticInfo Expression where - type Label AllocationEliminatorSemanticInfo Expression = () - -instance Annotation AllocationEliminatorSemanticInfo FunctionCall where - type Label AllocationEliminatorSemanticInfo FunctionCall = () - -instance Annotation AllocationEliminatorSemanticInfo SizeOf where - type Label AllocationEliminatorSemanticInfo SizeOf = () - -instance Annotation AllocationEliminatorSemanticInfo ArrayElem where - type Label AllocationEliminatorSemanticInfo ArrayElem = () - -instance Annotation AllocationEliminatorSemanticInfo StructField where - type Label AllocationEliminatorSemanticInfo StructField = () - -instance Annotation AllocationEliminatorSemanticInfo Constant where - type Label AllocationEliminatorSemanticInfo Constant = () - -instance Annotation AllocationEliminatorSemanticInfo IntConst where - type Label AllocationEliminatorSemanticInfo IntConst = () - -instance Annotation AllocationEliminatorSemanticInfo FloatConst where - type Label AllocationEliminatorSemanticInfo FloatConst = () - -instance Annotation AllocationEliminatorSemanticInfo BoolConst where - type Label AllocationEliminatorSemanticInfo BoolConst = () - -instance Annotation AllocationEliminatorSemanticInfo ArrayConst where - type Label AllocationEliminatorSemanticInfo ArrayConst = () - -instance Annotation AllocationEliminatorSemanticInfo ComplexConst where - type Label AllocationEliminatorSemanticInfo ComplexConst = () - -instance Annotation AllocationEliminatorSemanticInfo Variable where - type Label AllocationEliminatorSemanticInfo Variable = () - -instance Annotation AllocationEliminatorSemanticInfo Cast where - type Label AllocationEliminatorSemanticInfo Cast = () - -instance Annotation AllocationEliminatorSemanticInfo Comment where - type Label AllocationEliminatorSemanticInfo Comment = () - - -instance Transformation AllocationEliminator - where - type From AllocationEliminator = () - type To AllocationEliminator = AllocationEliminatorSemanticInfo - type Down AllocationEliminator = () - type Up AllocationEliminator = () - type State AllocationEliminator = (Integer, Map String (Integer, Type)) - -instance Transformable AllocationEliminator Entity - where - transform t s d proc@(ProcDef _ _ _ _ _ _) = Result proc' - { inParams = mem : ins' - , procDefLabel = (localsOf s', typesOf ins', typesOf outs') - } - (0,Map.empty) u' - where - Result proc' s' u' = defaultTransform t s d proc - mem = Variable - { varName = "mem" - , varType = ArrayType UndefinedLen $ ArrayType UndefinedLen VoidType - , varRole = Pointer - , varLabel = () - } - ins' = inParams proc' - outs' = outParams proc' - localsOf = map (\(_,(_,t)) -> t) . Map.toList . snd - typesOf = map varType - - transform t s d x = defaultTransform t s d x - -instance Transformable AllocationEliminator Expression - where - transform t s@(idx,m) d e@(VarExpr v lab) = case Map.lookup (varName v) m of - Nothing -> defaultTransform t s d e - Just (i,_) -> Result ArrayElem - { array = VarExpr - { var = Variable - { varName = "mem" - , varType = ArrayType UndefinedLen $ varType v - , varRole = Pointer - , varLabel = () - } - , exprLabel = () - } - , arrayIndex = ConstExpr - { constExpr = IntConst - { intValue = i - , intType = NumType Signed S32 - , intConstLabel = () - , constLabel = () - } - , exprLabel = () - } - , arrayLabel = () - , exprLabel = () - } s () - transform t s d e = defaultTransform t s d e - -instance Transformable1 AllocationEliminator [] Declaration - where - transform1 t s d [] = Result1 [] s () - transform1 t s@(idx,m) d (x:xs) = case varType $ declVar x of - ArrayType _ _ -> transform1 t (idx + 1, Map.insert (varName $ declVar x) (idx, varType $ declVar x) m) d xs - _ -> Result1 (x':xs') s'' () - where - Result1 xs' s'' () = transform1 t s' d xs - Result x' s' () = transform t s d x - -instance Plugin AllocationEliminator - where - type ExternalInfo AllocationEliminator = () - executePlugin self@AllocationEliminator externalInfo procedure = - result $ transform self (0,Map.empty) () procedure - diff --git a/Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs b/Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs +++ /dev/null @@ -1,80 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE EmptyDataDecls, TypeFamilies #-} - -module Feldspar.Compiler.Backend.C.Plugin.BlockProgramHandler where - -import Data.List -import Feldspar.Transformation -import Feldspar.Compiler.Backend.C.CodeGeneration -import Feldspar.Compiler.Backend.C.Options -import Feldspar.Compiler.Error - --- =========================================================================== --- == Type definition generator plugin --- =========================================================================== - -data BlockProgramHandler = BlockProgramHandler - -instance Default [Declaration ()] where - def = [] - -instance Combine [Declaration ()] where - combine a b = a ++ b - -instance Transformation BlockProgramHandler where - type From BlockProgramHandler = () - type To BlockProgramHandler = () - type Down BlockProgramHandler = () - type Up BlockProgramHandler = [Declaration ()] - type State BlockProgramHandler = () - -instance Transformable BlockProgramHandler Block where - transform t s d b = tr - { result = (result tr) - { locals = (locals $ result tr) ++ up tr - } - , up = ([]) - } - where - tr = defaultTransform t s d b - -instance Transformable BlockProgramHandler Program where - transform t s d p = - case result tr of - BlockProgram b _ -> Result (blockBody b) () (locals b ++ up tr) - _ -> tr - where - tr = defaultTransform t s d p - - -instance Plugin BlockProgramHandler where - type ExternalInfo BlockProgramHandler = () - executePlugin BlockProgramHandler externalInfo procedure = - result $ transform BlockProgramHandler ({-state-}) () procedure diff --git a/Feldspar/Compiler/Backend/C/Plugin/Locator.hs b/Feldspar/Compiler/Backend/C/Plugin/Locator.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Plugin/Locator.hs +++ /dev/null @@ -1,242 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE TypeFamilies #-} - -module Feldspar.Compiler.Backend.C.Plugin.Locator where - -import Feldspar.Transformation -import Feldspar.Compiler.Backend.C.CodeGeneration -import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint -import Feldspar.Compiler.Backend.C.Platforms -import Feldspar.Compiler.Backend.C.Options -import Feldspar.Compiler.Error - - --- =========================================================================== --- == GetPrg plugin --- =========================================================================== - - -instance Default Bool where - def = False - -instance Default (Program DebugToCSemanticInfo) where - def = Empty ((0,0),(0,0)) ((0,0),(0,0)) - -instance Combine Bool where - combine l1 l2 = l1 || l2 - -instance Combine (Program DebugToCSemanticInfo) where - combine (Empty _ _) p2 = p2 - combine p1 _ = p1 - ------------------------------------------------------ ---- GetPrg plugin for ParLoop ------------------------------------------------------ - -data GetPrgParLoop = GetPrgParLoop - -instance Transformation GetPrgParLoop where - type From GetPrgParLoop = DebugToCSemanticInfo - type To GetPrgParLoop = DebugToCSemanticInfo - type Down GetPrgParLoop = (Int, Int) - type Up GetPrgParLoop = (Bool, Program DebugToCSemanticInfo) - type State GetPrgParLoop = () - - -instance Plugin GetPrgParLoop where - type ExternalInfo GetPrgParLoop = (Int, Int) - executePlugin GetPrgParLoop (line, col) procedure = - result $ transform GetPrgParLoop () (line, col) procedure - -getPrgParLoop :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo) -getPrgParLoop (line, col) procedure = up res where - res = transform GetPrgParLoop () (line, col) procedure - -instance Transformable GetPrgParLoop Program where - transform t () (line, col) pl@(ParLoop _ _ _ prog inf1 inf2) = Result pl () info where - info = case contains (line, col) inf1 of - True -> infoCr where - res = transform t () (line, col) prog - infoCr = case (fst $ up res) of - True -> up res - _ -> (True, pl) - _ -> def - transform t () (line, col) pr = defaultTransform t () (line, col) pr - ------------------------------------------------------ ---- GetPrg plugin for Assign ------------------------------------------------------ - -data GetPrgAssign = GetPrgAssign - -instance Transformation GetPrgAssign where - type From GetPrgAssign = DebugToCSemanticInfo - type To GetPrgAssign = DebugToCSemanticInfo - type Down GetPrgAssign = (Int, Int) - type Up GetPrgAssign = (Bool, Program DebugToCSemanticInfo) - type State GetPrgAssign = () - - -instance Plugin GetPrgAssign where - type ExternalInfo GetPrgAssign = (Int, Int) - executePlugin GetPrgAssign (line, col) procedure = - result $ transform GetPrgAssign () (line, col) procedure - -getPrgAssign :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo) -getPrgAssign (line, col) procedure = up res where - res = transform GetPrgAssign () (line, col) procedure - -instance Transformable GetPrgAssign Program where - transform t () (line, col) assign@(Assign _ _ inf1 inf2) = Result assign () info where - info = case contains (line, col) inf1 of - True -> (True, assign) - _ -> def - transform t () (line, col) pr = defaultTransform t () (line, col) pr - - ------------------------------------------------------ ---- GetPrg plugin for Branch ------------------------------------------------------ - -data GetPrgBranch = GetPrgBranch - -instance Transformation GetPrgBranch where - type From GetPrgBranch = DebugToCSemanticInfo - type To GetPrgBranch = DebugToCSemanticInfo - type Down GetPrgBranch = (Int, Int) - type Up GetPrgBranch = (Bool, Program DebugToCSemanticInfo) - type State GetPrgBranch = () - - -instance Plugin GetPrgBranch where - type ExternalInfo GetPrgBranch = (Int, Int) - executePlugin GetPrgBranch (line, col) procedure = - result $ transform GetPrgBranch () (line, col) procedure - -getPrgBranch :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo) -getPrgBranch (line, col) procedure = up res where - res = transform GetPrgBranch () (line, col) procedure - -instance Transformable GetPrgBranch Program where - transform t () (line, col) br@(Branch _ prog1 prog2 inf1 inf2) = Result br () info where - info = case contains (line, col) inf1 of - True -> infoCr where - res1 = transform t () (line, col) prog1 - res2 = transform t () (line, col) prog2 - res = combine (up res1) (up res2) - infoCr = case (fst res) of - True -> res - _ -> (True, br) - _ -> def - - transform t () (line, col) pr = defaultTransform t () (line, col) pr - ------------------------------------------------------ ---- GetPrg plugin for ProcedureCall ------------------------------------------------------ - -data GetPrgProcCall = GetPrgProcCall - -instance Transformation GetPrgProcCall where - type From GetPrgProcCall = DebugToCSemanticInfo - type To GetPrgProcCall = DebugToCSemanticInfo - type Down GetPrgProcCall = (Int, Int) - type Up GetPrgProcCall = (Bool, Program DebugToCSemanticInfo) - type State GetPrgProcCall = () - - -instance Plugin GetPrgProcCall where - type ExternalInfo GetPrgProcCall = (Int, Int) - executePlugin GetPrgProcCall (line, col) procedure = - result $ transform GetPrgProcCall () (line, col) procedure - -getPrgProcCall :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo) -getPrgProcCall (line, col) procedure = up res where - res = transform GetPrgProcCall () (line, col) procedure - -instance Transformable GetPrgProcCall Program where - transform t () (line, col) pc@(ProcedureCall _ _ inf1 inf2) = Result pc () info where - info = case contains (line, col) inf1 of - True -> (True, pc) - _ -> def - transform t () (line, col) pr = defaultTransform t () (line, col) pr - ------------------------------------------------------ ---- GetPrg plugin for SeqLoop ------------------------------------------------------ - -data GetPrgSeqLoop = GetPrgSeqLoop - -instance Transformation GetPrgSeqLoop where - type From GetPrgSeqLoop = DebugToCSemanticInfo - type To GetPrgSeqLoop = DebugToCSemanticInfo - type Down GetPrgSeqLoop = (Int, Int) - type Up GetPrgSeqLoop = (Bool, Program DebugToCSemanticInfo) - type State GetPrgSeqLoop = () - - -instance Plugin GetPrgSeqLoop where - type ExternalInfo GetPrgSeqLoop = (Int, Int) - executePlugin GetPrgSeqLoop (line, col) procedure = - result $ transform GetPrgSeqLoop () (line, col) procedure - -getPrgSeqLoop :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo) -getPrgSeqLoop (line, col) procedure = up res where - res = transform GetPrgSeqLoop () (line, col) procedure - -instance Transformable GetPrgSeqLoop Program where - transform t () (line, col) sl@(SeqLoop _ _ prog inf1 inf2) = Result sl () info where - info = case contains (line, col) inf1 of - True -> infoCr where - res = transform t () (line, col) prog - infoCr = case (fst $ up res) of - True -> up res - _ -> (True, sl) - _ -> def - transform t () (line, col) pr = defaultTransform t () (line, col) pr - - -------------------------------------------------- ------- Helper functions -------------------------------------------------- - -contains (line, col) ((bl, bc), (el, ec)) = (line == bl && bc <= col) || (bl < line && line < el) || (line == el && col <= ec) - -myShow :: Program DebugToCSemanticInfo -> String -myShow (Assign lhs rhs inf1 inf2) = "Assign \n" ++ ind show lhs ++ "\n=\n" ++ ind show rhs ++ "\n" ++ show inf1 ++ "\n" -myShow (Sequence progs inf1 inf2) = "Sequence\n" ++ ind (listprint myShow "\n") progs ++ "\n" ++ show inf1 ++ "\n" -myShow (Branch cond thenBlock elseBlock inf1 inf2) = "Branch\n" ++ ind myShowB thenBlock ++ "\nelse\n" ++ ind myShowB elseBlock ++ "\n" ++ show inf1 ++ "\n" -myShow (ParLoop count bound step block inf1 inf2) - = "ParLoop\n count: " ++ show count ++ "\n bound: " ++ show bound ++ "\n step: " ++ show step ++ "\n" ++ ind myShowB block ++ "\n" ++ show inf1 ++ "\n" -myShow x = show x - -myShowB :: Block DebugToCSemanticInfo -> String -myShowB (Block locals prg inf) = "Block\n" ++ ind show locals ++"\n" ++ ind myShow prg ++ show inf - diff --git a/Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs b/Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs +++ /dev/null @@ -1,722 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE TypeFamilies #-} - -module Feldspar.Compiler.Backend.C.Plugin.PrettyPrint where - -import Feldspar.Transformation -import Feldspar.Compiler.Backend.C.CodeGeneration -import Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator -import Feldspar.Compiler.Backend.C.Platforms -import Feldspar.Compiler.Backend.C.Options -import Feldspar.Compiler.Backend.C.Library -import Feldspar.Compiler.Error - -import qualified Data.List as List (last,find, intersperse) -import qualified Control.Monad.State as StateMonad (get, put, runState) - --- =========================================================================== --- == DebugToC plugin --- =========================================================================== - -data DebugToC = DebugToC - -data DebugToCSemanticInfo - -instance Annotation DebugToCSemanticInfo Module where - type Label DebugToCSemanticInfo Module = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Entity where - type Label DebugToCSemanticInfo Entity = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Struct where - type Label DebugToCSemanticInfo Struct = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo ProcDef where - type Label DebugToCSemanticInfo ProcDef = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo ProcDecl where - type Label DebugToCSemanticInfo ProcDecl = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo StructMember where - type Label DebugToCSemanticInfo StructMember = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Block where - type Label DebugToCSemanticInfo Block = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Program where - type Label DebugToCSemanticInfo Program = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Empty where - type Label DebugToCSemanticInfo Empty = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Assign where - type Label DebugToCSemanticInfo Assign = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo ProcedureCall where - type Label DebugToCSemanticInfo ProcedureCall = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Sequence where - type Label DebugToCSemanticInfo Sequence = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Branch where - type Label DebugToCSemanticInfo Branch = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo SeqLoop where - type Label DebugToCSemanticInfo SeqLoop = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo ParLoop where - type Label DebugToCSemanticInfo ParLoop = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo ActualParameter where - type Label DebugToCSemanticInfo ActualParameter = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Declaration where - type Label DebugToCSemanticInfo Declaration = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Expression where - type Label DebugToCSemanticInfo Expression = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo FunctionCall where - type Label DebugToCSemanticInfo FunctionCall = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo SizeOf where - type Label DebugToCSemanticInfo SizeOf = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo ArrayElem where - type Label DebugToCSemanticInfo ArrayElem = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo StructField where - type Label DebugToCSemanticInfo StructField = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Constant where - type Label DebugToCSemanticInfo Constant = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo IntConst where - type Label DebugToCSemanticInfo IntConst = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo FloatConst where - type Label DebugToCSemanticInfo FloatConst = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo BoolConst where - type Label DebugToCSemanticInfo BoolConst = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo ArrayConst where - type Label DebugToCSemanticInfo ArrayConst = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo ComplexConst where - type Label DebugToCSemanticInfo ComplexConst = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Variable where - type Label DebugToCSemanticInfo Variable = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Cast where - type Label DebugToCSemanticInfo Cast = ((Int, Int), (Int, Int)) - -instance Annotation DebugToCSemanticInfo Comment where - type Label DebugToCSemanticInfo Comment = ((Int, Int), (Int, Int)) - - -instance Transformation DebugToC where - type From DebugToC = AllocationEliminatorSemanticInfo - type To DebugToC = DebugToCSemanticInfo - type Down DebugToC = (Options, Place, Int) -- Platform, Place and Indentation - type Up DebugToC = String - type State DebugToC = (Int, Int) - -instance Plugin DebugToC where - type ExternalInfo DebugToC = ((Options, Place), Int) - executePlugin DebugToC ((options, place), line) procedure = - result $ transform DebugToC (line, 0) (options, place, 0) procedure - -compToC :: ((Options, Place), Int) -> Module AllocationEliminatorSemanticInfo -> (String, (Int, Int)) -compToC ((options, place), line) procedure = (up res, state res) where - res = transform DebugToC (line, 0) (options, place, 0) procedure - -compToCWithInfos :: ((Options, Place), Int) -> Module AllocationEliminatorSemanticInfo -> (Module DebugToCSemanticInfo, (String, (Int, Int))) -compToCWithInfos ((options, place), line) procedure = (result res, (up res, state res)) where - res = transform DebugToC (line, 0) (options, place, 0) procedure - -instance Transformable DebugToC Variable where - transform t (line, col) (options, ValueNeed_pl, indent) x@(Variable name typ@(ArrayType _ _) role inf) = Result (Variable name typ role newInf) (snd newInf) cRep - where - ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - code $ toC options AddressNeed_pl x - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return newInf - transform t (line, col) (options, place, indent) x@(Variable name typ role inf) = Result (Variable name typ role newInf) (snd newInf) cRep - where - ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - code $ toC options place x - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return newInf - -instance Transformable1 DebugToC [] Constant where - transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l ", " 0 - -instance Transformable DebugToC Constant where - transform t pos@(line, col) down@(options, place, indent) const@(IntConst c _ inf1 inf2) = transformConst t pos down const (show c) - - transform t pos@(line, col) down@(options, place, indent) const@(FloatConst c inf1 inf2) = transformConst t pos down const (show c ++ "f") - - transform t pos@(line, col) down@(options, place, indent) const@(BoolConst False inf1 inf2) = transformConst t pos down const "0" - - transform t pos@(line, col) down@(options, place, indent) const@(BoolConst True inf1 inf2) = transformConst t pos down const "1" - - transform t (line, col) (options, place, indent) const@(ComplexConst real im inf1 inf2) - = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of - Just (_,f) -> - Result (ComplexConst (result newReal) (result newIm) newInf newInf) (snd newInf) cRep - where - ((newReal, newIm, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - newReal <- complexTransform t (options, place, indent) real - newIm <- complexTransform t (options, place, indent) im - code $ f const - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newReal, newIm, newInf) - Nothing -> - Result (ComplexConst (result newReal) (result newIm) newInf newInf) (snd newInf) cRep - where - ((newReal, newIm, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - code "complex(" - newReal <- monadicTransform' t (options, place, indent) real - code "," - newIm <- monadicTransform' t (options, place, indent) im - code ")" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newReal, newIm, newInf) - -instance Transformable DebugToC ActualParameter where - transform t pos@(line, col) down@(options, place, indent) act@(In param@(VarExpr (Variable _ (StructType _) _ _) _) inf) = - transformActParam t pos down act AddressNeed_pl - transform t pos@(line, col) down@(options, place, indent) act@(In param@(VarExpr (Variable _ (ArrayType _ _) _ _) _) inf) = - transformActParam t pos down act AddressNeed_pl - transform t pos@(line, col) down@(options, place, indent) act@(In _ _) = transformActParam t pos down act FunctionCallIn_pl - transform t pos@(line, col) down@(options, place, indent) act@(Out _ _) = transformActParam t pos down act AddressNeed_pl - -instance Transformable1 DebugToC [] Expression where - transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l ", " 0 - -instance Transformable DebugToC Expression where - transform t (line, col) (options, place, indent) (VarExpr val inf) = Result (VarExpr (result newVal) newInf) (snd newInf) cRep - where - ((newVal, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - newVal <- monadicTransform' t (options, place, indent) val - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newVal, newInf) - - transform t (line, col) (options, place, indent) e@(ArrayElem name index inf1 inf2) = Result (ArrayElem (result newName) (result newIndex) newInf newInf) (snd newInf) cRep - where - ((newName, newIndex, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - let prefix = case (place, typeof e) of - (AddressNeed_pl, _) -> "&" - (_, ArrayType _ _) -> "&" -- TODO the call site should set the place to AddressNeed_pl for Arrays - _ -> "" - code $ prefix ++ "at(" ++ show_type options MainParameter_pl (typeof e) NoRestrict ++ "," - newName <- monadicTransform' t (options, AddressNeed_pl, indent) name - code "," - newIndex <- monadicTransform' t (options, ValueNeed_pl, indent) index - code ")" - (_, newLine, newCol) <- StateMonad.get - let newInf = ((line, col), (newLine, newCol)) - return (newName, newIndex, newInf) - - transform t pos@(line, col) down@(options, place, indent) expr@(StructField str field inf1 inf2) = transformExpr t pos down expr ("." ++ field) field ValueNeed_pl - - transform t (line, col) (options, place, indent) (ConstExpr val inf) = Result (ConstExpr (result newVal) newInf) (snd newInf) cRep - where - ((newVal, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - newVal <- monadicTransform' t (options, place, indent) val - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newVal, newInf) - - transform t pos@(line, col) down@(options, place, indent) - fc@(FunctionCall f [a,b] inf1 inf2) | funName f == "!" = - transformFuncCall t pos down fc "at(" "," ")" - - transform t pos@(line, col) down@(options, place, indent) - fc@(FunctionCall f [a,b] inf1 inf2) | funMode f == Infix = - transformFuncCall t pos down fc "(" (" " ++ funName f ++ " ") ")" - - transform t (line, col) (options, place, indent) - (FunctionCall f paramlist inf1 inf2) = - Result (FunctionCall f (result1 newParamlist) newInf newInf) (snd newInf) cRep - where - ((newParamlist, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - code $ funName f ++ "(" - newParamlist <- monadicListTransform' t (options, place, indent) paramlist - code ")" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newParamlist, newInf) - - transform t (line, col) (options, place, indent) (Cast typ exp inf1 inf2) = Result (Cast typ (result newExp) newInf newInf) (snd newInf) cRep - where - ((newExp, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - code $ concat ["(", toC options place typ, ")("] - newExp <- monadicTransform' t (options, place, indent) exp - code ")" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newExp, newInf) - - transform t (line, col) (options, place, indent) (SizeOf (Left typ) inf1 inf2) = Result (SizeOf (Left typ) newInf newInf) (snd newInf) cRep - where - ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - code ("sizeof(" ++ toC options place typ ++ ")") - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return newInf - - transform t (line, col) (options, place, indent) (SizeOf (Right exp) inf1 inf2) = Result (SizeOf (Right (result newExp)) newInf newInf) (newLine, newCol) cRep - where - ((newExp, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - code "sizeof" - newExp <- monadicTransform' t (options, place, indent) exp - code ")" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newExp, newInf) - -instance Transformable1 DebugToC [] Entity where - transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l "" 0 - -instance Transformable DebugToC Module where - transform t (line, col) (options, place, indent) (Module defList inf) = Result (Module (result1 newDefList) newInf) (snd newInf) cRep - where - ((newDefList, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - newDefList <- monadicListTransform' t (options, place, indent) defList - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newDefList, newInf) - -instance Transformable1 DebugToC [] Variable where - transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l ", " 0 - -instance Transformable1 DebugToC [] StructMember where - transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) "" - transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) (cRep) where - ((newX, newXs), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - indenter indent - newX <- monadicTransform' t (options, place, indent) x - newXs <- monadicListTransform' t (options, place, indent) xs - return (newX, newXs) - - -instance Transformable DebugToC Entity where - transform t (line, col) (options, place, indent) (StructDef name members inf1 inf2) = Result (StructDef name (result1 newMembers) newInf newInf) (snd newInf) cRep - where - ((newMembers, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - code $ name ++ " {\n" - (crep, cl, cc) <- StateMonad.get - StateMonad.put (crep, cl, cc + (addIndent indent)) - newMembers <- monadicListTransform' t (options, place, addIndent indent) members - indenter indent - code "};\n" - (crep, cl, _) <- StateMonad.get - StateMonad.put (crep, cl, indent) - let newInf = ((line, col), (cl, indent)) - return (newMembers, newInf) - - - transform t (line, col) (options, place, indent) (ProcDef name inParam outParam body inf1 inf2) = - Result (ProcDef name (result1 newInParam) (result1 newOutParam) (result newBody) newInf newInf) (snd newInf) cRep - where - ((newInParam, newOutParam, newBody, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - code $ memoryInformation options indent inf1 - indenter indent - -- code "#include \n" - code $ "void " ++ name ++ "(" - newInParam <- monadicListTransform' t (options, MainParameter_pl, indent) inParam - let str = case up1 newInParam of - "" -> "" - otherwise -> ", " - code str - newOutParam <- monadicListTransform' t (options, MainParameter_pl, indent) outParam - code $ ")\n" - indenter indent - -- code "{\nprintf(\"enter\\n\");\n" - -- code "printf(\"out:%p buffer:%p len:%d esize:%d\\n\", out, out->buffer, out->length, out->elemSize);\n" - code "{\n" - (crep, al, _) <- StateMonad.get - StateMonad.put (crep, al, addIndent indent) - newBody <- monadicTransform' t (options, Declaration_pl, addIndent indent) body - indenter indent - code "}\n" - -- code "printf(\"leave\\n\");\n}\n" - (_, nl, _) <- StateMonad.get - let newInf = ((line, col), (nl, indent)) - return (newInParam, newOutParam, newBody, newInf) - - transform t (line, col) (options, place, indent) (ProcDecl name inParam outParam inf1 inf2) = - Result (ProcDecl name (result1 newInParam) (result1 newOutParam) newInf newInf) (snd newInf) cRep - where - ((newInParam, newOutParam, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - code $ memoryInformation options indent inf1 - indenter indent - code $ "void " ++ name ++ "(" - newInParam <- monadicListTransform' t (options, MainParameter_pl, indent) inParam - let str = case up1 newInParam of - "" -> "" - otherwise -> ", " - code str - newOutParam <- monadicListTransform' t (options, MainParameter_pl, indent) outParam - code $ ");\n" - (_, nl, _) <- StateMonad.get - let newInf = ((line, col), (nl, indent)) - return (newInParam, newOutParam, newInf) - -memoryInformation :: Options -> Int -> AllocationInfo -> String -memoryInformation options indent inf1 - | (memoryInfoVisible options) = displayComment indent $ ["Memory information", "" ] ++ - (zipWith displayMemInfo ["Local", "Input", "Output"] [localMI, inputMI, outputMI]) ++ [ "" ] - | otherwise = "" - where (localMI, inputMI, outputMI) = inf1 - -displayComment :: Int -> [String] -> String -displayComment indent = unlines . map (putIndent indent ++) . (["/*"] ++) . (++ [" */"]) . map (" * " ++) - -displayMemInfo :: String -> [Type] -> String -displayMemInfo name [] = name ++ ": none" -displayMemInfo name info = name ++ ": " ++ (concat $ List.intersperse ", " $ map displayType info) - -displayType :: Type -> String -displayType (ArrayType (LiteralLen n) (ArrayType (LiteralLen m) t)) = - unwords [displayType t, concat ["array(", show n, "x", show m, ")"]] -displayType (ArrayType (LiteralLen n) t) = unwords [displayType t, concat ["array(", show n, ")"]] -displayType (ArrayType UndefinedLen t) = unwords [displayType t, "array"] -displayType VoidType = "void" -displayType BoolType = "Boolean" -displayType BitType = "bit" -displayType FloatType = "float" -displayType (NumType signed size) = unwords [sg signed, (sz size) ++ "-bit", "integer"] - where - sg Signed = "signed" - sg Unsigned = "unsigned" - sz S8 = "8" - sz S16 = "16" - sz S32 = "32" - sz S40 = "40" - sz S64 = "64" -displayType (ComplexType t) = unwords ["complex", displayType t] -displayType (UserType s) = s -displayType (StructType fields) = "struct" - -instance Transformable DebugToC StructMember where - transform t (line, col) (options, place, indent) dsm@(StructMember str typ inf) = Result (StructMember str typ newInf) (snd newInf) cRep - where - ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - let t = case structMemberType dsm of - ArrayType len innerType -> show_variable options place Value (structMemberType dsm) - (structMemberName dsm) ++ ";" - otherwise -> (toC options place $ structMemberType dsm) ++ " " ++ structMemberName dsm ++ ";" - code t - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return newInf - -instance Transformable1 DebugToC [] Declaration where - transform1 t (line, col) (options, place, indent) [] = Result1 [] (line, col) "" - transform1 t (line, col) (options, place, indent) (x:xs) = Result1 ((result newX):(result1 newXs)) (state1 newXs) ((putIndent indent ++ up newX ++ ";\n" ) ++ up1 newXs) where - newX = transform t (line, col) (options, place, indent) x - (line2, col2) = state newX - newSt = (line2 + 1, indent) - newXs = transform1 t newSt (options, place, indent) xs - -instance Transformable DebugToC Block where - transform t (line, col) (options, place, indent) (Block locs body inf) = Result (Block (result1 newLocs) (result newBody) newInf) (snd newInf) cRep - where - ((newLocs, newBody, newInf), (cRep, newLine, newcol)) = flip StateMonad.runState (defaultState line col) $ do - newLocs <- monadicListTransform' t (options, Declaration_pl, indent) locs - let str = case up1 newLocs of - "" -> "" - otherwise -> "\n" - code str - newBody <- monadicTransform' t (options, place, indent) body - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, indent)) - return (newLocs, newBody, newInf) - -instance Transformable DebugToC Declaration where - transform t (line, col) (options, place, indent) (Declaration declVar Nothing inf) = Result (Declaration (result newDeclVar) Nothing newInf) (snd newInf) cRep - where - ((newDeclVar, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - newDeclVar <- monadicTransform' t (options, Declaration_pl, indent) declVar - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newDeclVar, newInf) - - transform t (line, col) (options, place, indent) (Declaration declVar (Just expr) inf) = Result (Declaration (result newDeclVar) (Just (result newExpr)) newInf) (snd newInf) cRep - where - ((newDeclVar, newExpr, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - newDeclVar <- monadicTransform' t (options, Declaration_pl, indent) declVar - code " = " - newExpr <- monadicTransform' t (options, ValueNeed_pl, indent) expr - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newDeclVar, newExpr, newInf) - -instance Transformable1 DebugToC [] ActualParameter where - transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l ", " 0 - -instance Transformable1 DebugToC [] Program where - transform1 t pos@(line, col) down@(options, place, indent) l = transform1' t pos down l "" 0 - - -instance Transformable DebugToC Program where - transform t (line, col) (options, place, indent) (Empty inf1 inf2) = Result (Empty newInf newInf) newSt cRep where - newSt = (line, col) - newInf = ((line, col), newSt) - cRep = "" - - transform t (line, col) (options, place, indent) (Comment True comment inf1 inf2) = Result (Comment True comment newInf newInf) (snd newInf) cRep - where - ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - indenter indent - code $ "/* " ++ comment ++ " */\n" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newInf) - - transform t (line, col) (options, place, indent) (Comment False comment inf1 inf2) = Result (Comment False comment newInf newInf) (snd newInf) cRep - where - ((newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - indenter indent - code $ "// " ++ comment ++ "\n" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newInf) - - transform t (line, col) (options, place, indent) (Assign lhs rhs inf1 inf2) = Result (Assign (result newLhs) (result newRhs) newInf newInf) (snd newInf) cRep - where - ((newLhs, newRhs, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - indenter indent - newLhs <- monadicTransform' t (options, ValueNeed_pl, indent) lhs - code " = " - newRhs <- monadicTransform' t (options, ValueNeed_pl, indent) rhs - code ";\n" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, indent)) - return (newLhs, newRhs, newInf) - - transform t (line, col) (options, place, indent) (ProcedureCall name param inf1 inf2) = Result (ProcedureCall name (result1 newParam) newInf newInf) (snd newInf) cRep - where - ((newParam, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - indenter indent - code $ name ++ "(" - newParam <- monadicListTransform' t (options, place, indent) param - code ");\n" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, indent)) - return (newParam, newInf) - - transform t (line, col) (options, place, indent) (Sequence prog inf1 inf2) = Result (Sequence (result1 newProg) newInf newInf) (snd newInf) cRep - where - ((newProg, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - newProg <- monadicListTransform' t (options, place, indent) prog - let newInf = ((line, col), state1 newProg) - return (newProg, newInf) - - transform t (line, col) (options, place, indent) (Branch con tPrg ePrg inf1 inf2) = Result (Branch (result newCon) (result newTPrg) (result newEPrg) newInf newInf) (snd newInf) cRep - where - ((newCon, newTPrg, newEPrg, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - indenter indent - code "if(" - newCon <- monadicTransform' t (options, ValueNeed_pl, indent) con - code ")\n" - indenter indent - code "{\n" - newTPrg <- monadicTransform' t (options, place, addIndent indent) tPrg - indenter indent - code "}\n" - indenter indent - code "else\n" - indenter indent - code "{\n" - newEPrg <- monadicTransform' t (options, place, addIndent indent) ePrg - indenter indent - code "}\n" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newCon, newTPrg, newEPrg, newInf) - - transform t (line, col) (options, place, indent) (SeqLoop con conPrg blockPrg inf1 inf2) = Result (SeqLoop (result newCon) (result newConPrg) (result newBlockPrg) newInf newInf) (snd newInf) cRep - where - ((newCon, newConPrg, newBlockPrg, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - indenter indent - code "{\n" - newConPrg <- monadicTransform' t (options, place, addIndent indent) conPrg - indenter $ addIndent indent - code "while(" - newCon <- monadicTransform' t (options, ValueNeed_pl, addIndent indent) con - code $ ")\n" - indenter $ addIndent indent - code "{\n" - newBlockPrg <- monadicTransform' t (options, place, addIndent $ addIndent indent) blockPrg - monadicTransform' t (options, place, addIndent $ addIndent indent) (blockBody conPrg) - indenter $ addIndent indent - code "}\n" - indenter indent - code "}\n" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newCon, newConPrg, newBlockPrg, newInf) - - transform t (line, col) (options, place, indent) (ParLoop count bound step prog inf1 inf2) = Result (ParLoop (result newCount) (result newBound) step (result newProg) newInf newInf) (snd newInf) cRep - where - ((newCount, newBound, newProg, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - indenter indent - code "for(" - newCount <- monadicTransform' t (options, Declaration_pl, addIndent indent) count - code $ " = 0; " - loopVariable <- monadicTransform' t (options, ValueNeed_pl, addIndent indent) count - code $ " < " - newBound <- monadicTransform' t (options, ValueNeed_pl, addIndent indent) bound - code $ "; " ++ up loopVariable ++ " += " ++ show step ++ ")\n" - indenter indent - code "{\n" - -- code "printf(\"before\\n\");\n" - newProg <- monadicTransform' t (options, place, addIndent indent) prog - -- code "printf(\"after\\n\");\n" - indenter indent - code "}\n" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (loopVariable, newBound, newProg, newInf) - - transform t (line, col) (options, place, indent) (BlockProgram prog inf) = Result (BlockProgram (result newProg) newInf) (snd newInf) cRep - where - ((newProg, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - indenter indent - code "{\n" - newProg <- monadicTransform' t (options, place, addIndent indent) prog - indenter indent - code "}\n" - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (newLine, newCol)) - return (newProg, newInf) - -putIndent ind = concat $ replicate ind " " - -addIndent :: Int -> Int -addIndent indent = indent + 4 - -transform1' t (line, col) (options, place, indent) [] str num = Result1 [] (line, col) "" -transform1' t (line, col) (options, place, indent) (x:[]) str num = Result1 ((result newX):[]) (state newX) (up newX) where - newX = transform t (line, col) (options, place, indent) x -transform1' t (line, col) (options, place, indent) (x:xs) str num = Result1 ((result newX):(result1 newXs)) (state1 newXs) (up newX ++ str ++ up1 newXs) where - newX = transform t (line, col) (options, place, indent) x - (line2, col2) = state newX - newSt = (line2 + num, col2 + length str) - newXs = transform1 t newSt (options, place, indent) xs - -transformConst t (line, col) (options, place, indent) const str = Result (newConst const) (line, newCol) cRep - where - newConst (IntConst c t _ _) = (IntConst c t newInf newInf) - newConst (FloatConst c _ _) = (FloatConst c newInf newInf) - newConst (BoolConst c _ _) = (BoolConst c newInf newInf) - newInf = ((line, col), (line, newCol)) - (cRep, newLine, newCol) = snd $ flip StateMonad.runState (defaultState line col) $ do - let s = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of - Just (_,f) -> f const - Nothing -> str - code s - -transformActParam t (line, col) (options, place, indent) act paramType = Result (newActParam act) (snd newInf) cRep - where - newActParam (Out _ _) = (Out (result newParam) newInf) - newActParam _ = (In (result newParam) newInf) - getParam (In param _) = param - getParam (Out param _) = param - ((newParam, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - newParam <- monadicTransform' t (options, paramType, indent) (getParam act) - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newParam, newInf) - -transformFuncCall t (line, col) (options, place, indent) - (FunctionCall f [a, b] inf1 inf2) str1 str2 str3 = - Result (FunctionCall f [result newA, result newB] newInf newInf) (snd newInf) cRep - where - ((newA, newB, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - code str1 - newA <- monadicTransform' t (options, place, indent) a - code str2 - newB <- monadicTransform' t (options, place, indent) b - code str3 - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newA, newB, newInf) - -transformExpr t (line, col) (options, place, indent) expr str field paramType = Result (newExpr expr) (snd newInf) cRep - where - newExpr (StructField e s _ _ ) = (StructField (result newTarget) s newInf newInf) - getExpr (StructField e _ _ _ ) = e - ((newTarget, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do - newTarget <- monadicTransform' t (options, paramType, indent) (getExpr expr) - code str - (_, nl, nc) <- StateMonad.get - let newInf = ((line, col), (nl, nc)) - return (newTarget, newInf) - - -code s = do - (str, line, col) <- StateMonad.get - let numEOF = length (filter (=='\n') s) - StateMonad.put (str++s,line + numEOF, (if numEOF == 0 then col else 0) + (length $ takeWhile (/='\n') $ reverse s)) - -indenter n = do - (str, line, col) <- StateMonad.get - StateMonad.put (str ++ (concat $ replicate n " "), line, col) - -monadicTransform' t down@(options, place, indent) d = do - (cRep, line, col) <- StateMonad.get - let res = transform t (line, col) down d - code $ up res - return res - -complexTransform t down@(options, place, indent) d = do - (cRep, line, col) <- StateMonad.get - let res = transform t (line, col) down d - return res - -monadicListTransform' t down@(options, place, indent) l = do - (_, line, col) <- StateMonad.get - let resList = transform1 t (line, col) down l - code $ up1 resList - return resList - -defaultState :: Int -> Int -> (String, Int, Int) -defaultState line col = ("", line, col) diff --git a/Feldspar/Compiler/Backend/C/Plugin/Rule.hs b/Feldspar/Compiler/Backend/C/Plugin/Rule.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Plugin/Rule.hs +++ /dev/null @@ -1,89 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Backend.C.Plugin.Rule - ( RulePlugin(..) - ) where - -import Data.Maybe -import Data.Typeable - -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Transformation -import Feldspar.Compiler.Backend.C.Options -import Feldspar.Compiler.Error - -userError = handleError "Feldspar.Compiler.Backend.C.Plugin.Rule" InternalError - -data RulePlugin = RulePlugin - -instance Transformation RulePlugin - where - type From RulePlugin = () - type To RulePlugin = () - type Down RulePlugin = Options - type Up RulePlugin = [Rule] - type State RulePlugin = Int - -instance Plugin RulePlugin - where - type ExternalInfo RulePlugin = Options - executePlugin _ externalInfo = result . transform RulePlugin (0{-initial ID-}) externalInfo - -instance (DefaultTransformable RulePlugin t, Typeable1 t) => Transformable RulePlugin t where - transform t s d orig = recurse { result = x'', up = pr1 ++ pr2 ++ pr3, state = newID2 } - where - recurse = defaultTransform t s d orig - applyRule :: t () -> Int -> [Rule] -> (t (), [Rule], [Rule], Int) - applyRule c s rs = foldl applyRuleFun (c,[],[],s) rs - where - applyRuleFun :: (t (), [Rule], [Rule], Int) -> Rule -> (t (), [Rule], [Rule], Int) - applyRuleFun (cc,incomp,prop,currentID) (Rule r) = case cast r of - Just r' -> (cc',incomp,prop ++ prop', newID) - where - (cc',prop', newID) = applyAction cc currentID (r' cc) - applyAction :: t () -> Int -> [Action (t ())] -> (t (), [Rule], Int) - applyAction ccc currentID actions = foldl applyActionFun (ccc,[],currentID) actions - where - applyActionFun :: (t (), [Rule], Int) -> Action (t ()) -> (t (), [Rule], Int) - applyActionFun (_, prop'', currentID) (Replace newConstr) = (newConstr, prop'', currentID) - applyActionFun (ccc', prop'', currentID) (Propagate pr) = (ccc', prop'' ++ [pr], currentID) - applyActionFun (constr, ruleList, currentID) (WithId f) - = applyAction constr (currentID + 1) (f currentID) - applyActionFun (constr, ruleList, currentID) (WithOptions f) - = applyAction constr currentID (f d) - Nothing -> (cc,incomp ++ [Rule r],prop, currentID) - (x',_,pr1,newID1) = applyRule (result recurse) (state recurse) (rules d) - (x'',pr3,pr2,newID2) = applyRule x' newID1 (up recurse) - - -instance Combine [Rule] where - combine = (++) diff --git a/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs b/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs +++ /dev/null @@ -1,196 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE EmptyDataDecls, TypeFamilies #-} - -module Feldspar.Compiler.Backend.C.Plugin.TypeCorrector where - -import Data.List -import qualified Data.Map as Map -import Feldspar.Transformation -import Feldspar.Compiler.Backend.C.CodeGeneration -import Feldspar.Compiler.Backend.C.Options -import Feldspar.Compiler.Error - --- =========================================================================== --- == Type corrector plugin --- =========================================================================== --- TODO: IS THIS STILL NEEDED? - -typeCorrectorError = handleError "PluginArch/TypeCorrector" InternalError - -type TypeCatalog = Map.Map String Type - -instance Default TypeCatalog where - def = Map.empty - --- first collect types of global variables -data GlobalCollector = GlobalCollector -instance Transformation GlobalCollector where - type From GlobalCollector = () - type To GlobalCollector = () - type Down GlobalCollector = Bool -- variable is global - type Up GlobalCollector = () - type State GlobalCollector = TypeCatalog - - -instance Transformable GlobalCollector Entity where - transform t s d p = defaultTransform t s False p - -instance Transformable GlobalCollector Variable where - transform t s d v@(Variable name typ role ()) = Result v s' () where - s' - | d = Map.insert name typ s - | otherwise = s - -data TypeCheckDown = TypeCheckDown - { globals :: TypeCatalog - , inDeclaration :: Bool - } - -inDecl d b = d {inDeclaration = b} - -instance Default [String] where - def = [] -instance Combine [String] where - combine = (++) - --- get globals as state collect types of variables in a procedure, then corrert types -data TypeCheck = TypeCheck -instance Transformation TypeCheck where - type From TypeCheck = () - type To TypeCheck = () - type Down TypeCheck = TypeCheckDown -- globals variable's type, in a declaration - type Up TypeCheck = [String] -- errors - type State TypeCheck = TypeCatalog -- local variable's types - -instance Transformable TypeCheck Entity where - transform t s d p@(ProcDef _ _ _ _ _ _) = defaultTransform t s' d' p where - s' = def -- start with an empty local variable type catalog - d' = inDecl d True --input parameters are declarations (block will correct where it isn't good) - transform t s d p = Result p s def -- just definitions, not implementation, not need check/correct - -instance Transformable TypeCheck Block where - transform t s d b = tr - { result = (result tr) - { blockBody = mkSeq (err (up tr)) $ blockBody $ result tr - } - , state = s -- forget locals - , up = [] - } - where - tr = defaultTransform t s (inDecl d False) b -- we are'n in declaration (correct the procedure's change) - mkSeq (Empty _ _) x = x - mkSeq p (Sequence ps _ _) = Sequence (p:ps) () () - mkSeq p p2 = Sequence [p, p2] () () - err [] = Empty () () - err x = Comment True (listprint id "\n " $ uniq x) () () - uniq [] = [] - uniq (x:xs) = x:(uniq $ filter (/= x) xs) - -instance Transformable TypeCheck Declaration where - transform t s d (Declaration v i inf) = Result (Declaration (result tr1) (result1 tr2) $ convert inf) (state1 tr2) (combine (up tr1) (up1 tr2)) where - tr1 = transform t s (inDecl d True) v - tr2 = transform1 t (state tr1) d i - -instance Transformable TypeCheck Program where - transform t s d (ParLoop v b i p inf1 inf2) = Result (ParLoop (result tr1) (result tr2) i (result tr3) (convert inf1) $ convert inf2) s' (foldl combine (up tr1) [up tr2, up tr3]) where - tr1 = transform t s (inDecl d True) v -- loop variable is an undeclared local - tr2 = transform t (state tr1) d b - tr3 = transform t (state tr2) d p - s' = s -- forget loop variable (no other new var can be here, other news deleted at block) - transform t s d p = defaultTransform t s d p - -instance Transformable TypeCheck Variable where - transform t s d v@(Variable name typ role ()) - | inDeclaration d = Result v (Map.insert name typ s) def - | otherwise = Result v s u' where - u' = case Map.lookup name allVar of - Just typ2 - | typ == typ2 -> [] - | otherwise -> ["Inconsistent types: " ++ name ++ " (actual type: " ++show typ ++ ", declared type: " ++ show typ2 ++ ")"] - Nothing -> ["Undeclared variable: " ++ name] - allVar :: TypeCatalog - allVar = Map.unionWith (\global local -> local) (globals d) s - -data TypeCorrector = TypeCorrector -instance Transformation TypeCorrector where - type From TypeCorrector = () - type To TypeCorrector = () - type Down TypeCorrector = TypeCatalog -- global variable's type, in a declaration - type Up TypeCorrector = () - type State TypeCorrector = TypeCatalog -- local variable's types - -instance Transformable TypeCorrector Entity where - transform t s d p@(ProcDef n i o _ _ _) = defaultTransform t (state tr) d p where - tr = defaultTransform t def d p -- start with an empty local variable type catalog - transform t s d p = Result p s def -- just definitions, not implementation, not need check/correct - -instance Transformable TypeCorrector Variable where - transform t locals globals v@(Variable name typ role ()) = Result v' (Map.insert name typ' locals) def where - v' = v {varType = typ'} - typ' = case Map.lookup name allVar of - Just typ2 - | typ == typ2 -> typ2 - | otherwise -> select typ typ2 - Nothing -> typ - allVar = Map.unionWith (\global local -> local) globals locals - -select act decl - | ok = typ - | otherwise = decl - where - (ok,typ) = select' act decl - select' (ComplexType t1) (ComplexType t2) = (o, ComplexType t) where - (o,t) = select' t1 t2 - select' (ArrayType l1 t1) (ArrayType l2 t2) = (o && o2, ArrayType l t) where - (o,t) = select' t1 t2 - (o2,l) = select'' l1 l2 - select'' UndefinedLen x = (True, x) - select'' x UndefinedLen = (True, x) - select'' (LiteralLen a) (LiteralLen b) = (a==b, (LiteralLen b)) - select' (StructType t1) (StructType t2) = (o, StructType t) where - (o,t) = select'' t1 t2 - select'' [] [] = (True, []) - select'' [] _ = (False, undefined) - select'' _ [] = (False, undefined) - select'' ((a,st1):ts1) ((b,st2):ts2) = ( a==b && oo && ooo, (a,tt):tts) where - (oo,tt) = select' st1 st2 - (ooo,tts) = select'' ts1 ts2 - select' t1 t2 - | t1 == t2 = (True, t1) - | otherwise = (False, undefined) - -instance Plugin TypeCorrector where - type ExternalInfo TypeCorrector = Bool - executePlugin TypeCorrector showErr procedure = - result $ transform TypeCorrector def globals x where - globals = {- Map.insert defaultArraySizeConstantName (NumType Unsigned S32) $ -} state $ transform GlobalCollector def False procedure - x - | showErr = result $ transform TypeCheck def (TypeCheckDown globals False) procedure - | otherwise = procedure diff --git a/Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs b/Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs +++ /dev/null @@ -1,87 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE EmptyDataDecls, TypeFamilies #-} - -module Feldspar.Compiler.Backend.C.Plugin.TypeDefinitionGenerator where - -import Data.List -import Feldspar.Transformation -import Feldspar.Compiler.Backend.C.CodeGeneration -import Feldspar.Compiler.Backend.C.Options -import Feldspar.Compiler.Error - -import Debug.Trace - --- =========================================================================== --- == Type definition generator plugin --- =========================================================================== - -typeDefGenError = handleError "PluginArch/TypeDefinitionGenerator" - -data TypeDefinitionGenerator = TypeDefinitionGenerator - -getTypes :: Options -> Type -> [Entity ()] -getTypes options typ = {-trace ("DEBUG: "show typ) $-} case typ of - StructType members -> concatMap (getTypes options . snd) members - ++ [StructDef { - structName = toC options Declaration_pl (StructType members), - structMembers = map (\(name,typ) -> StructMember name typ ()) members, - structLabel = (), - definitionLabel = () - }] - ArrayType len baseType -> getTypes options baseType - _ -> [] - -- XXX complexType? - -instance Transformation TypeDefinitionGenerator where - type From TypeDefinitionGenerator = () - type To TypeDefinitionGenerator = () - type Down TypeDefinitionGenerator = Options - type Up TypeDefinitionGenerator = () - type State TypeDefinitionGenerator = [Entity ()] - -instance Transformable TypeDefinitionGenerator Module where - transform selfpointer origState fromAbove origModule = defaultTransformationResult { - result = (result defaultTransformationResult) { - entities = (nub $ state defaultTransformationResult) - ++ (entities $ result defaultTransformationResult) - } - } where - defaultTransformationResult = defaultTransform selfpointer origState fromAbove origModule - -instance Transformable TypeDefinitionGenerator Variable where - transform selfpointer origState fromAbove origVariable = defaultTransformationResult { - state = state defaultTransformationResult ++ getTypes fromAbove (varType origVariable) - } where - defaultTransformationResult = defaultTransform selfpointer origState fromAbove origVariable - -instance Plugin TypeDefinitionGenerator where - type ExternalInfo TypeDefinitionGenerator = Options - executePlugin TypeDefinitionGenerator externalInfo procedure = result - $ transform TypeDefinitionGenerator [{-state-}] externalInfo procedure diff --git a/Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs b/Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs deleted file mode 100644 --- a/Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs +++ /dev/null @@ -1,74 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Feldspar.Compiler.Backend.C.Plugin.VariableRoleAssigner where - -import Data.List -import Feldspar.Transformation - -data VariableRoleAssigner = VariableRoleAssigner - -data Parameters = Parameters - { inParametersVRA :: [String] - , outParametersVRA :: [String] - } - -instance Transformation VariableRoleAssigner where - type From VariableRoleAssigner = () - type To VariableRoleAssigner = () - type Down VariableRoleAssigner = Parameters - type Up VariableRoleAssigner = () - type State VariableRoleAssigner = () - -instance Transformable VariableRoleAssigner Variable where - transform t s d v = Result v' () () where - v' = v { varRole = if (varName v `elem` outParametersVRA d) || - (isComposite v && (varName v `elem` "mem" : inParametersVRA d)) - then Pointer else Value - , varLabel = () - } - -instance Transformable VariableRoleAssigner Entity where - transform t s d p@(ProcDef n i o pr inf1 inf2) = defaultTransform t s d' p where - d' = Parameters - { inParametersVRA = map varName i - , outParametersVRA = map varName o - } - transform t s d p = defaultTransform t s d p - -instance Plugin VariableRoleAssigner where - type ExternalInfo VariableRoleAssigner = () - executePlugin self@VariableRoleAssigner externalInfo procedure = - result $ transform self ({-state-}) (Parameters [] []) procedure - -isComposite :: Variable () -> Bool -isComposite v = case varType v of - (ArrayType _ _) -> True - (StructType _) -> True - otherwise -> False - diff --git a/Feldspar/Compiler/Compiler.hs b/Feldspar/Compiler/Compiler.hs deleted file mode 100644 --- a/Feldspar/Compiler/Compiler.hs +++ /dev/null @@ -1,259 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Feldspar.Compiler.Compiler where - -import System.IO -import System.FilePath -import Data.Typeable as DT -import Control.Arrow -import Control.Applicative - -import Feldspar.Core.Types -import Feldspar.Transformation -import qualified Feldspar.NameExtractor as NameExtractor -import Feldspar.Compiler.Backend.C.Options -import Feldspar.Compiler.Backend.C.Platforms -import Feldspar.Compiler.Backend.C.Library -import Feldspar.Compiler.Imperative.Plugin.Naming -import Feldspar.Compiler.Backend.C.Plugin.Rule -import Feldspar.Compiler.Imperative.Plugin.Unroll -import Feldspar.Compiler.Backend.C.Plugin.TypeDefinitionGenerator -import Feldspar.Compiler.Backend.C.Plugin.VariableRoleAssigner -import Feldspar.Compiler.Imperative.Plugin.ConstantFolding -import Feldspar.Compiler.Backend.C.Plugin.BlockProgramHandler -import Feldspar.Compiler.Backend.C.Plugin.TypeCorrector -import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint -import Feldspar.Compiler.Backend.C.Plugin.Locator -import Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator -import Feldspar.Compiler.Backend.C.CodeGeneration -import Feldspar.Compiler.Imperative.FromCore - -data SomeCompilable = forall a internal . Compilable a internal => SomeCompilable a - deriving (DT.Typeable) - --- ================================================================================================ --- == Compiler core --- ================================================================================================ - -type Position = (Int, Int) - -data SplitModuleDescriptor = SplitModuleDescriptor { - smdSource :: Module AllocationEliminatorSemanticInfo, - smdHeader :: Module AllocationEliminatorSemanticInfo -} - -data CompToCCoreResult = CompToCCoreResult { - sourceCode :: String, - endPosition :: Position, - debugModule :: Module DebugToCSemanticInfo, - allocationInfo :: AllocationInfo -} - -data SplitCompToCCoreResult = SplitCompToCCoreResult { - sctccrSource :: CompToCCoreResult, - sctccrHeader :: CompToCCoreResult -} - -data IncludesNeeded = IncludesNeeded | NoIncludesNeeded { incneedLineNum :: Int } - -moduleSplitter :: Module AllocationEliminatorSemanticInfo -> SplitModuleDescriptor -moduleSplitter m = SplitModuleDescriptor { - smdHeader = Module ((filter belongsToHeader $ entities m) ++ (createProcDecls $ entities m)) (moduleLabel m), - smdSource = Module (filter (not . belongsToHeader) $ entities m) (moduleLabel m) -} where - belongsToHeader :: Entity AllocationEliminatorSemanticInfo -> Bool - belongsToHeader (StructDef _ _ _ _) = True - belongsToHeader (ProcDecl _ _ _ _ _) = True - belongsToHeader _ = False - createProcDecls :: [Entity AllocationEliminatorSemanticInfo] -> [Entity AllocationEliminatorSemanticInfo] - createProcDecls [] = [] - createProcDecls (e:es) = convertProcDefToProcDecl e ++ createProcDecls es - convertProcDefToProcDecl :: Entity AllocationEliminatorSemanticInfo -> [Entity AllocationEliminatorSemanticInfo] - convertProcDefToProcDecl e = case e of - ProcDef name inparams outparams body label1 label2 -> [ProcDecl name inparams outparams label1 label2] - anythingelse -> [] - -mergeAllocationInfos :: [AllocationInfo] -> AllocationInfo -mergeAllocationInfos = foldr plus ([],[],[]) - -(x1,y1,z1) `plus` (x2,y2,z2) = (x1 ++ x2, y1 ++ y2, z1 ++ z2) - -separateAndCompileToCCore :: (Compilable t internal) - => (Module AllocationEliminatorSemanticInfo - -> [Module AllocationEliminatorSemanticInfo]) - -> CompilationMode -> t -> IncludesNeeded - -> NameExtractor.OriginalFunctionSignature -> Options - -> [(CompToCCoreResult, Module AllocationEliminatorSemanticInfo)] -separateAndCompileToCCore - moduleSeparator - compilationMode prg needed - functionSignature coreOptions = - pack <$> separatedModules - where - pack = compToCWithInfo &&& id - - separatedModules = - moduleSeparator $ - executePluginChain' compilationMode prg functionSignature coreOptions - - compToCWithInfo = moduleToCCore needed coreOptions - -moduleToCCore - :: IncludesNeeded -> Options -> Module AllocationEliminatorSemanticInfo - -> CompToCCoreResult -moduleToCCore needed opts mdl = - CompToCCoreResult { - sourceCode = includes ++ moduleSrc - , endPosition = endPos - , debugModule = dbgModule - , allocationInfo = extractAllocations mdl - } - where - (includes, lineNum) = genInclude needed - - (dbgModule, (moduleSrc, endPos)) = - compToCWithInfos ((opts,Declaration_pl), lineNum) mdl - - genInclude IncludesNeeded = genIncludeLines opts Nothing - genInclude (NoIncludesNeeded ln) = ("", ln) - - extractAllocations = - entities >>> - filter isProcedure >>> - (procDefLabel <$>) >>> - mergeAllocationInfos - where - isProcedure (ProcDef _ _ _ _ _ _) = True - isProcedure _ = False - --- =========================================================== --- ___ ... --- === ::: [ COMPILER CORE ] ::: === --- ... ___ --- =========================================================== --- This functionality should not be duplicated. Instead, everything should call this and only do a trivial interface adaptation. -compileToCCore - :: (Compilable t internal) => CompilationMode -> t -> Maybe String -> IncludesNeeded - -> NameExtractor.OriginalFunctionSignature -> Options - -> SplitCompToCCoreResult -compileToCCore compilationMode prg outputFileName includesNeeded - originalFunctionSignature coreOptions = - createSplit $ fst <$> separateAndCompileToCCore headerAndSource - compilationMode prg includesNeeded originalFunctionSignature coreOptions - where - headerAndSource modules = [header, source] - where (SplitModuleDescriptor header source) = moduleSplitter modules - - createSplit [header, source] = SplitCompToCCoreResult header source - -genIncludeLinesCore :: [String] -> (String, Int) -genIncludeLinesCore [] = ("", 1) -genIncludeLinesCore (x:xs) = ("#include " ++ x ++ "\n" ++ str, linenum + 1) where - (str, linenum) = genIncludeLinesCore xs - -genIncludeLines :: Options -> Maybe String -> (String, Int) -genIncludeLines coreOptions mainHeader = (str ++ "\n\n", linenum + 2) where - (str, linenum) = genIncludeLinesCore $ (includes $ platform coreOptions) ++ mainHeaderCore - mainHeaderCore = case mainHeader of - Nothing -> [] - Just filename -> ["\"" ++ takeFileName filename ++ ".h\""] - ------------------------- --- Predefined options -- ------------------------- - -defaultOptions - = Options - { platform = c99 - , unroll = NoUnroll - , debug = NoDebug - , memoryInfoVisible = True - , rules = [] - } - -c99PlatformOptions = defaultOptions -tic64xPlatformOptions = defaultOptions { platform = tic64x } -unrollOptions = defaultOptions { unroll = Unroll 8 } -noPrimitiveInstructionHandling = defaultOptions { debug = NoPrimitiveInstructionHandling } -noMemoryInformation = defaultOptions { memoryInfoVisible = False } - --- =========================================================================== --- == Plugin system --- =========================================================================== - -pluginChain :: ExternalInfoCollection -> Module () -> Module AllocationEliminatorSemanticInfo -pluginChain externalInfo - = (executePlugin AllocationEliminator ()) - . (executePlugin RulePlugin (ruleExternalInfo externalInfo)) - . (executePlugin TypeDefinitionGenerator (typeDefinitionGeneratorExternalInfo externalInfo)) - . (executePlugin ConstantFolding ()) - . (executePlugin UnrollPlugin (unrollExternalInfo externalInfo)) - . (executePlugin Precompilation (precompilationExternalInfo externalInfo)) - . (executePlugin RulePlugin (primitivesExternalInfo externalInfo)) - . (executePlugin VariableRoleAssigner (variableRoleAssignerExternalInfo externalInfo)) - . (executePlugin TypeCorrector (typeCorrectorExternalInfo externalInfo)) - . (executePlugin BlockProgramHandler ()) - -data ExternalInfoCollection = ExternalInfoCollection { - precompilationExternalInfo :: ExternalInfo Precompilation - , unrollExternalInfo :: ExternalInfo UnrollPlugin - , primitivesExternalInfo :: ExternalInfo RulePlugin - , ruleExternalInfo :: ExternalInfo RulePlugin - , typeDefinitionGeneratorExternalInfo :: ExternalInfo TypeDefinitionGenerator - , variableRoleAssignerExternalInfo :: ExternalInfo VariableRoleAssigner - , typeCorrectorExternalInfo :: ExternalInfo TypeCorrector -} - -executePluginChain' :: (Compilable c internal) - => CompilationMode -> c -> NameExtractor.OriginalFunctionSignature - -> Options -> Module AllocationEliminatorSemanticInfo -executePluginChain' compilationMode prg originalFunctionSignatureParam opt = - pluginChain ExternalInfoCollection { - precompilationExternalInfo = PrecompilationExternalInfo { - originalFunctionSignature = fixedOriginalFunctionSignature - , inputParametersDescriptor = buildInParamDescriptor prg - , numberOfFunctionArguments = numArgs prg - , compilationMode = compilationMode - } - , unrollExternalInfo = unroll opt - , primitivesExternalInfo = opt{ rules = platformRules $ platform opt } - , ruleExternalInfo = opt - , typeDefinitionGeneratorExternalInfo = opt - , variableRoleAssignerExternalInfo = () - , typeCorrectorExternalInfo = False - } $ fromCore "PLACEHOLDER" prg - where - ofn = NameExtractor.originalFunctionName - errorPEI = - (error "There is no defaultArraySize any more", debug opt, platform opt) - fixedOriginalFunctionSignature = originalFunctionSignatureParam { - NameExtractor.originalFunctionName = - fixFunctionName $ ofn originalFunctionSignatureParam - } - -executePluginChain cm f sig opts = - moduleSplitter $ executePluginChain' cm f sig opts diff --git a/Feldspar/Compiler/Error.hs b/Feldspar/Compiler/Error.hs deleted file mode 100644 --- a/Feldspar/Compiler/Error.hs +++ /dev/null @@ -1,35 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Feldspar.Compiler.Error where - -data ErrorClass = InvariantViolation | InternalError | Warning - deriving (Show, Eq) - -handleError :: String -> ErrorClass -> String -> a -handleError place errorClass message = error $ "[" ++ show errorClass ++ " @ " ++ place ++ "]: " ++ message diff --git a/Feldspar/Compiler/Frontend/CommandLine/API.hs b/Feldspar/Compiler/Frontend/CommandLine/API.hs deleted file mode 100644 --- a/Feldspar/Compiler/Frontend/CommandLine/API.hs +++ /dev/null @@ -1,151 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE CPP #-} -module Feldspar.Compiler.Frontend.CommandLine.API where - -import qualified Feldspar.NameExtractor as NameExtractor -import Feldspar.Compiler.Backend.C.Options -import Feldspar.Compiler.Compiler -import Feldspar.Compiler.Imperative.FromCore -import Feldspar.Compiler.Frontend.CommandLine.API.Library -import Feldspar.Compiler.Backend.C.Library -import Language.Haskell.Interpreter -import qualified Data.Typeable as T -import Control.Monad - --- ====================================== System imports ================================== -import System.Directory -import System.FilePath -import System.IO -import System.Exit -import System.Environment -import System.Console.GetOpt - -data CompilationResult - = CompilationSuccess - | CompilationFailure - deriving (Eq, Show, T.Typeable) - -#ifdef RELEASE -releaseMode = True -#else -releaseMode = False -#endif - - -- A general interpreter body for interpreting an expression -generalInterpreterBody :: forall a . (T.Typeable (IO a)) - => String -- the expression to interpret - -> Interpreter (IO a) -generalInterpreterBody expression = interpret expression (as::IO a) - --- A high-level interface for calling the interpreter -highLevelInterpreter :: T.Typeable (IO a) - => String -- the module name (for example My.Module) - -> String -- the input file name (for example "My/Module.hs") - -> [String] -- globalImportList - -> Bool -- need to import global modules qualified? - -> Interpreter (IO a) -- ^ an interpreter body - -> IO CompilationResult -highLevelInterpreter moduleName inputFileName importList needQualify interpreterBody = do - actionToExecute <- runInterpreter $ do - set [ languageExtensions := [GADTs, ScopedTypeVariables, TypeSynonymInstances, StandaloneDeriving, - DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, - FunctionalDependencies, ExistentialQuantification, Rank2Types, TypeOperators, - EmptyDataDecls, GeneralizedNewtypeDeriving, TypeFamilies, - UnknownExtension "ImplicitPrelude"] - ] - -- in relesae mode, globalImportList modules are package modules and shouldn't be loaded, only imported - -- in normal mode, we need to load them before importing them - loadModules $ [inputFileName] ++ if not releaseMode then importList else [] - setTopLevelModules [moduleName] - -- Import modules qualified to prevent name collisions with user defined entities - if needQualify - then setImportsQ $ zip importList $ map Just importList - else setImports importList - interpreterBody - case actionToExecute of - Left err -> do - printInterpreterError err - return CompilationFailure - Right action -> do - action - return CompilationSuccess - -- either printInterpreterError id actionToExecute - -printInterpreterError :: InterpreterError -> IO () -printInterpreterError (WontCompile []) = return () -printInterpreterError (WontCompile (x:xs)) = do - printGhcError x - printInterpreterError (WontCompile xs) - where - printGhcError (GhcError {errMsg=s}) = hPutStrLn stderr s -printInterpreterError e = hPutStrLn stderr $ "Code generation failed: " ++ show e - -handleOptions :: [OptDescr (a -> IO a)] -> a -> String -> IO (a, String) -handleOptions descriptors startOptions helpHeader = do - args <- getArgs - - when (length args == 0) (do - putStrLn $ usageInfo helpHeader descriptors - exitWith ExitSuccess) - - -- Parse options, getting a list of option actions - let (actions, nonOptions, errors) = getOpt Permute descriptors args - - when (length errors > 0) (do - putStrLn $ concat errors - putStrLn $ usageInfo helpHeader descriptors - exitWith (ExitFailure 1)) - - -- Here we thread startOptions through all supplied option actions - opts <- foldl (>>=) (return startOptions) actions - - when (length nonOptions /= 1) (do - putStrLn "ERROR: Exactly one input file expected." - exitWith (ExitFailure 1)) - - let inputFileName = replace (head nonOptions) "\\" "/" -- change it for multi-file operation - - return (opts, inputFileName) - -removeFileIfPossible :: String -> IO () -removeFileIfPossible filename = removeFile filename `Prelude.catch` (const $ return()) - -prepareInputFile :: String -> IO () -prepareInputFile inputFileName = do - removeFileIfPossible $ replaceExtension inputFileName ".hi" - removeFileIfPossible $ replaceExtension inputFileName ".o" - -standaloneCompile :: (Compilable t internal) => - t -> FilePath -> FilePath -> NameExtractor.OriginalFunctionSignature -> Options -> IO () -standaloneCompile prg inputFileName outputFileName originalFunctionSignature opts = do - appendFile (makeCFileName outputFileName) $ sourceCode $ sctccrSource compilationResult - appendFile (makeHFileName outputFileName) $ sourceCode $ sctccrHeader compilationResult - where - compilationResult = compileToCCore Standalone prg (Just outputFileName) IncludesNeeded originalFunctionSignature opts diff --git a/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs b/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs deleted file mode 100644 --- a/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs +++ /dev/null @@ -1,36 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Feldspar.Compiler.Frontend.CommandLine.API.Constants where - -globalImportList = ["Feldspar.Compiler.Compiler"] - -warningPrefix = "[WARNING]: " -errorPrefix = "[ERROR ]: " - - diff --git a/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs b/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs deleted file mode 100644 --- a/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs +++ /dev/null @@ -1,72 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Feldspar.Compiler.Frontend.CommandLine.API.Library where - -import qualified Feldspar.Compiler.Backend.C.Options as CoreOptions -import Feldspar.Compiler.Backend.C.Platforms - -import Data.Char -import Language.Haskell.Interpreter -import System.Console.ANSI -import Feldspar.Compiler.Backend.C.Library - -lowerFirst :: String -> String -lowerFirst (first:rest) = (toLower first : rest) - -upperFirst :: String -> String -upperFirst (first:rest) = (toUpper first : rest) - -formatStringListCore :: [String] -> String -formatStringListCore [] = "" -formatStringListCore [x] = x -formatStringListCore (x:xs) = x ++ " | " ++ (formatStringListCore xs) - -formatStringList :: [String] -> String -formatStringList list | length list > 0 = "(" ++ (formatStringListCore list) ++ ")" -formatStringList _ = error "This list should not be empty." - -rpad :: Int -> String -> String -rpad target s = rpadWith target ' ' s - -rpadWith :: Int -> Char -> String -> String -rpadWith target padchar s - | length s >= target = s - | otherwise = rpadWith target padchar (s ++ [padchar]) - -iPutStrLn :: String -> Interpreter () -iPutStrLn = liftIO . putStrLn - -iPutStr :: String -> Interpreter () -iPutStr = liftIO . putStr - -fancyWrite :: String -> IO () -fancyWrite s = do - withColor Blue $ putStr "=== [ " - withColor Cyan $ putStr $ rpad 70 s - withColor Blue $ putStrLn " ] ===" diff --git a/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs b/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs deleted file mode 100644 --- a/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs +++ /dev/null @@ -1,135 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Feldspar.Compiler.Frontend.CommandLine.API.Options where - -import qualified Feldspar.Compiler.Backend.C.Options as CompilerCoreOptions -import qualified Feldspar.Compiler.Compiler as CompilerCore -import qualified Feldspar.Compiler.Frontend.CommandLine.API.Library as StandaloneLib -import Feldspar.Compiler.Frontend.CommandLine.API.Constants -import Feldspar.Compiler.Backend.C.Platforms - -import Data.List -import Data.Char - -import System.Console.GetOpt -import System.Exit -import System.Environment -import System.IO -import System.Process -import System.Info -import System.Directory - -availablePlatformsStrRep = StandaloneLib.formatStringList $ - map (StandaloneLib.upperFirst . CompilerCoreOptions.name) availablePlatforms - -data StandaloneMode = SingleFunction String | MultiFunction - -data Options = Options { optStandaloneMode :: StandaloneMode - , optOutputFileName :: Maybe String - , optCompilerMode :: CompilerCoreOptions.Options - } - --- | Default options -startOptions :: Options -startOptions = Options { optStandaloneMode = MultiFunction - , optOutputFileName = Nothing - , optCompilerMode = CompilerCore.defaultOptions - } - -helpHeader = "Standalone Feldspar Compiler\nUsage: feldspar [options] inputfile\n" ++ - "Notes: \n" ++ - " * When no output file name is specified, the input file's name with .c extension is used\n" ++ - " * The inputfile parameter is always needed, even in single-function mode\n" ++ - "\nAvailable options: \n" - --- | Option descriptions for getOpt -optionDescriptors :: [ OptDescr (Options -> IO Options) ] -optionDescriptors = - [ Option "f" ["singlefunction"] - (ReqArg - (\arg opt -> return opt { optStandaloneMode = SingleFunction arg }) - "FUNCTION") - "Enables single-function compilation" - , Option "o" ["output"] - (ReqArg - (\arg opt -> return opt { optOutputFileName = Just arg }) - "outputfile") - "Overrides the file names for the generated output code" - - , Option "p" ["platform"] - (ReqArg - (\arg opt -> return opt { optCompilerMode = (optCompilerMode opt) - { CompilerCoreOptions.platform = decodePlatform arg } }) - "") - ("Overrides the target platform " ++ availablePlatformsStrRep) - , Option "u" ["unroll"] - (ReqArg - (\arg opt -> return opt { - optCompilerMode = (optCompilerMode opt) { - CompilerCoreOptions.unroll = CompilerCoreOptions.Unroll (parseInt arg "Invalid unroll count") - } - }) - "") - "Enables loop unrolling" - , Option "D" ["debuglevel"] - (ReqArg - (\arg opt -> return opt { optCompilerMode = (optCompilerMode opt) - { CompilerCoreOptions.debug = decodeDebug arg } }) - "") - "Specifies debug level (currently the only possible option is NoPrimitiveInstructionHandling)" - , Option "h" ["help"] - (NoArg - (\_ -> do - --prg <- getProgName - hPutStrLn stderr (usageInfo helpHeader optionDescriptors) - exitWith ExitSuccess)) - "Show this help message" - ] - --- ============================================================================== --- == Option Decoders --- ============================================================================== - -findPlatformByName :: String -> Maybe CompilerCoreOptions.Platform -findPlatformByName platformName = -- Finds a platform by name using case-insensitive comparison - find (\platform -> (map toLower platformName) == (map toLower $ CompilerCoreOptions.name platform)) - availablePlatforms - -decodePlatform :: String -> CompilerCoreOptions.Platform -decodePlatform s = case (findPlatformByName s) of - Just platform -> platform - Nothing -> error $ "Invalid platform specified. Valid platforms are: " ++ availablePlatformsStrRep - -decodeDebug "NoPrimitiveInstructionHandling" = CompilerCoreOptions.NoPrimitiveInstructionHandling -decodeDebug _ = error "Invalid debug level specified" - -parseInt :: String -> String -> Int -parseInt arg message = case reads arg of - [(x, "")] -> x - _ -> error message diff --git a/Feldspar/Compiler/Frontend/CommandLine/Main.hs b/Feldspar/Compiler/Frontend/CommandLine/Main.hs deleted file mode 100644 --- a/Feldspar/Compiler/Frontend/CommandLine/Main.hs +++ /dev/null @@ -1,220 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Main where --- ====================================== Feldspar imports ================================== -import Feldspar.NameExtractor -import Feldspar.Compiler.Compiler -import qualified Feldspar.Compiler.Compiler as CompilerCore -import Feldspar.Compiler.Backend.C.Options -import qualified Feldspar.Compiler.Backend.C.Options as CoreOptions -import Feldspar.Compiler.Frontend.CommandLine.API.Options as StandaloneOptions -import Feldspar.Compiler.Frontend.CommandLine.API.Constants -import Feldspar.Compiler.Frontend.CommandLine.API.Library as StandaloneLib -import Feldspar.Compiler.Backend.C.Library -import Feldspar.Compiler.Frontend.CommandLine.API -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Backend.C.CodeGeneration -import Feldspar.Compiler.Error -import Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator -import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint --- ====================================== System imports ================================== -import System.IO -import System.Exit -import System.Info -import System.Process -import System.IO.Error -import System.FilePath -import System.Directory -import System.Environment -import System.Console.GetOpt --- ====================================== Control imports ================================== -import Control.Monad -import Control.Exception -import Control.Monad.Error -import Control.Monad.CatchIO --- ====================================== Other imports ================================== -import Data.List -import Debug.Trace -import Language.Haskell.Interpreter - - -data CompilationError = - InterpreterError InterpreterError - | InternalErrorCall String - -compileFunction :: String -> String -> CoreOptions.Options -> OriginalFunctionSignature - -> Interpreter (String, Either SplitModuleDescriptor CompilationError) -compileFunction inFileName outFileName coreOptions originalFunctionSignature = do - let functionName = originalFunctionName originalFunctionSignature - (SomeCompilable prg) <- interpret ("SomeCompilable " ++ functionName) (as::SomeCompilable) - let splitModuleDescriptor = executePluginChain Standalone prg originalFunctionSignature coreOptions - -- XXX force evaluation in order to be able to catch the exceptions - -- liftIO $ evaluate $ compToC coreOptions compilationUnit -- XXX somehow not enough(?!) -- counter-example: structexamples - result <- liftIO $ do - tempdir <- System.IO.Error.catch (getTemporaryDirectory) (\_ -> return ".") - (tempfile, temph) <- openTempFile tempdir "feldspar-temp.txt" - let core = compileToCCore Standalone prg (Just outFileName) IncludesNeeded originalFunctionSignature coreOptions - Control.Exception.finally (do hPutStrLn temph $ sourceCode $ sctccrSource core - hPutStrLn temph $ sourceCode $ sctccrHeader core) - (do hClose temph - removeFileIfPossible tempfile) - return $ (functionName, Left splitModuleDescriptor) - return result - -compileAllFunctions :: String -> String -> CoreOptions.Options -> [OriginalFunctionSignature] - -> Interpreter [(String, Either SplitModuleDescriptor CompilationError)] -compileAllFunctions inFileName outFileName options [] = return [] -compileAllFunctions inFileName outFileName options (x:xs) = do - let functionName = originalFunctionName x - resultCurrent <- (catchError (compileFunction inFileName outFileName options x) - (\(e::InterpreterError) -> return $ (functionName, Right $ InterpreterError e))) - `Control.Monad.CatchIO.catch` - (\msg -> return $ (functionName, - Right $ InternalErrorCall $ errorPrefix ++ show (msg::Control.Exception.ErrorCall))) - resultRest <- compileAllFunctions inFileName outFileName options xs - return $ resultCurrent : resultRest - --- | Interpreter body for single-function compilation -singleFunctionCompilationBody :: String -> String -> CoreOptions.Options -> OriginalFunctionSignature - -> Interpreter (IO ()) -singleFunctionCompilationBody inFileName outFileName coreOptions originalFunctionSignature = do - liftIO $ fancyWrite $ "Compiling function " ++ (originalFunctionName originalFunctionSignature) ++ "..." - (SomeCompilable prg) <- - interpret ("SomeCompilable " ++ originalFunctionName originalFunctionSignature) (as::SomeCompilable) - liftIO $ standaloneCompile prg inFileName outFileName originalFunctionSignature coreOptions - return $ return () - -mergeModules :: [Module AllocationEliminatorSemanticInfo] -> Module AllocationEliminatorSemanticInfo -mergeModules [] = handleError "Standalone" InvariantViolation "Called mergeModules with an empty list" -mergeModules [x] = x -mergeModules l@(x:xs) = Module { - entities = nub $ entities x ++ (entities $ mergeModules xs), -- nub is in fact a "global plugin" here - moduleLabel = () -} - -padFunctionName :: String -> String -padFunctionName n = StandaloneLib.rpadWith 50 '.' $ "Function " ++ n - -writeErrors :: (String, Either a CompilationError) -> IO () -writeErrors (functionName, Left x) = return () -writeErrors (functionName, Right err) = case err of - InterpreterError ie -> do - withColor Red $ putStrLn $ "Error in function " ++ functionName ++ ":" - printInterpreterError ie - InternalErrorCall ec -> do - withColor Red $ putStrLn $ "Error in function " ++ functionName ++ ":" - withColor Red $ putStrLn ec - -writeSummary :: (String, Either a CompilationError) -> IO () -writeSummary (functionName, Left x) = do - withColor Cyan $ putStr $ padFunctionName functionName - withColor Green $ putStrLn "[OK]" -writeSummary (functionName, Right msg) = do - withColor Cyan $ putStr $ padFunctionName functionName - withColor Red $ putStrLn "[FAILED]" - -filterLefts :: [(String, Either a b)] -> [a] -filterLefts [] = [] -filterLefts [(_,Left x)] = [x] -filterLefts [(_,Right _)] = [] -filterLefts ((_,Left x):xs) = x : filterLefts xs -filterLefts ((_,Right _):xs) = filterLefts xs - --- | Interpreter body for multi-function compilation -multiFunctionCompilationBody :: String -> String -> CoreOptions.Options -> [OriginalFunctionSignature] -> Interpreter (IO ()) -multiFunctionCompilationBody inFileName outFileName coreOptions declarationList = do - let (hIncludes, hLineNum) = genIncludeLines coreOptions Nothing - let (cIncludes, cLineNum) = genIncludeLines coreOptions (Just outFileName) - liftIO $ appendFile (makeHFileName outFileName) $ hIncludes - liftIO $ appendFile (makeCFileName outFileName) $ cIncludes - modules <- compileAllFunctions inFileName outFileName coreOptions declarationList - liftIO $ do - mapM writeErrors modules - withColor Blue $ putStrLn "\n================= [ Summary of compilation results ] =================\n" - mapM writeSummary modules - let mergedCModules = mergeModules $ map smdSource $ filterLefts modules - let mergedHModules = mergeModules $ map smdHeader $ filterLefts modules - let cCompToCResult = compToCWithInfos ((coreOptions, Declaration_pl), cLineNum) mergedCModules - let hCompToCResult = compToCWithInfos ((coreOptions, Declaration_pl), hLineNum) mergedHModules - (appendFile (makeCFileName outFileName) $ fst $ snd cCompToCResult) `Control.Exception.catch` errorHandler - (appendFile (makeHFileName outFileName) $ fst $ snd hCompToCResult) `Control.Exception.catch` errorHandler - (writeFile (makeDebugCFileName outFileName) $ show $ fst cCompToCResult) `Control.Exception.catch` errorHandler - (writeFile (makeDebugHFileName outFileName) $ show $ fst hCompToCResult) `Control.Exception.catch` errorHandler - return $ return () - where - errorHandler = (\msg -> withColor Red $ putStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)) - --- | Calculates the output file name. -convertOutputFileName :: String -> Maybe String -> String -convertOutputFileName inputFileName maybeOutputFileName = case maybeOutputFileName of - Nothing -> takeFileName $ dropExtension inputFileName -- remove takeFileName to return the full path - Just overriddenFileName -> overriddenFileName - -makeBackup :: String -> IO () -makeBackup filename = renameFile filename (filename ++ ".bak") `Prelude.catch` (const $ return()) - -main = do - (opts, inputFileName) <- handleOptions optionDescriptors startOptions helpHeader - let outputFileName = convertOutputFileName inputFileName (optOutputFileName opts) - - prepareInputFile inputFileName - makeBackup $ makeHFileName outputFileName - makeBackup $ makeCFileName outputFileName - makeBackup $ makeDebugHFileName outputFileName - makeBackup $ makeDebugCFileName outputFileName - - fileDescriptor <- openFile inputFileName ReadMode - fileContents <- hGetContents fileDescriptor - - let declarationList = getExtendedDeclarationList inputFileName fileContents - let moduleName = getModuleName inputFileName fileContents - fancyWrite $ "Compilation target: module " ++ moduleName - fancyWrite $ "Output file: " ++ outputFileName - - let highLevelInterpreterWithModuleInfo body = - highLevelInterpreter moduleName inputFileName globalImportList False body - - -- C code generation - case optStandaloneMode opts of - MultiFunction - | length declarationList == 0 -> putStrLn "No functions to compile." - | otherwise -> do - fancyWrite $ "Number of functions to compile: " ++ (show $ length declarationList) - highLevelInterpreterWithModuleInfo - (multiFunctionCompilationBody inputFileName outputFileName (optCompilerMode opts) declarationList) - return () - SingleFunction funName -> do - let originalFunctionSignatureNeeded = - case filter ((==funName).originalFunctionName) declarationList of - [a] -> a - [] -> error $ "Function " ++ funName ++ " not found" - _ -> error "Unexpected error SC/01" - highLevelInterpreterWithModuleInfo - (singleFunctionCompilationBody inputFileName outputFileName (optCompilerMode opts) originalFunctionSignatureNeeded) - return () diff --git a/Feldspar/Compiler/Frontend/Interactive/Interface.hs b/Feldspar/Compiler/Frontend/Interactive/Interface.hs deleted file mode 100644 --- a/Feldspar/Compiler/Frontend/Interactive/Interface.hs +++ /dev/null @@ -1,94 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Feldspar.Compiler.Frontend.Interactive.Interface where - -import Feldspar.Compiler.Compiler -import Feldspar.Compiler.Imperative.FromCore -import Feldspar.Compiler.Backend.C.Options -import qualified Feldspar.NameExtractor as NameExtractor -import Feldspar.Compiler.Backend.C.Library -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint -import Feldspar.Compiler.Backend.C.Plugin.Locator - --- ================================================================================================ --- == Interactive compilation --- ================================================================================================ - -data PrgType = ForType | AssignType | IfType - -forPrg = ForType -ifPrg = IfType -assignPrg = AssignType - -getProgram :: (Int, Int) -> PrgType -> Module DebugToCSemanticInfo -> IO () -getProgram (line, col) prgtype prg = res where - res = case find of - True -> putStrLn $ myShow code - _ -> putStrLn "Not found appropriate code part!" - (find, code) = case prgtype of - ForType -> getPrgParLoop (line, col) prg - AssignType -> getPrgAssign (line, col) prg - IfType -> getPrgBranch (line, col) prg - - -compile :: (Compilable t internal) => t -> FilePath -> String -> Options -> IO () -compile prg fileName functionName opts = do - writeFile (makeCFileName fileName) $ sourceCode $ sctccrSource compilationResult - writeFile (makeHFileName fileName) $ sourceCode $ sctccrHeader compilationResult - where - compilationResult = compileToCCore Interactive prg (Just fileName) IncludesNeeded - (NameExtractor.OriginalFunctionSignature functionName []) opts - -icompile :: (Compilable t internal) => t -> IO () -icompile prg = icompile' prg "test" defaultOptions - -icompile' :: (Compilable t internal) => t -> String -> Options -> IO () -icompile' prg functionName opts = do - putStrLn "=============== Header ================" - putStrLn $ sourceCode $ sctccrHeader compilationResult - putStrLn "=============== Source ================" - putStrLn $ sourceCode $ sctccrSource compilationResult - where - compilationResult = compileToCCore Interactive prg Nothing IncludesNeeded - (NameExtractor.OriginalFunctionSignature functionName []) opts - -info :: (Compilable t internal) => t -> IO () -info = flip info' defaultOptions - -info' :: (Compilable t internal) => t -> Options -> IO () -info' prg opts = print $ mergeAllocationInfos $ [ allocationInfo $ sctccrSource compilationResult - , allocationInfo $ sctccrHeader compilationResult ] - where - compilationResult = compileToCCore Interactive prg Nothing IncludesNeeded - (NameExtractor.OriginalFunctionSignature "test" []) opts - -icompileWithInfos :: (Compilable t internal) => t -> String -> Options -> SplitCompToCCoreResult -icompileWithInfos prg functionName opts = compileToCCore Interactive prg Nothing IncludesNeeded - (NameExtractor.OriginalFunctionSignature functionName []) opts diff --git a/Feldspar/Compiler/Imperative/FromCore.hs b/Feldspar/Compiler/Imperative/FromCore.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore.hs +++ /dev/null @@ -1,109 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore where - - - -import Control.Monad.RWS - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding -import Language.Syntactic.Sharing.SimpleCodeMotion - -import Feldspar.Core.Types -import Feldspar.Core.Interpretation -import Feldspar.Core.Constructs -import Feldspar.Core.Frontend - -import Feldspar.Compiler.Imperative.Representation (Module) -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation -import Feldspar.Compiler.Imperative.FromCore.Array -import Feldspar.Compiler.Imperative.FromCore.Binding -import Feldspar.Compiler.Imperative.FromCore.Condition -import Feldspar.Compiler.Imperative.FromCore.ConditionM -import Feldspar.Compiler.Imperative.FromCore.Error -import Feldspar.Compiler.Imperative.FromCore.FFI -import Feldspar.Compiler.Imperative.FromCore.Literal -import Feldspar.Compiler.Imperative.FromCore.Loop -import Feldspar.Compiler.Imperative.FromCore.Mutable -import Feldspar.Compiler.Imperative.FromCore.Par -import Feldspar.Compiler.Imperative.FromCore.MutableToPure -import Feldspar.Compiler.Imperative.FromCore.Primitive -import Feldspar.Compiler.Imperative.FromCore.Save -import Feldspar.Compiler.Imperative.FromCore.SizeProp -import Feldspar.Compiler.Imperative.FromCore.SourceInfo -import Feldspar.Compiler.Imperative.FromCore.Tuple - - - -instance Compile FeldDomain (Lambda TypeCtx :+: (Variable TypeCtx :+: FeldDomain)) - where - compileProgSym (FeldDomain a) = compileProgSym a - compileExprSym (FeldDomain a) = compileExprSym a - -compileProgTop :: (Compile dom dom, Lambda TypeCtx :<: dom) => - String -> [Var] -> ASTF (Decor Info dom) a -> Mod -compileProgTop name args (lam :$ body) - | Just (info, Lambda v) <- prjDecorCtx typeCtx lam - = let ta = argType $ infoType info - sa = defaultSize ta - var = mkVariable (compileTypeRep ta sa) v - in compileProgTop name (var:args) body -compileProgTop name args a = Mod defs - where - ins = reverse args - info = getInfo a - outType = compileTypeRep (infoType info) (infoSize info) - outParam = Pointer outType "out" - outLoc = Ptr outType "out" - results = snd $ evalRWS (compileProg outLoc a) initReader initState - body = Seq $ block $ results - defs = def results ++ [ProcDf name ins [outParam] body] - -class Syntactic a FeldDomainAll => Compilable a internal | a -> internal -instance Syntactic a FeldDomainAll => Compilable a () - -- TODO This class should be replaced by (Syntactic a FeldDomainAll) (or a - -- similar alias) everywhere. The second parameter is not needed. - -fromCore :: Syntactic a FeldDomainAll => String -> a -> Module () -fromCore name - = fromInterface - . compileProgTop name [] - . reifyFeld N32 - -buildInParamDescriptor :: Syntactic a FeldDomainAll => a -> [Int] -buildInParamDescriptor _ = [] - -- TODO - -numArgs :: Syntactic a FeldDomainAll => a -> Int -numArgs = length . buildInParamDescriptor - diff --git a/Feldspar/Compiler/Imperative/FromCore/Array.hs b/Feldspar/Compiler/Imperative/FromCore/Array.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Array.hs +++ /dev/null @@ -1,124 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Array where - - - -import Control.Monad.RWS - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding - -import Feldspar.Core.Types -import Feldspar.Core.Interpretation -import Feldspar.Core.Constructs.Array -import Feldspar.Core.Constructs.Literal - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - -instance ( Compile dom dom - , Lambda TypeCtx :<: dom - , Literal TypeCtx :<: dom - , Variable TypeCtx :<: dom - ) - => Compile Array dom - where - compileProgSym Parallel _ loc (len :* (lam :$ ixf) :* Nil) - | Just (info, Lambda v) <- prjDecorCtx typeCtx lam - = do - let ta = argType $ infoType info - let sa = defaultSize ta - let ix@(Var _ name) = mkVar (compileTypeRep ta sa) v - len' <- mkLength len - (e, body) <- confiscateProg $ compileProg (loc :!: ix) ixf - tellProg [For name len' 1 $ Seq body] - tellProg [setLength loc len'] - - compileProgSym Sequential _ loc (len :* st :* (lam1 :$ (lam2 :$ step)) :* Nil) - | Just (info1, Lambda v) <- prjDecorCtx typeCtx lam1 - , Just (info2, Lambda s) <- prjDecorCtx typeCtx lam2 - = do - let t = argType $ infoType info1 - let sz = defaultSize t - let ta' = argType $ infoType info2 - let sa' = defaultSize ta' - let tr' = resType $ infoType info2 - let sr' = defaultSize tr' - let ix@(Var _ name) = mkVar (compileTypeRep t sz) v - let stv = mkVar (compileTypeRep ta' sa') s - len' <- mkLength len - tmp <- freshVar "seq" tr' sr' - initSt <- compileExpr st - (e, body) <- confiscateProg $ compileProg tmp step - tellProg [Block [ini stv initSt, def tmp] $ - For name len' 1 $ - Seq (body ++ - [loc :!: ix := (tmp :.: "member1") - ,stv := (tmp :.: "member2") - ])] - tellProg [setLength loc len'] - where def (Var ty str) = Def ty str - ini (Var ty str) e = Init ty str e - - compileProgSym Append _ loc (a :* b :* Nil) = do - a' <- compileExpr a - b' <- compileExpr b - let offset = Fun U32 "getLength" [a'] - tellProg [copyProg loc a'] - tellProg [copyProgPos loc offset b'] - - compileProgSym SetIx info loc (arr :* i :* a :* Nil) = do - compileProg loc arr - i' <- compileExpr i - compileProg (loc :!: i') a - - compileProgSym SetLength _ loc (len :* arr :* Nil) = do - len' <- compileExpr len - tellProg [setLength loc len'] - compileProg loc arr - -- TODO Optimize by using copyProgLen (compare to 0.4) - - compileProgSym a info loc args = compileExprLoc a info loc args - - compileExprSym GetLength info (a :* Nil) = do - aExpr <- compileExpr a - return $ Fun (compileTypeRep (infoType info) (infoSize info)) "getLength" [aExpr] - - compileExprSym GetIx info (arr :* i :* Nil) = do - a' <- compileExpr arr - i' <- compileExpr i - return $ a' :!: i' - - compileExprSym a info args = compileProgFresh a info args - diff --git a/Feldspar/Compiler/Imperative/FromCore/Binding.hs b/Feldspar/Compiler/Imperative/FromCore/Binding.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Binding.hs +++ /dev/null @@ -1,78 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Binding where - -import Control.Monad.RWS - -import Language.Syntactic - -import Feldspar.Core.Types -import Feldspar.Core.Interpretation -import Feldspar.Core.Constructs.Binding -import qualified Feldspar.Core.Constructs.Binding as Core - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - -instance Compile (Core.Variable TypeCtx) dom - where - compileExprSym (Core.Variable v) info Nil = do - env <- ask - case lookup v (alias env) of - Nothing -> return $ Var (compileTypeRep (infoType info) (infoSize info)) ("v" ++ show v) - Just e -> return e - -instance Compile (Lambda TypeCtx) dom - where - compileProgSym = error "Can only compile top-level Lambda" - -instance (Compile dom dom, Lambda TypeCtx :<: dom) => Compile (Let TypeCtx TypeCtx) dom - where - compileProgSym Let _ loc (a :* (lam :$ body) :* Nil) - | Just (info, Lambda v) <- prjDecorCtx typeCtx lam - = do - let ta = argType $ infoType info - let sa = defaultSize ta - let var = mkVar (compileTypeRep ta sa) v - compileProg var a - withDecl var $ compileProg loc body - - compileExprSym Let _ (a :* (lam :$ body) :* Nil) - | Just (info, Lambda v) <- prjDecorCtx typeCtx lam - = do - let ta = argType $ infoType info - let sa = defaultSize ta - let var = mkVar (compileTypeRep ta sa) v - compileProg var a - withDecl var $ compileExpr body - diff --git a/Feldspar/Compiler/Imperative/FromCore/Condition.hs b/Feldspar/Compiler/Imperative/FromCore/Condition.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Condition.hs +++ /dev/null @@ -1,54 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Condition where - - - -import Control.Monad.RWS - -import Language.Syntactic - -import Feldspar.Core.Types -import Feldspar.Core.Constructs.Condition - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - -instance Compile dom dom => Compile (Condition TypeCtx) dom - where - compileProgSym Condition _ loc (cond :* tHEN :* eLSE :* Nil) = do - condExpr <- compileExpr cond - (_,thenProg) <- confiscateProg $ compileProg loc tHEN - (_,elseProg) <- confiscateProg $ compileProg loc eLSE - tellProg [If condExpr (Seq thenProg) (Seq elseProg)] - diff --git a/Feldspar/Compiler/Imperative/FromCore/ConditionM.hs b/Feldspar/Compiler/Imperative/FromCore/ConditionM.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/ConditionM.hs +++ /dev/null @@ -1,53 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.ConditionM where - - - -import Control.Monad.RWS - -import Language.Syntactic - -import Feldspar.Core.Types -import Feldspar.Core.Constructs.ConditionM - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - -instance Compile dom dom => Compile (ConditionM m) dom - where - compileProgSym ConditionM _ loc (cond :* tHEN :* eLSE :* Nil) = do - condExpr <- compileExpr cond - (_,thenProg) <- confiscateProg $ compileProg loc tHEN - (_,elseProg) <- confiscateProg $ compileProg loc eLSE - tellProg [If condExpr (Seq thenProg) (Seq elseProg)] diff --git a/Feldspar/Compiler/Imperative/FromCore/Error.hs b/Feldspar/Compiler/Imperative/FromCore/Error.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Error.hs +++ /dev/null @@ -1,61 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Error where - - - -import Control.Monad.RWS - -import Language.Syntactic - -import Feldspar.Core.Constructs.Error - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - -instance (Compile dom dom) => Compile Error dom - where - compileProgSym Undefined _ loc Nil = return () - compileProgSym (Assert msg) _ loc (cond :* a :* Nil) = do - condExpr <- compileExpr cond - tellProg [Call "assert" [In condExpr]] - when (length msg > 0) $ tellProg [Comment $ "{" ++ msg ++ "}"] - compileProg loc a - - compileExprSym (Assert msg) _ (cond :* a :* Nil) = do - condExpr <- compileExpr cond - tellProg [Call "assert" [In condExpr]] - when (length msg > 0) $ tellProg [Comment $ "{" ++ msg ++ "}"] - compileExpr a - compileExprSym a info args = compileProgFresh a info args - diff --git a/Feldspar/Compiler/Imperative/FromCore/FFI.hs b/Feldspar/Compiler/Imperative/FromCore/FFI.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/FFI.hs +++ /dev/null @@ -1,46 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.FFI where - -import Language.Syntactic - -import Feldspar.Core.Interpretation -import Feldspar.Core.Constructs.FFI - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - -instance (Compile dom dom) => Compile FFI dom - where - compileExprSym (ForeignImport name _) info args = do - argExprs <- sequence $ listArgs compileExpr args - return $ Fun (compileTypeRep (infoType info) (infoSize info)) name argExprs - diff --git a/Feldspar/Compiler/Imperative/FromCore/Interpretation.hs b/Feldspar/Compiler/Imperative/FromCore/Interpretation.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Interpretation.hs +++ /dev/null @@ -1,325 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Interpretation where - - -import Control.Arrow -import Control.Monad.RWS - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding (VarId) - -import Feldspar.Range -import Feldspar.Core.Types hiding (Type) -import Feldspar.Core.Interpretation -import qualified Feldspar.Core.Constructs.Binding as Core -import qualified Feldspar.Core.Constructs.Literal as Core - -import Feldspar.Compiler.Imperative.Frontend - - - --- | Code generation monad -type CodeWriter = RWS Readers Writers States - -data Readers = Readers { alias :: [(VarId, Expr)] -- ^ variable aliasing - , sourceInfo :: SourceInfo -- ^ Surrounding source info - } - -initReader = Readers [] "" - -data Writers = Writers { -- | collects code within one block - block :: [Prog] - - -- | collects top level definitions - , def :: [Ent] - } - -instance Monoid Writers - where - mempty = Writers { block = mempty - , def = mempty - } - mappend a b = Writers { block = mappend (block a) (block b) - , def = mappend (def a) (def b) - } - -type Task = [Prog] - -data States = States { -- | the first fresh variable - fresh :: Integer - , tasks :: [Task] -- ^ suspended programs - } - -initState = States 0 [] - --- | Where to place the program result -type Location = Expr - --- | A minimal complete instance has to define either 'compileProgSym' or --- 'compileExprSym'. -class Compile sub dom - where - compileProgSym - :: sub a - -> Info (DenResult a) - -> Location - -> Args (AST (Decor Info dom)) a - -> CodeWriter () - compileProgSym = compileExprLoc - - compileExprSym - :: sub a - -> Info (DenResult a) - -> Args (AST (Decor Info dom)) a - -> CodeWriter Expr - compileExprSym = compileProgFresh - -instance (Compile sub1 dom, Compile sub2 dom) => - Compile (sub1 :+: sub2) dom - where - compileProgSym (InjL a) = compileProgSym a - compileProgSym (InjR a) = compileProgSym a - - compileExprSym (InjL a) = compileExprSym a - compileExprSym (InjR a) = compileExprSym a - - - --- | Implementation of 'compileExprSym' that assigns an expression to the given --- location. -compileExprLoc :: Compile sub dom - => sub a - -> Info (DenResult a) - -> Location - -> Args (AST (Decor Info dom)) a - -> CodeWriter () -compileExprLoc a info loc args = do - expr <- compileExprSym a info args - assign loc expr - --- | Implementation of 'compileProgSym' that generates code into a fresh --- variable. -compileProgFresh :: Compile sub dom - => sub a - -> Info (DenResult a) - -> Args (AST (Decor Info dom)) a - -> CodeWriter Expr -compileProgFresh a info args = do - loc <- freshVar "e" (infoType info) (infoSize info) - withDecl loc $ compileProgSym a info loc args - return loc - -compileProgDecor :: Compile dom dom - => Location - -> Decor Info dom a - -> Args (AST (Decor Info dom)) a - -> CodeWriter () -compileProgDecor result (Decor info a) args = do - let src = infoSource info - aboveSrc <- asks sourceInfo - unless (null src || src==aboveSrc) $ tellProg [BComment src] - local (\env -> env {sourceInfo = src}) $ compileProgSym a info result args - -compileExprDecor :: Compile dom dom - => Decor Info dom a - -> Args (AST (Decor Info dom)) a - -> CodeWriter Expr -compileExprDecor (Decor info a) args = do - let src = infoSource info - aboveSrc <- asks sourceInfo - unless (null src || src==aboveSrc) $ tellProg [BComment src] - local (\env -> env {sourceInfo = src}) $ compileExprSym a info args - -compileProg :: Compile dom dom => - Location -> ASTF (Decor Info dom) a -> CodeWriter () -compileProg result = queryNodeSimple (compileProgDecor result) - -compileExpr :: Compile dom dom => ASTF (Decor Info dom) a -> CodeWriter Expr -compileExpr = queryNodeSimple compileExprDecor - - - --------------------------------------------------------------------------------- --- * Utility functions --------------------------------------------------------------------------------- - -compileNumType :: Signedness a -> BitWidth n -> Type -compileNumType U N8 = U8 -compileNumType S N8 = I8 -compileNumType U N16 = U16 -compileNumType S N16 = I16 -compileNumType U N32 = U32 -compileNumType S N32 = I32 -compileNumType U N64 = U64 -compileNumType S N64 = I64 -compileNumType U NNative = U32 -- TODO -compileNumType S NNative = I32 -- TODO - -compileTypeRep :: TypeRep a -> Size a -> Type -compileTypeRep UnitType _ = Void -compileTypeRep BoolType _ = Boolean -compileTypeRep (IntType s n) _ = compileNumType s n -compileTypeRep FloatType _ = Floating -compileTypeRep (ComplexType t) _ = Complex (compileTypeRep t (defaultSize t)) -compileTypeRep (Tup2Type a b) (sa,sb) = Struct - [ ("member1", compileTypeRep a sa) - , ("member2", compileTypeRep b sb) - ] -compileTypeRep (Tup3Type a b c) (sa,sb,sc) = Struct - [ ("member1", compileTypeRep a sa) - , ("member2", compileTypeRep b sb) - , ("member3", compileTypeRep c sc) - ] -compileTypeRep (Tup4Type a b c d) (sa,sb,sc,sd) = Struct - [ ("member1", compileTypeRep a sa) - , ("member2", compileTypeRep b sb) - , ("member3", compileTypeRep c sc) - , ("member4", compileTypeRep d sd) - ] -compileTypeRep (Tup5Type a b c d e) (sa,sb,sc,sd,se) = Struct - [ ("member1", compileTypeRep a sa) - , ("member2", compileTypeRep b sb) - , ("member3", compileTypeRep c sc) - , ("member4", compileTypeRep d sd) - , ("member5", compileTypeRep e se) - ] -compileTypeRep (Tup6Type a b c d e f) (sa,sb,sc,sd,se,sf) = Struct - [ ("member1", compileTypeRep a sa) - , ("member2", compileTypeRep b sb) - , ("member3", compileTypeRep c sc) - , ("member4", compileTypeRep d sd) - , ("member5", compileTypeRep e se) - , ("member6", compileTypeRep f sf) - ] -compileTypeRep (Tup7Type a b c d e f g) (sa,sb,sc,sd,se,sf,sg) = Struct - [ ("member1", compileTypeRep a sa) - , ("member2", compileTypeRep b sb) - , ("member3", compileTypeRep c sc) - , ("member4", compileTypeRep d sd) - , ("member5", compileTypeRep e se) - , ("member6", compileTypeRep f sf) - , ("member7", compileTypeRep g sg) - ] -compileTypeRep (MutType a) _ = compileTypeRep a (defaultSize a) -compileTypeRep (RefType a) _ = compileTypeRep a (defaultSize a) -compileTypeRep (ArrayType a) (rs :> es) = if unboundedLength - then Array $ compileTypeRep a es - else SizedArray (fromEnum $ upperBound rs) $ compileTypeRep a es - where - unboundedLength - = upperBound rs > fromIntegral (maxBound :: Int) - -- This ensures that `fromEnum` succeeds - || upperBound rs == maxBound - -- This `maxBound` might be smaller than `maxBound :: Int` -compileTypeRep (MArrType a) _ = Array (compileTypeRep a (defaultSize a)) -compileTypeRep (ParType a) _ = compileTypeRep a (defaultSize a) -compileTypeRep (IVarType a) _ = compileTypeRep a (defaultSize a) -compileTypeRep (FunType _ b) sz = compileTypeRep b sz -compileTypeRep typ _ = error $ "compileTypeRep: missing " ++ show typ -- TODO - -mkVar :: Type -> VarId -> Expr -mkVar t = Var t . ("v" ++) . show - -mkVariable :: Type -> VarId -> Var -mkVariable t = Variable t . ("v" ++) . show - -freshVar :: String -> TypeRep a -> Size a -> CodeWriter Expr -- TODO take just info instead of TypeRep and Size? -freshVar base t size = do - s <- get - let v = fresh s - put $ s {fresh = (v + 1)} - return $ Var (compileTypeRep t size) (base ++ show v) - -tellProg :: [Prog] -> CodeWriter () -tellProg ps = tell $ mempty {block = ps} - -addTask :: Task -> CodeWriter () -addTask t = do - s <- get - let ts = tasks s - put $ s {tasks = ts ++ [t]} - return () - -assign :: Location -> Expr -> CodeWriter () -assign lhs rhs = tellProg [copyProg lhs rhs] - -suspendProg :: CodeWriter a -> CodeWriter a -suspendProg m = do - (a, ps) <- censor (\rec -> rec {block = []}) $ listen m - addTask $ block ps - return a - -releaseProgs :: CodeWriter () -releaseProgs = do - s <- get - let ts = tasks s - mapM_ tellProg $ reverse ts - put $ s {tasks = []} - --- | Like 'listen', but also prevents the program from being written in the --- monad. -confiscateProg :: CodeWriter a -> CodeWriter (a, [Prog]) -confiscateProg m - = liftM (id *** block) - $ censor (\rec -> rec {block = []}) - $ listen m - -withDecl :: Location -> CodeWriter a -> CodeWriter a -withDecl (Var Void _) ma = ma -- don't declace void variables -withDecl (Var t name) ma = do - (e,prog) <- confiscateProg ma - tellProg [Block [Def t name] (Seq prog)] - return e - -- TODO Could probably use only censor - -withDeclInit :: Location -> Expr -> CodeWriter a -> CodeWriter a -withDeclInit (Var t name) init ma = do - (e,prog) <- confiscateProg ma - tellProg [Block [Init t name init] (Seq prog)] - return e - -- TODO Needed? - -withAlias :: VarId -> Expr -> CodeWriter a -> CodeWriter a -withAlias v0 expr action = do - local (\e -> e {alias = (v0,expr) : alias e}) $ action - -isVariableOrLiteral (prjDecorCtx typeCtx -> Just (_, Core.Literal l)) = True -isVariableOrLiteral (prjDecorCtx typeCtx -> Just (_, Core.Variable v)) = True -isVariableOrLiteral _ = False - -mkLength a | isVariableOrLiteral a = compileExpr a - | otherwise = do - let lentyp = IntType U N32 - lenvar <- freshVar "len" lentyp (defaultSize lentyp) - withDecl lenvar $ compileProg lenvar a - return lenvar - diff --git a/Feldspar/Compiler/Imperative/FromCore/Literal.hs b/Feldspar/Compiler/Imperative/FromCore/Literal.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Literal.hs +++ /dev/null @@ -1,138 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Literal where - - - -import Control.Monad.RWS -import Data.Complex -import GHC.Float (float2Double) - -import Language.Syntactic - -import Feldspar.Core.Types -import Feldspar.Core.Interpretation -import Feldspar.Core.Constructs.Literal - -import Feldspar.Range (upperBound) - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - -instance Compile (Literal TypeCtx) dom - where - compileExprSym (Literal a) info Nil = literal (infoType info) (infoSize info) a - - compileProgSym (Literal a) info loc Nil = literalLoc loc (infoType info) (infoSize info) a - -literal :: TypeRep a -> Size a -> a -> CodeWriter Expr -literal UnitType _ () = return $ LitI I32 0 -literal BoolType _ a = return $ boolToExpr a -literal trep@(IntType _ _) sz a = return $ LitI (compileTypeRep trep sz) (toInteger a) -literal FloatType _ a = return $ LitF $ float2Double a -literal (ComplexType t) sz (r:+i) = do re <- literal t (defaultSize t) r - ie <- literal t (defaultSize t) i - return $ LitC re ie -literal t s a = do loc <- freshVar "x" t s - withDecl loc $ literalLoc loc t s a - return loc - -literalLoc :: Location -> TypeRep a -> Size a -> a -> CodeWriter () -literalLoc loc ty@(ArrayType t) (rs :> es) e - = do - tellProg [setLength loc $ LitI I32 $ toInteger $ upperBound rs] - zipWithM_ (writeElement loc t es) (map (LitI I32) [0..]) e - where writeElement :: Expr -> TypeRep a -> Size a -> Expr -> a -> CodeWriter () - writeElement loc ty sz ix e = do expr <- literal ty sz e - tellProg [loc :!: ix := expr] -literalLoc loc t@(Tup2Type ta tb) (sa,sb) (a,b) = - do aExpr <- literal ta sa a - bExpr <- literal tb sb b - tellProg [loc :.: "member1" := aExpr - ,loc :.: "member2" := bExpr] -literalLoc loc t@(Tup3Type ta tb tc) (sa,sb,sc) (a,b,c) = - do aExpr <- literal ta sa a - bExpr <- literal tb sb b - cExpr <- literal tc sc c - tellProg [loc :.: "member1" := aExpr - ,loc :.: "member2" := bExpr - ,loc :.: "member3" := cExpr] -literalLoc loc t@(Tup4Type ta tb tc td) (sa,sb,sc,sd) (a,b,c,d) = - do aExpr <- literal ta sa a - bExpr <- literal tb sb b - cExpr <- literal tc sc c - dExpr <- literal td sd d - tellProg [loc :.: "member1" := aExpr - ,loc :.: "member2" := bExpr - ,loc :.: "member3" := cExpr - ,loc :.: "member4" := dExpr] -literalLoc loc t@(Tup5Type ta tb tc td te) (sa,sb,sc,sd,se) (a,b,c,d,e) = - do aExpr <- literal ta sa a - bExpr <- literal tb sb b - cExpr <- literal tc sc c - dExpr <- literal td sd d - eExpr <- literal te se e - tellProg [loc :.: "member1" := aExpr - ,loc :.: "member2" := bExpr - ,loc :.: "member3" := cExpr - ,loc :.: "member4" := dExpr - ,loc :.: "member5" := eExpr] -literalLoc loc t@(Tup6Type ta tb tc td te tf) (sa,sb,sc,sd,se,sf) (a,b,c,d,e,f) = - do aExpr <- literal ta sa a - bExpr <- literal tb sb b - cExpr <- literal tc sc c - dExpr <- literal td sd d - eExpr <- literal te se e - fExpr <- literal tf sf f - tellProg [loc :.: "member1" := aExpr - ,loc :.: "member2" := bExpr - ,loc :.: "member3" := cExpr - ,loc :.: "member4" := dExpr - ,loc :.: "member5" := eExpr - ,loc :.: "member5" := fExpr] -literalLoc loc t@(Tup7Type ta tb tc td te tf tg) (sa,sb,sc,sd,se,sf,sg) (a,b,c,d,e,f,g) = - do aExpr <- literal ta sa a - bExpr <- literal tb sb b - cExpr <- literal tc sc c - dExpr <- literal td sd d - eExpr <- literal te se e - fExpr <- literal tf sf f - gExpr <- literal tg sg g - tellProg [loc :.: "member1" := aExpr - ,loc :.: "member2" := bExpr - ,loc :.: "member3" := cExpr - ,loc :.: "member4" := dExpr - ,loc :.: "member5" := eExpr - ,loc :.: "member5" := fExpr - ,loc :.: "member5" := gExpr] -literalLoc loc t sz a = do rhs <- literal t sz a - tellProg [loc := rhs] - diff --git a/Feldspar/Compiler/Imperative/FromCore/Loop.hs b/Feldspar/Compiler/Imperative/FromCore/Loop.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Loop.hs +++ /dev/null @@ -1,101 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Loop where - - - -import Control.Monad.RWS - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding - -import Feldspar.Core.Types -import Feldspar.Core.Interpretation -import Feldspar.Core.Constructs.Loop hiding (For, While) -import Feldspar.Core.Constructs.Literal -import qualified Feldspar.Core.Constructs.Loop as Core - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - -instance ( Compile dom dom - , Lambda TypeCtx :<: dom - , Literal TypeCtx :<: dom - , Variable TypeCtx :<: dom - ) - => Compile Loop dom - where - compileProgSym ForLoop _ loc (len :* init :* (lam1 :$ (lam2 :$ ixf)) :* Nil) - | Just (info1, Lambda ix) <- prjDecorCtx typeCtx lam1 - , Just (info2, Lambda st) <- prjDecorCtx typeCtx lam2 - = do - let ixvar@(Var _ name) = mkVar (compileTypeRep (infoType info1) (infoSize info1)) ix - let stvar = mkVar (compileTypeRep (infoType info2) (infoSize info2)) st - len' <- mkLength len - compileProg loc init - (_, body) <- withAlias st loc $ confiscateProg $ compileProg stvar ixf >> assign loc stvar - withDecl stvar $ tellProg [For name len' 1 $ Seq body] - - compileProgSym WhileLoop _ loc (init :* (lam1 :$ cond) :* (lam2 :$ body) :* Nil) - | Just (info1, Lambda cv) <- prjDecorCtx typeCtx lam1 - , Just (info2, Lambda cb) <- prjDecorCtx typeCtx lam2 - = do - let stvar = mkVar (compileTypeRep (infoType info2) (infoSize info2)) cb - compileProg loc init - cond' <- withAlias cv loc $ compileExpr cond - (_, body') <- withAlias cb loc $ confiscateProg $ compileProg stvar body >> assign loc stvar - withDecl stvar $ tellProg [While Skip cond' $ Seq body'] - -instance ( Compile dom dom - , Lambda TypeCtx :<: dom - , Literal TypeCtx :<: dom - , Variable TypeCtx :<: dom - ) - => Compile (LoopM Mut) dom - where - compileProgSym Core.For _ loc (len :* (lam :$ ixf) :* Nil) - | Just (info, Lambda v) <- prjDecorCtx typeCtx lam - = do - let ta = argType $ infoType info - let sa = defaultSize ta - let ix@(Var _ name) = mkVar (compileTypeRep ta sa) v - len' <- mkLength len - (e, body) <- confiscateProg $ compileProg loc ixf - tellProg [For name len' 1 $ Seq body] - --- TODO Missing While - compileProgSym Core.While _ loc (cond :* step :* Nil) - = do - cond' <- compileExpr cond - (_,step') <- confiscateProg $ compileProg loc step - tellProg [While Skip cond' $ Seq step'] - diff --git a/Feldspar/Compiler/Imperative/FromCore/Mutable.hs b/Feldspar/Compiler/Imperative/FromCore/Mutable.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Mutable.hs +++ /dev/null @@ -1,129 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Mutable where - - - -import Control.Monad.RWS - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding - -import Feldspar.Core.Types -import Feldspar.Core.Interpretation -import Feldspar.Core.Constructs.Mutable -import Feldspar.Core.Constructs.MutableArray -import Feldspar.Core.Constructs.MutableReference - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - -instance (Compile dom dom, Lambda TypeCtx :<: dom) => Compile (MONAD Mut) dom - where - compileProgSym Bind _ loc (ma :* (lam :$ body) :* Nil) - | Just (_, Lambda v) <- prjDecorCtx typeCtx lam - = do - e <- compileExpr ma - withAlias v e $ compileProg loc body - -{- TODO reenable this implementation! The case above inlines too much if v is used more than once in the body - compileProgSym Bind _ loc (ma :* (Symbol (Decor info lam) :$ body) :* Nil) - | Just (Lambda v) <- prjCtx typeCtx lam - = do - let var = mkVar (compileTypeRep $ argType $ infoType info) v - withDecl var $ do - compileProg var ma - compileProg loc body --} - - compileProgSym Then _ loc (ma :* mb :* Nil) = do - compileExpr ma - compileProg loc mb - - compileProgSym Return info loc (a :* Nil) - | MutType UnitType <- infoType info = return () - | otherwise = compileProg loc a - - compileProgSym When _ loc (c :* action :* Nil) = do - c' <- compileExpr c - (_, body) <- confiscateProg $ compileProg loc action - tellProg [If c' (Seq body) Skip] - -instance (Compile dom dom, Lambda TypeCtx :<: dom) => Compile Mutable dom - where - compileProgSym Run _ loc (ma :* Nil) = compileProg loc ma - - compileExprSym Run info (ma :* Nil) = compileExpr ma - -instance (Compile dom dom, Lambda TypeCtx :<: dom) => Compile MutableReference dom - where - compileProgSym NewRef _ loc (a :* Nil) = compileProg loc a - compileProgSym GetRef _ loc (r :* Nil) = compileProg loc r - compileProgSym SetRef _ loc (r :* a :* Nil) = do - var <- compileExpr r - compileProg var a - - compileExprSym GetRef _ (r :* Nil) = compileExpr r - compileExprSym feat info args = compileProgFresh feat info args - -instance (Compile dom dom, Lambda TypeCtx :<: dom) => Compile MutableArray dom - where - compileProgSym NewArr_ _ loc (length :* Nil) = do - len <- compileExpr length - tellProg [Call "setLength" [In loc,In len]] - - compileProgSym NewArr _ loc (length :* a :* Nil) = do - let ix = Var U32 "i" - a' <- compileExpr a - len <- compileExpr length - tellProg [For "i" len 1 (Seq [loc :!: ix := a'])] - - compileProgSym GetArr _ loc (arr :* i :* Nil) = do - arr' <- compileExpr arr - i' <- compileExpr i - assign loc (arr' :!: i') - - compileProgSym SetArr _ _ (arr :* i :* a :* Nil) = do - arr' <- compileExpr arr - i' <- compileExpr i - a' <- compileExpr a - assign (arr' :!: i') a' - - compileProgSym a info loc args = compileExprLoc a info loc args - - compileExprSym ArrLength info (arr :* Nil) = do - a' <- compileExpr arr - return $ Fun (compileTypeRep (infoType info) (infoSize info)) "getLength" [a'] - - compileExprSym a info args = compileProgFresh a info args - diff --git a/Feldspar/Compiler/Imperative/FromCore/MutableToPure.hs b/Feldspar/Compiler/Imperative/FromCore/MutableToPure.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/MutableToPure.hs +++ /dev/null @@ -1,85 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.MutableToPure where - - - -import Control.Monad.RWS - -import Language.Syntactic -import Language.Syntactic.Constructs.Binding - -import Feldspar.Core.Types -import Feldspar.Core.Interpretation -import Feldspar.Core.Constructs.MutableToPure - -import Feldspar.Compiler.Imperative.Frontend hiding (Variable) -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - -instance ( Compile dom dom - , Lambda TypeCtx :<: dom - , Variable TypeCtx :<: dom - ) - => Compile MutableToPure dom - where - compileProgSym WithArray _ loc (marr :* (lam :$ body) :* Nil) - | Just (_, Variable v0) <- prjDecorCtx typeCtx marr - , Just (info, Lambda v1) <- prjDecorCtx typeCtx lam - = do - e <- compileExpr marr - withAlias v1 e $ do - e <- compileExpr body - tellProg [copyProg loc e] - - compileProgSym WithArray _ loc (marr :* (lam :$ body) :* Nil) - | Just (info, Lambda v) <- prjDecorCtx typeCtx lam - = do - let ta = argType $ infoType info - let sa = defaultSize ta - let var = mkVar (compileTypeRep ta sa) v - withDecl var $ do - compileProg var marr - e <- compileExpr body - tellProg [copyProg loc e] - - compileProgSym RunMutableArray _ loc (marr :* Nil) = compileProg loc marr - -{- NOTES: - -The trick of doing a copy at the end, i.e. `tellProg [copyProg loc -e]`, when compiling WithArray is important. It allows us to safely -return the pure array that is passed in as input. This is nice because -it allows us to implement `freezeArray` in terms of `withArray`. -In most cases I expect `withArray` to return a scalar as its final -result and then the copyProg is harmless. --} diff --git a/Feldspar/Compiler/Imperative/FromCore/Par.hs b/Feldspar/Compiler/Imperative/FromCore/Par.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Par.hs +++ /dev/null @@ -1,105 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Par where - -import Language.Syntactic -import Language.Syntactic.Constructs.Monad -import Language.Syntactic.Constructs.Binding - -import Feldspar.Core.Types -import Feldspar.Core.Interpretation -import Feldspar.Core.Constructs.Par - -import Feldspar.Compiler.Imperative.Frontend hiding (Variable) -import Feldspar.Compiler.Imperative.FromCore.Interpretation - -instance ( Compile dom dom - , Lambda TypeCtx :<: dom - , ParFeature :<: dom - ) - => Compile (MONAD Par) dom - where - compileProgSym Bind _ loc (ma :* (lam :$ body) :* Nil) - | Just (_, Lambda v) <- prjDecorCtx typeCtx lam - , Just (info, ParNew) <- prjDecor ma - -- TODO add helper function :: Info (Par a) -> Info a - = do - let var = mkVar (compileTypeRep (infoType info) (infoSize info)) v - withDecl var $ compileProg loc body - - compileProgSym Bind _ loc (ma :* (lam :$ body) :* Nil) - | Just (_, Lambda v) <- prjDecorCtx typeCtx lam - = do - e <- compileExpr ma - withAlias v e $ compileProg loc body - - compileProgSym Then _ loc (ma :* mb :* Nil) = do - compileExpr ma - compileProg loc mb - - compileProgSym Return info loc (a :* Nil) - | ParType UnitType <- infoType info = return () - | otherwise = compileProg loc a - - compileProgSym When _ loc (c :* action :* Nil) = do - c' <- compileExpr c - (_, body) <- confiscateProg $ compileProg loc action - tellProg [If c' (Seq body) Skip] - -instance ( Compile dom dom - , Variable TypeCtx :<: dom - ) - => Compile ParFeature dom - where - compileExprSym ParGet _ (r :* Nil) = do - releaseProgs - compileExpr r - - compileExprSym a info args = compileProgFresh a info args - - compileProgSym ParRun _ loc (p :* Nil) = compileProg loc p - - compileProgSym ParGet _ loc (r :* Nil) = do - releaseProgs - compileProg loc r - - compileProgSym ParPut _ loc (r :* a :* Nil) - | Just (info, Variable v) <- prjDecorCtx typeCtx r - = do - let var = mkVar (compileTypeRep (infoType info) (infoSize info)) v - compileProg var a - - compileProgSym ParFork _ loc (p :* Nil) = do - suspendProg $ compileProg loc p - - compileProgSym ParYield _ loc Nil = return () - - diff --git a/Feldspar/Compiler/Imperative/FromCore/Primitive.hs b/Feldspar/Compiler/Imperative/FromCore/Primitive.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Primitive.hs +++ /dev/null @@ -1,82 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Primitive where - - - -import Language.Syntactic -import Language.Syntactic.Interpretation.Semantics - -import Feldspar.Core.Interpretation -import Feldspar.Core.Constructs.Bits -import Feldspar.Core.Constructs.Complex -import Feldspar.Core.Constructs.Conversion -import Feldspar.Core.Constructs.Eq -import Feldspar.Core.Constructs.Floating -import Feldspar.Core.Constructs.Fractional -import Feldspar.Core.Constructs.Integral -import Feldspar.Core.Constructs.Logic -import Feldspar.Core.Constructs.Num -import Feldspar.Core.Constructs.Ord -import Feldspar.Core.Constructs.Trace - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - --- | Converts symbols to primitive function calls -instance Compile dom dom => Compile Semantics dom - where - compileExprSym (Sem name _) info args = do - argExprs <- sequence $ listArgs compileExpr args - return $ Fun (compileTypeRep (infoType info) (infoSize info)) name argExprs - --- | Convenient implementation of 'compileExprSym' for primitive functions -compilePrim :: (Semantic expr, Compile dom dom) - => expr a - -> Info (DenResult a) - -> Args (AST (Decor Info dom)) a - -> CodeWriter Expr -compilePrim = compileExprSym . semantics - -instance Compile dom dom => Compile BITS dom where compileExprSym = compilePrim -instance Compile dom dom => Compile COMPLEX dom where compileExprSym = compilePrim -instance Compile dom dom => Compile Conversion dom where compileExprSym = compilePrim -instance Compile dom dom => Compile EQ dom where compileExprSym = compilePrim -instance Compile dom dom => Compile FLOATING dom where compileExprSym = compilePrim -instance Compile dom dom => Compile FRACTIONAL dom where compileExprSym = compilePrim -instance Compile dom dom => Compile INTEGRAL dom where compileExprSym = compilePrim -instance Compile dom dom => Compile Logic dom where compileExprSym = compilePrim -instance Compile dom dom => Compile NUM dom where compileExprSym = compilePrim -instance Compile dom dom => Compile ORD dom where compileExprSym = compilePrim -instance Compile dom dom => Compile Trace dom where compileExprSym = compilePrim - diff --git a/Feldspar/Compiler/Imperative/FromCore/Save.hs b/Feldspar/Compiler/Imperative/FromCore/Save.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Save.hs +++ /dev/null @@ -1,48 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Save where - - - -import Language.Syntactic - -import Feldspar.Core.Types -import Feldspar.Core.Constructs.Save - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - -instance Compile dom dom => Compile Save dom - where - compileProgSym Save _ loc (a :* Nil) = compileProg loc a - diff --git a/Feldspar/Compiler/Imperative/FromCore/SizeProp.hs b/Feldspar/Compiler/Imperative/FromCore/SizeProp.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/SizeProp.hs +++ /dev/null @@ -1,51 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.SizeProp where - - - -import Control.Monad.RWS - -import Language.Syntactic - -import Feldspar.Core.Constructs.SizeProp - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - -instance Compile dom dom => Compile PropSize dom - where - compileProgSym (PropSize _) _ loc (_ :* b :* Nil) = compileProg loc b - - compileExprSym (PropSize _) _ (_ :* b :* Nil) = compileExpr b - diff --git a/Feldspar/Compiler/Imperative/FromCore/SourceInfo.hs b/Feldspar/Compiler/Imperative/FromCore/SourceInfo.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/SourceInfo.hs +++ /dev/null @@ -1,53 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.SourceInfo where - - - -import Language.Syntactic - -import Feldspar.Core.Types -import Feldspar.Core.Constructs.SourceInfo - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - -instance Compile dom dom => Compile (Decor SourceInfo1 (Identity TypeCtx)) dom - where - compileProgSym (Decor (SourceInfo1 info) Id) _ loc (a :* Nil) = do - tellProg [BComment info] - compileProg loc a - compileExprSym (Decor (SourceInfo1 info) Id) _ (a :* Nil) = do - tellProg [BComment info] - compileExpr a - diff --git a/Feldspar/Compiler/Imperative/FromCore/Tuple.hs b/Feldspar/Compiler/Imperative/FromCore/Tuple.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/FromCore/Tuple.hs +++ /dev/null @@ -1,104 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances #-} - -module Feldspar.Compiler.Imperative.FromCore.Tuple where - - - -import Language.Syntactic - -import Feldspar.Core.Types -import Feldspar.Core.Constructs.Tuple - -import Feldspar.Compiler.Imperative.Frontend -import Feldspar.Compiler.Imperative.FromCore.Interpretation - - - -instance Compile dom dom => Compile (Tuple TypeCtx) dom - where - compileProgSym Tup2 _ loc (m1 :* m2 :* Nil) = do - compileExpr m1 >>= assign (loc :.: "member1") - compileExpr m2 >>= assign (loc :.: "member2") - compileProgSym Tup3 _ loc (m1 :* m2 :* m3 :* Nil) = do - compileExpr m1 >>= assign (loc :.: "member1") - compileExpr m2 >>= assign (loc :.: "member2") - compileExpr m3 >>= assign (loc :.: "member3") - compileProgSym Tup4 _ loc (m1 :* m2 :* m3 :* m4 :* Nil) = do - compileExpr m1 >>= assign (loc :.: "member1") - compileExpr m2 >>= assign (loc :.: "member2") - compileExpr m3 >>= assign (loc :.: "member3") - compileExpr m4 >>= assign (loc :.: "member4") - compileProgSym Tup5 _ loc (m1 :* m2 :* m3 :* m4 :* m5 :* Nil) = do - compileExpr m1 >>= assign (loc :.: "member1") - compileExpr m2 >>= assign (loc :.: "member2") - compileExpr m3 >>= assign (loc :.: "member3") - compileExpr m4 >>= assign (loc :.: "member4") - compileExpr m5 >>= assign (loc :.: "member5") - compileProgSym Tup6 _ loc (m1 :* m2 :* m3 :* m4 :* m5 :* m6 :* Nil) = do - compileExpr m1 >>= assign (loc :.: "member1") - compileExpr m2 >>= assign (loc :.: "member2") - compileExpr m3 >>= assign (loc :.: "member3") - compileExpr m4 >>= assign (loc :.: "member4") - compileExpr m5 >>= assign (loc :.: "member5") - compileExpr m6 >>= assign (loc :.: "member6") - compileProgSym Tup7 _ loc (m1 :* m2 :* m3 :* m4 :* m5 :* m6 :* m7 :* Nil) = do - compileExpr m1 >>= assign (loc :.: "member1") - compileExpr m2 >>= assign (loc :.: "member2") - compileExpr m3 >>= assign (loc :.: "member3") - compileExpr m4 >>= assign (loc :.: "member4") - compileExpr m5 >>= assign (loc :.: "member5") - compileExpr m6 >>= assign (loc :.: "member6") - compileExpr m7 >>= assign (loc :.: "member7") - -instance Compile dom dom => Compile (Select TypeCtx) dom - where - compileExprSym Sel1 _ (tup :* Nil) = do - tupExpr <- compileExpr tup - return $ tupExpr :.: "member1" - compileExprSym Sel2 _ (tup :* Nil) = do - tupExpr <- compileExpr tup - return $ tupExpr :.: "member2" - compileExprSym Sel3 _ (tup :* Nil) = do - tupExpr <- compileExpr tup - return $ tupExpr :.: "member3" - compileExprSym Sel4 _ (tup :* Nil) = do - tupExpr <- compileExpr tup - return $ tupExpr :.: "member4" - compileExprSym Sel5 _ (tup :* Nil) = do - tupExpr <- compileExpr tup - return $ tupExpr :.: "member5" - compileExprSym Sel6 _ (tup :* Nil) = do - tupExpr <- compileExpr tup - return $ tupExpr :.: "member6" - compileExprSym Sel7 _ (tup :* Nil) = do - tupExpr <- compileExpr tup - return $ tupExpr :.: "member7" - diff --git a/Feldspar/Compiler/Imperative/Frontend.hs b/Feldspar/Compiler/Imperative/Frontend.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/Frontend.hs +++ /dev/null @@ -1,353 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE ViewPatterns #-} - -module Feldspar.Compiler.Imperative.Frontend where - -import Data.List - -import Feldspar.Compiler.Imperative.Representation hiding (Type, UserType, Cast, In, Out, Variable, Block, Pointer, Comment) -import qualified Feldspar.Compiler.Imperative.Representation as AIR - -import Feldspar.Core.Types hiding (Type) - --- * Frontend data types - -data Mod = Mod [Ent] - deriving (Show) - -data Ent - = StructD String [(String, Type)] - | ProcDf String [Var] [Var] Prog - | ProcDcl String [Var] [Var] - deriving (Show) - -data Type - = Void - | Boolean - | Bit - | Floating - | I8 | I16 | I32 | I40 | I64 - | U8 | U16 | U32 | U40 | U64 - | Complex Type - | UserType String - | Array Type - | SizedArray Int Type - | Struct [(String, Type)] - deriving Eq - -data Expr - = Var Type String - | Ptr Type String - | Tr - | Fl - | LitI Type Integer - | LitF Double - | LitC Expr Expr - | Expr :!: Expr - | Expr :.: String - | Binop Type String [Expr] - | Fun Type String [Expr] - | Cast Type Expr - | SizeofE Expr - | SizeofT Type - deriving (Show) - -data Prog - = Skip - | BComment String - | Comment String - | Expr := Expr - | Call String [Param] - | Seq [Prog] - | If Expr Prog Prog - | While Prog Expr Prog - | For String Expr Int Prog - | Block [Def] Prog - deriving (Show) - -data Param - = In Expr - | Out Expr - deriving (Show) - -data Block - = Bl [Def] Prog - deriving (Show) - -data Def - = Init Type String Expr - | Def Type String - deriving (Show) - -data Var - = Variable Type String - | Pointer Type String - deriving (Show) - --- * Conversion between representation and frontend - -class Interface t where - type Repr t - toInterface :: Repr t -> t - fromInterface :: t -> Repr t - -instance Interface Mod where - type Repr Mod = AIR.Module () - toInterface (Module entities ()) = Mod $ map toInterface entities - fromInterface (Mod entities) = AIR.Module (map fromInterface entities) () - -instance Interface Ent where - type Repr Ent = AIR.Entity () - toInterface (AIR.StructDef name members () ()) = - StructD name (map (\(StructMember mname mtyp ())->(mname,toInterface mtyp)) members) - toInterface (AIR.ProcDef name inparams outparams body () ()) = - ProcDf name (map toInterface inparams) (map toInterface outparams) (toProg body) - toInterface (AIR.ProcDecl name inparams outparams () ()) = - ProcDcl name (map toInterface inparams) (map toInterface outparams) - fromInterface (StructD name members) = - AIR.StructDef name (map (\(mname,mtyp)->(StructMember mname (fromInterface mtyp) ())) members) () () - fromInterface (ProcDf name inparams outparams body) = - AIR.ProcDef name (map fromInterface inparams) (map fromInterface outparams) (toBlock body) () () - fromInterface (ProcDcl name inparams outparams) = - AIR.ProcDecl name (map fromInterface inparams) (map fromInterface outparams) () () - - -instance Interface Type where - type Repr Type = AIR.Type - toInterface VoidType = Void - toInterface AIR.BoolType = Boolean - toInterface BitType = Bit - toInterface AIR.FloatType = Floating - toInterface (NumType Signed S8) = I8 - toInterface (NumType Signed S16) = I16 - toInterface (NumType Signed S32) = I32 - toInterface (NumType Signed S40) = I40 - toInterface (NumType Signed S64) = I64 - toInterface (NumType Unsigned S8) = U8 - toInterface (NumType Unsigned S16) = U16 - toInterface (NumType Unsigned S32) = U32 - toInterface (NumType Unsigned S40) = U40 - toInterface (NumType Unsigned S64) = U64 - toInterface (AIR.ComplexType t) = Complex $ toInterface t - toInterface (AIR.UserType s) = UserType s - toInterface (AIR.ArrayType (LiteralLen l) t) = SizedArray l $ toInterface t - toInterface (AIR.ArrayType _ t) = Array $ toInterface t - toInterface (AIR.StructType fields) = Struct $ map (\(name,t) -> (name,toInterface t)) fields - fromInterface Void = VoidType - fromInterface Boolean = AIR.BoolType - fromInterface Bit = BitType - fromInterface Floating = AIR.FloatType - fromInterface I8 = NumType Signed S8 - fromInterface I16 = NumType Signed S16 - fromInterface I32 = NumType Signed S32 - fromInterface I40 = NumType Signed S40 - fromInterface I64 = NumType Signed S64 - fromInterface U8 = NumType Unsigned S8 - fromInterface U16 = NumType Unsigned S16 - fromInterface U32 = NumType Unsigned S32 - fromInterface U40 = NumType Unsigned S40 - fromInterface U64 = NumType Unsigned S64 - fromInterface (Complex t) = AIR.ComplexType $ fromInterface t - fromInterface (UserType s) = AIR.UserType s - fromInterface (Array t) = AIR.ArrayType UndefinedLen $ fromInterface t - fromInterface (SizedArray l t) = AIR.ArrayType (LiteralLen l) $ fromInterface t - fromInterface (Struct fields) = AIR.StructType $ map (\(name,t) -> (name,fromInterface t)) fields - -instance Interface Expr where - type Repr Expr = Expression () - toInterface (VarExpr (AIR.Variable name t Value ()) ()) = Var (toInterface t) name - toInterface (VarExpr (AIR.Variable name t AIR.Pointer ()) ()) = Ptr (toInterface t) name - toInterface (ArrayElem arr idx () ()) = (toInterface arr) :!: (toInterface idx) - toInterface (StructField str field () ()) = (toInterface str) :.: field - toInterface (ConstExpr (BoolConst True () ()) ()) = Tr - toInterface (ConstExpr (BoolConst False () ()) ()) = Fl - toInterface (ConstExpr (IntConst x t () ()) ()) = LitI (toInterface t) x - toInterface (ConstExpr (FloatConst x () ()) ()) = LitF x - toInterface (ConstExpr (ComplexConst r i () ()) ()) = LitC (toInterface $ ConstExpr r ()) (toInterface $ ConstExpr i ()) - toInterface (FunctionCall (Function name t Prefix) ps () ()) = Fun (toInterface t) name $ map toInterface ps - toInterface (FunctionCall (Function name t Infix) ps () ()) = Binop (toInterface t) name $ map toInterface ps - toInterface (AIR.Cast t e () ()) = Cast (toInterface t) (toInterface e) - toInterface (SizeOf (Left t) () ()) = SizeofT $ toInterface t - toInterface (SizeOf (Right e) () ()) = SizeofE $ toInterface e - fromInterface (Var t name) = VarExpr (AIR.Variable name (fromInterface t) Value ()) () - fromInterface (Ptr t name) = VarExpr (AIR.Variable name (fromInterface t) AIR.Pointer ()) () - fromInterface (Tr) = ConstExpr (BoolConst True () ()) () - fromInterface (Fl) = ConstExpr (BoolConst False () ()) () - fromInterface (LitI t x) = ConstExpr (IntConst x (fromInterface t) () ()) () - fromInterface (LitF x) = ConstExpr (FloatConst x () ()) () - fromInterface (LitC (fromInterface -> (ConstExpr r ())) (fromInterface -> (ConstExpr i ()))) = - ConstExpr (ComplexConst r i () ()) () - fromInterface (LitC _ _) = error "Illegal LitC" -- TODO (?) - fromInterface (Binop t name es) = FunctionCall (Function name (fromInterface t) Infix) (map fromInterface es) () () - fromInterface (Fun t name es) = FunctionCall (Function name (fromInterface t) Prefix) (map fromInterface es) () () - fromInterface (Cast t e) = AIR.Cast (fromInterface t) (fromInterface e) () () - fromInterface (SizeofE e) = SizeOf (Right $ fromInterface e) () () - fromInterface (SizeofT t) = SizeOf (Left $ fromInterface t) () () - fromInterface (arr :!: idx) = ArrayElem (fromInterface arr) (fromInterface idx) () () - fromInterface (str :.: field) = StructField (fromInterface str) field () () - -instance Interface Prog where - type Repr Prog = AIR.Program () - toInterface (Empty () ()) = Skip - toInterface (AIR.Comment True s () ()) = BComment s - toInterface (AIR.Comment False s () ()) = Comment s - toInterface (Assign lhs rhs () ()) = (toInterface lhs) := (toInterface rhs) - toInterface (ProcedureCall s ps () ()) = Call s (map toInterface ps) - toInterface (Sequence ps () ()) = Seq (map toInterface ps) - toInterface (Branch e b1 b2 () ()) = If (toInterface e) (toProg b1) (toProg b2) - toInterface (SeqLoop e pe b () ()) = While (toProg pe) (toInterface e) (toProg b) - toInterface (ParLoop v e i b () ()) = For (varName v) (toInterface e) i (toProg b) - toInterface (BlockProgram b ()) = Block (map toInterface $ locals b) (toInterface $ blockBody b) - fromInterface (Skip) = Empty () () - fromInterface (BComment s) = AIR.Comment True s () () - fromInterface (Comment s) = AIR.Comment False s () () - fromInterface (lhs := rhs) = Assign (fromInterface lhs) (fromInterface rhs) () () - fromInterface (Call s ps) = ProcedureCall s (map fromInterface ps) () () - fromInterface (Seq ps) = Sequence (map fromInterface ps) () () - fromInterface (If e p1 p2) = Branch (fromInterface e) (toBlock p1) (toBlock p2) () () - fromInterface (While pe e p) = SeqLoop (fromInterface e) (toBlock pe) (toBlock p) () () - fromInterface (For s e i p) = ParLoop - (AIR.Variable s (NumType Unsigned S32) Value ()) (fromInterface e) i (toBlock p) () () - fromInterface (Block ds p) = BlockProgram (AIR.Block (map fromInterface ds) (fromInterface p) ()) () - -instance Interface Param where - type Repr Param = ActualParameter () - toInterface (AIR.In e ()) = In (toInterface e) - toInterface (AIR.Out e ()) = Out (toInterface e) - fromInterface (In e) = AIR.In (fromInterface e) () - fromInterface (Out e) = AIR.Out (fromInterface e) () - -instance Interface Def where - type Repr Def = Declaration () - toInterface (Declaration v (Just e) ()) = Init (toInterface $ varType v) (varName v) (toInterface e) - toInterface (Declaration v Nothing ()) = Def (toInterface $ varType v) (varName v) - fromInterface (Init t s e) = Declaration (AIR.Variable s (fromInterface t) Value ()) (Just $ fromInterface e) () - fromInterface (Def t s) = Declaration (AIR.Variable s (fromInterface t) Value ()) Nothing () - -instance Interface Block where - type Repr Block = AIR.Block () - toInterface (AIR.Block ds p ()) = Bl (map toInterface ds) (toInterface p) - fromInterface (Bl ds p) = AIR.Block (map fromInterface ds) (fromInterface p) () - -instance Interface Var where - type Repr Var = AIR.Variable () - toInterface (AIR.Variable name typ Value ()) = Variable (toInterface typ) name - toInterface (AIR.Variable name typ AIR.Pointer ()) = Pointer (toInterface typ) name - fromInterface (Variable typ name) = AIR.Variable name (fromInterface typ) Value () - fromInterface (Pointer typ name) = AIR.Variable name (fromInterface typ) AIR.Pointer () - -toBlock :: Prog -> AIR.Block () -toBlock (Block ds p) = AIR.Block (map fromInterface ds) (fromInterface p) () -toBlock p = AIR.Block [] (fromInterface p) () - -toProg :: AIR.Block () -> Prog -toProg (AIR.Block [] p ()) = toInterface p -toProg (AIR.Block ds p ()) = Block (map toInterface ds) (toInterface p) - -boolToExpr :: Bool -> Expr -boolToExpr True = Tr -boolToExpr False = Fl - -setLength :: Expr -> Expr -> Prog -setLength arr len = Call "setLength" [Out arr, In len] - -increaseLength :: Expr -> Expr -> Prog -increaseLength arr len = Call "increaseLength" [Out arr, In len] - -copyProg :: Expr -> Expr -> Prog -copyProg outExp inExp = Call "copy" [Out outExp, In inExp] - -copyProgPos :: Expr -> Expr -> Expr -> Prog -copyProgPos outExp shift inExp = Call "copyArrayPos" [Out outExp, In shift, In inExp] - -copyProgLen :: Expr -> Expr -> Expr -> Prog -copyProgLen outExp inExp len = Call "copyArrayLen" [Out outExp, In inExp, In len] - -instance Show Type - where - show Void = "void" - show Boolean = "bool" - show Bit = "bit" - show Floating = "float" - show I8 = "int8" - show I16 = "int16" - show I32 = "int32" - show I40 = "int40" - show I64 = "int64" - show U8 = "uint8" - show U16 = "uint16" - show U32 = "uint32" - show U40 = "uint40" - show U64 = "uint64" - show (Complex t) = "complexOf_" ++ show t - show (UserType s) = "userType_" ++ s - show (Array t) = "arrayOf_" ++ show t - show (SizedArray i t) = "arrayOfSize_" ++ show i ++ "_" ++ show t - show (Struct fields) = "struct_" ++ intercalate "_" (map (\(s,t) -> s ++ "_" ++ show t) fields) - -instance HasType Expr - where - type TypeOf Expr = Type - typeof = toInterface . typeof . fromInterface - -intWidth :: Type -> Maybe Integer -intWidth I8 = Just 8 -intWidth I16 = Just 16 -intWidth I32 = Just 32 -intWidth I40 = Just 40 -intWidth I64 = Just 64 -intWidth U8 = Just 8 -intWidth U16 = Just 16 -intWidth U32 = Just 32 -intWidth U40 = Just 40 -intWidth U64 = Just 64 -intWidth _ = Nothing - -intSigned :: Type -> Maybe Bool -intSigned I8 = Just True -intSigned I16 = Just True -intSigned I32 = Just True -intSigned I40 = Just True -intSigned I64 = Just True -intSigned U8 = Just False -intSigned U16 = Just False -intSigned U32 = Just False -intSigned U40 = Just False -intSigned U64 = Just False -intSigned _ = Nothing - -litB :: Bool -> Expr -litB True = Tr -litB False = Fl - -isArray :: Type -> Bool -isArray (Array _) = True -isArray (SizedArray _ _) = True -isArray _ = False diff --git a/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs b/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs +++ /dev/null @@ -1,68 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE TypeFamilies #-} - -module Feldspar.Compiler.Imperative.Plugin.ConstantFolding where - -import Feldspar.Transformation - -data ConstantFolding = ConstantFolding - -instance Plugin ConstantFolding where - type ExternalInfo ConstantFolding = () - executePlugin ConstantFolding _ procedure = result $ transform ConstantFolding () () procedure - -instance Transformation ConstantFolding where - type From ConstantFolding = () - type To ConstantFolding = () - type Down ConstantFolding = () - type Up ConstantFolding = () - type State ConstantFolding = () - -instance Transformable ConstantFolding Expression where - transform t s d f@(FunctionCall _ _ _ _) = case funMode $ function f' of - Infix -> case funName $ function f' of - "+" -> tr' $ elimParamIf (isConstIntN 0) True $ result tr - "-" -> tr' $ elimParamIf (isConstIntN 0) False $ result tr - "*" -> tr' $ elimParamIf (isConstIntN 1) True $ result tr - _ -> tr - _ -> tr - where - tr = defaultTransform t s d f - tr' x = tr {result = x} - f' = result tr - isConstIntN n (ConstExpr (IntConst i _ _ _) _) = n == i - isConstIntN _ _ = False - - elimParamIf pred flippable funCall@(FunctionCall (Function _ _ Infix) (x:xs) _ _) - | pred (head xs) = x - | flippable && pred x = head xs - | otherwise = funCall - elimParamIf _ _ funCall = funCall - transform t s d e = defaultTransform t s d e diff --git a/Feldspar/Compiler/Imperative/Plugin/Naming.hs b/Feldspar/Compiler/Imperative/Plugin/Naming.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/Plugin/Naming.hs +++ /dev/null @@ -1,161 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE EmptyDataDecls, TypeFamilies #-} - -module Feldspar.Compiler.Imperative.Plugin.Naming where - -import Data.Char - -import Feldspar.Transformation -import Feldspar.Core.Types - -import qualified Feldspar.NameExtractor as Precompiler -import Feldspar.Compiler.Error -import Feldspar.Compiler.Backend.C.Library - -import System.IO.Unsafe - --- =========================================================================== --- == Precompilation plugin --- =========================================================================== - -data SignatureInformation = SignatureInformation { - originalFunctionName :: String, - generatedImperativeParameterNames :: [String], - originalParameterNames :: Maybe [Maybe String] -} deriving (Show, Eq) - -instance Default SignatureInformation where def = precompilationError InternalError "Default value should not be used" - -precompilationError = handleError "PluginArch/Naming" - -data Precompilation = Precompilation - -instance Transformation Precompilation where - type From Precompilation = () - type To Precompilation = () - type Down Precompilation = SignatureInformation - type Up Precompilation = () - type State Precompilation = () - - -instance Transformable Precompilation Entity where - transform t s d x@(ProcDef n i _ _ _ _) | n == "PLACEHOLDER" = tr { result = (result tr){ procName = n' } } where - d' = d { generatedImperativeParameterNames = map varName i } - tr = defaultTransform t s d' x - n' = originalFunctionName d - transform t s d x = defaultTransform t s d x - -instance Transformable Precompilation Variable where - transform t s d v = Result newVar s def where - newVar = v - { varName = (maybeStr2Str $ getVariableName d (varName v)) ++ varName v - , varLabel = () - } - -getVariableName :: SignatureInformation -> String -> Maybe String -getVariableName signatureInformation origname = case (originalParameterNames signatureInformation) of - Just originalParameterNameList -> - if length (generatedImperativeParameterNames signatureInformation) == length originalParameterNameList then - case searchResults of - [] -> Nothing - otherwise -> snd $ head $ searchResults - else - precompilationError InternalError $ "parameter name list length mismatch:" ++ - show (generatedImperativeParameterNames signatureInformation) ++ " " ++ show originalParameterNameList - where - searchResults = filter (((==) origname).fst) - (zip (generatedImperativeParameterNames signatureInformation) originalParameterNameList) - Nothing -> Nothing - -maybeStr2Str :: Maybe String -> String -maybeStr2Str (Just s) = s ++ "_" -maybeStr2Str Nothing = "" - -data PrecompilationExternalInfo = PrecompilationExternalInfo { - originalFunctionSignature :: Precompiler.OriginalFunctionSignature, - inputParametersDescriptor :: [Int], - numberOfFunctionArguments :: Int, - compilationMode :: CompilationMode -} - -addPostfixNumberToMaybeString :: (Maybe String, Int) -> Maybe String -addPostfixNumberToMaybeString (ms, num) = case ms of - Just s -> Just $ s ++ (show num) - Nothing -> Nothing - -inflate :: Int -> [Maybe String] -> [Maybe String] -inflate target list | length list < target = inflate target (list++[Nothing]) - | length list == target = list - | otherwise = precompilationError InternalError "Unexpected situation in 'inflate'" - --- Replicates each element of the [parameter list given by the precompiler] based on the input parameter descriptor -parameterNameListConsolidator :: PrecompilationExternalInfo -> [Maybe String] -parameterNameListConsolidator externalInfo = - if (numberOfFunctionArguments externalInfo == (length $ inputParametersDescriptor externalInfo)) - then - concat $ map (\(cnt,name)->replicate cnt name) - (zip (inputParametersDescriptor externalInfo) - (Precompiler.originalParameterNames $ originalFunctionSignature externalInfo)) - else - precompilationError InternalError "numArgs should be equal to the length of the input parameters' descriptor" - -instance Plugin Precompilation where - type ExternalInfo Precompilation = PrecompilationExternalInfo - executePlugin Precompilation externalInfo procedure = result - $ transform Precompilation ({-state-}) (SignatureInformation { - originalFunctionName = Precompiler.originalFunctionName $ originalFunctionSignature externalInfo, - generatedImperativeParameterNames = precompilationError InternalError "GIPN should have been overwritten", - originalParameterNames = case compilationMode externalInfo of - Standalone -> - if -- ultimate check, should be enough... - numberOfFunctionArguments externalInfo == - length (Precompiler.originalParameterNames $ originalFunctionSignature externalInfo) - then - Just $ parameterNameListConsolidator externalInfo - else - (unsafePerformIO $ do - withColor Yellow $ putStrLn $ "[WARNING @ PluginArch/Naming]:"++ - " not enough named parameters in function " ++ - (Precompiler.originalFunctionName $ originalFunctionSignature externalInfo) - withColor Yellow $ putStrLn $ "numArgs: " ++ show (numberOfFunctionArguments externalInfo) ++ - ", parameter list: " ++ show (Precompiler.originalParameterNames $ - originalFunctionSignature externalInfo) - return $ Just $ parameterNameListConsolidator (externalInfo { - originalFunctionSignature = (originalFunctionSignature externalInfo) { - Precompiler.originalParameterNames = - inflate (numberOfFunctionArguments externalInfo) $ - Precompiler.originalParameterNames $ - originalFunctionSignature externalInfo - } - }) - ) - Interactive -> Nothing -- no parameter name handling in interactive mode - }) procedure - diff --git a/Feldspar/Compiler/Imperative/Plugin/Unroll.hs b/Feldspar/Compiler/Imperative/Plugin/Unroll.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/Plugin/Unroll.hs +++ /dev/null @@ -1,270 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE FlexibleInstances, TypeFamilies #-} - -module Feldspar.Compiler.Imperative.Plugin.Unroll where - -import Data.List (elem) - -import Feldspar.Compiler.Backend.C.Options -import Feldspar.Transformation - --- ============================ --- == Unroll's Semantic info == --- ============================ - -data SemInfPrg = SemInfPrg - { position :: Int - , varNames :: [String] - , loopVar :: String - } deriving (Eq, Show) - -data UnrollSemInf - -instance Annotation UnrollSemInf Module where - type Label UnrollSemInf Module = () - -instance Annotation UnrollSemInf Entity where - type Label UnrollSemInf Entity = () - -instance Annotation UnrollSemInf Struct where - type Label UnrollSemInf Struct = () - -instance Annotation UnrollSemInf StructMember where - type Label UnrollSemInf StructMember = () - -instance Annotation UnrollSemInf ProcDef where - type Label UnrollSemInf ProcDef = () - -instance Annotation UnrollSemInf ProcDecl where - type Label UnrollSemInf ProcDecl = () - -instance Annotation UnrollSemInf Block where - type Label UnrollSemInf Block = () - -instance Annotation UnrollSemInf Program where - type Label UnrollSemInf Program = Maybe SemInfPrg - -instance Annotation UnrollSemInf Empty where - type Label UnrollSemInf Empty = () - -instance Annotation UnrollSemInf Comment where - type Label UnrollSemInf Comment = () - -instance Annotation UnrollSemInf Assign where - type Label UnrollSemInf Assign = () - -instance Annotation UnrollSemInf ProcedureCall where - type Label UnrollSemInf ProcedureCall = () - -instance Annotation UnrollSemInf Sequence where - type Label UnrollSemInf Sequence = () - -instance Annotation UnrollSemInf Branch where - type Label UnrollSemInf Branch = () - -instance Annotation UnrollSemInf SeqLoop where - type Label UnrollSemInf SeqLoop = () - -instance Annotation UnrollSemInf ParLoop where - type Label UnrollSemInf ParLoop = () - -instance Annotation UnrollSemInf ActualParameter where - type Label UnrollSemInf ActualParameter = () - -instance Annotation UnrollSemInf Declaration where - type Label UnrollSemInf Declaration = () - -instance Annotation UnrollSemInf Expression where - type Label UnrollSemInf Expression = () - -instance Annotation UnrollSemInf FunctionCall where - type Label UnrollSemInf FunctionCall = () - -instance Annotation UnrollSemInf Cast where - type Label UnrollSemInf Cast = () - -instance Annotation UnrollSemInf SizeOf where - type Label UnrollSemInf SizeOf = () - -instance Annotation UnrollSemInf ArrayElem where - type Label UnrollSemInf ArrayElem = () - -instance Annotation UnrollSemInf StructField where - type Label UnrollSemInf StructField = () - -instance Annotation UnrollSemInf Constant where - type Label UnrollSemInf Constant = () - -instance Annotation UnrollSemInf IntConst where - type Label UnrollSemInf IntConst = () - -instance Annotation UnrollSemInf FloatConst where - type Label UnrollSemInf FloatConst = () - -instance Annotation UnrollSemInf BoolConst where - type Label UnrollSemInf BoolConst = () - -instance Annotation UnrollSemInf ArrayConst where - type Label UnrollSemInf ArrayConst = () - -instance Annotation UnrollSemInf ComplexConst where - type Label UnrollSemInf ComplexConst = () - -instance Annotation UnrollSemInf Variable where - type Label UnrollSemInf Variable = () - --- == --- == Plugin --- == - -instance Default Bool where - def = False - -instance Combine Bool where - combine = (||) - -instance Default (Maybe SemInfPrg) where def = Nothing - - -instance Plugin UnrollPlugin where - type ExternalInfo UnrollPlugin = UnrollStrategy - executePlugin UnrollPlugin ei p = case ei of - NoUnroll -> p - Unroll unrollCount -> result $ transform Unroll_2 () Nothing $ result $ transform Unroll_1 () unrollCount p - -data UnrollPlugin = UnrollPlugin -instance Transformation UnrollPlugin where - type From UnrollPlugin = () - type To UnrollPlugin = () - type Down UnrollPlugin = () - type Up UnrollPlugin = () - type State UnrollPlugin = () - -data Unroll_1 = Unroll_1 -instance Transformation Unroll_1 where - type From Unroll_1 = () - type To Unroll_1 = UnrollSemInf - type Down Unroll_1 = Int - type Up Unroll_1 = Bool - type State Unroll_1 = () - -instance Transformable Unroll_1 Program where - transform t s d p@(ParLoop _ _ _ _ _ _) - | up tr == False && unrollPossible = tr' - | otherwise = tr - where - tr = defaultTransform t s d p - tr' = tr - { result = (result tr) - { pLoopStep = d - , pLoopBlock = loopCore - { locals = unrollDecls - , blockBody = Sequence prgs () Nothing - } - } - , up = True - } - prgs = map (\(i,p) -> p{ programLabel = (Just $ SemInfPrg i varNames loopCounter) }) $ zip [0,1..] replPrg - replPrg = replicate d $ blockBody loopCore - unrollDecls = concat $ map (\(i,ds) -> renameDecls ds i) $ zip [0,1..] replDecls - renameDecls ds i = map (\d -> renameDeclaration d ((getVarNameDecl d) ++ "_u" ++ (show i))) ds - replDecls = replicate d $ locals loopCore - loopCore = pLoopBlock $ result tr - loopBound = pLoopBound $ result tr - loopCounter = varName $ pLoopCounter $ result tr - varNames = map (\d -> getVarNameDecl d) $ locals loopCore - unrollPossible = case loopBound of - (ConstExpr (IntConst i _ _ _) _) -> mod i (toInteger d) == 0 - _ -> False - transform t s d p = defaultTransform t s d p - - -data Unroll_2 = Unroll_2 -instance Transformation Unroll_2 where - type From Unroll_2 = UnrollSemInf - type To Unroll_2 = () - type Down Unroll_2 = Maybe SemInfPrg - type Up Unroll_2 = () - type State Unroll_2 = () - -instance Transformable Unroll_2 Program where - transform t s d p = defaultTransform t s d' p where - d' = case programLabel p of - Nothing -> d - x -> x - -instance Transformable Unroll_2 Expression where - transform t s d l = case d of - Nothing -> tr - Just x -> case l of - VarExpr n _ - | varName n == loopVar x -> tr - { result = FunctionCall - { function = Function - { funName = "+" - , returnType = NumType Signed S32 - , funMode = Infix - } - , funCallParams = - [ result tr - , ConstExpr (IntConst (toInteger $ position x) (NumType Signed S32) () ()) () - ] - , funCallLabel = () - , exprLabel = () - } - } - | otherwise -> tr - _ -> tr - where - tr = defaultTransform t s d l - - -instance Transformable Unroll_2 Variable where - transform t s d v = case d of - Just x - | (varName v) `elem` (varNames x) -> tr - { result = (result tr) - { varName = (varName v) ++ "_u" ++ (show $ position x) - , varLabel = () - } - } - | otherwise -> tr - Nothing -> tr - where - tr = defaultTransform t s d v - - --- helper functions : -isJust (Just x) = True -isJust _ = False -getVarNameDecl d = varName $ declVar d -renameDeclaration d n = d { declVar = renameVariable (declVar d) n } -renameVariable v n = v { varName = n } - diff --git a/Feldspar/Compiler/Imperative/Representation.hs b/Feldspar/Compiler/Imperative/Representation.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/Representation.hs +++ /dev/null @@ -1,571 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE TypeFamilies, UndecidableInstances, OverlappingInstances #-} -module Feldspar.Compiler.Imperative.Representation where - -import Data.Typeable -import qualified Data.List as List (find) - -import Feldspar.Compiler.Error - --- =============================================================================================== --- == Class defining semantic information attached to different nodes in the imperative program == --- =============================================================================================== - -class Annotation t s where - type Label t s - -instance Annotation () s where - type Label () s = () - --- ================================================= --- == Data stuctures to store imperative programs == --- ================================================= - -data Module t = Module - { entities :: [Entity t] - , moduleLabel :: Label t Module - } - deriving Typeable - -deriving instance (ShowLabel t) => Show (Module t) -deriving instance (EqLabel t) => Eq (Module t) - -data Entity t - = StructDef - { structName :: String - , structMembers :: [StructMember t] - , structLabel :: Label t Struct - , definitionLabel :: Label t Entity - } - | ProcDef - { procName :: String - , inParams :: [Variable t] - , outParams :: [Variable t] - , procBody :: Block t - , procDefLabel :: Label t ProcDef - , definitionLabel :: Label t Entity - } - | ProcDecl - { procName :: String - , inParams :: [Variable t] - , outParams :: [Variable t] - , procDeclLabel :: Label t ProcDecl - , definitionLabel :: Label t Entity - } - deriving Typeable - -deriving instance (ShowLabel t) => Show (Entity t) -deriving instance (EqLabel t) => Eq (Entity t) - -data StructMember t = StructMember - { structMemberName :: String - , structMemberType :: Type - , structMemberLabel :: Label t StructMember - } - deriving Typeable - -deriving instance (ShowLabel t) => Show (StructMember t) -deriving instance (EqLabel t) => Eq (StructMember t) - -data Block t = Block - { locals :: [Declaration t] - , blockBody :: Program t - , blockLabel :: Label t Block - } - deriving Typeable - -deriving instance (ShowLabel t) => Show (Block t) -deriving instance (EqLabel t) => Eq (Block t) - -data Program t - = Empty - { emptyLabel :: Label t Empty - , programLabel :: Label t Program - } - | Comment - { isBlockComment :: Bool - , commentValue :: String - , commentLabel :: Label t Comment - , programLabel :: Label t Program - } - | Assign - { lhs :: Expression t - , rhs :: Expression t - , assignLabel :: Label t Assign - , programLabel :: Label t Program - } - | ProcedureCall - { procCallName :: String - , procCallParams :: [ActualParameter t] - , procCallLabel :: Label t ProcedureCall - , programLabel :: Label t Program - } - | Sequence - { sequenceProgs :: [Program t] - , sequenceLabel :: Label t Sequence - , programLabel :: Label t Program - } - | Branch - { branchCond :: Expression t - , thenBlock :: Block t - , elseBlock :: Block t - , branchLabel :: Label t Branch - , programLabel :: Label t Program - } - | SeqLoop - { sLoopCond :: Expression t - , sLoopCondCalc :: Block t - , sLoopBlock :: Block t - , sLoopLabel :: Label t SeqLoop - , programLabel :: Label t Program - } - | ParLoop - { pLoopCounter :: Variable t - , pLoopBound :: Expression t - , pLoopStep :: Int - , pLoopBlock :: Block t - , pLoopLabel :: Label t ParLoop - , programLabel :: Label t Program - } - | BlockProgram - { blockProgram :: Block t - , programLabel :: Label t Program - } - deriving Typeable - -deriving instance (ShowLabel t) => Show (Program t) -deriving instance (EqLabel t) => Eq (Program t) - -data ActualParameter t - = In - { inParam :: Expression t - , actParamLabel :: Label t ActualParameter - } - | Out - { outParam :: Expression t - , actParamLabel :: Label t ActualParameter - } - deriving Typeable - -deriving instance (ShowLabel t) => Show (ActualParameter t) -deriving instance (EqLabel t) => Eq (ActualParameter t) - -data Declaration t = Declaration - { declVar :: Variable t - , initVal :: Maybe (Expression t) - , declLabel :: Label t Declaration - } - deriving Typeable - -deriving instance (ShowLabel t) => Show (Declaration t) -deriving instance (EqLabel t) => Eq (Declaration t) - -data Expression t - = VarExpr - { var :: Variable t - , exprLabel :: Label t Expression - } - | ArrayElem - { array :: Expression t - , arrayIndex :: Expression t - , arrayLabel :: Label t ArrayElem - , exprLabel :: Label t Expression - } - | StructField - { struct :: Expression t - , fieldName :: String - , structFieldLabel :: Label t StructField - , exprLabel :: Label t Expression - } - | ConstExpr - { constExpr :: Constant t - , exprLabel :: Label t Expression - } - | FunctionCall - { function :: Function - , funCallParams :: [Expression t] - , funCallLabel :: Label t FunctionCall - , exprLabel :: Label t Expression - } - | Cast - { castType :: Type - , castExpr :: Expression t - , castLabel :: Label t Cast - , exprLabel :: Label t Expression - } - | SizeOf - { sizeOf :: Either Type (Expression t) - , sizeOfLabel :: Label t SizeOf - , exprLabel :: Label t Expression - } - deriving Typeable - -deriving instance (ShowLabel t) => Show (Expression t) -deriving instance (EqLabel t) => Eq (Expression t) - -data Function = Function { - funName :: String - , returnType :: Type - , funMode :: FunctionMode -} deriving (Eq, Show) - -data Constant t - = IntConst - { intValue :: Integer - , intType :: Type - , intConstLabel :: Label t IntConst - , constLabel :: Label t Constant - } - | FloatConst - { floatValue :: Double - , floatConstLabel :: Label t FloatConst - , constLabel :: Label t Constant - } - | BoolConst - { boolValue :: Bool - , boolConstLabel :: Label t BoolConst - , constLabel :: Label t Constant - } - -- | ArrayConst - -- { arrayValues :: [Constant t] - -- , arrayConstLabel :: Label t ArrayConst - -- , constLabel :: Label t Constant - -- } - | ComplexConst - { realPartComplexValue :: Constant t - , imagPartComplexValue :: Constant t - , complexConstLabel :: Label t ComplexConst - , constLabel :: Label t Constant - } - deriving Typeable - -deriving instance (ShowLabel t) => Show (Constant t) -deriving instance (EqLabel t) => Eq (Constant t) - -data Variable t = Variable - { varName :: String - , varType :: Type - , varRole :: VariableRole - , varLabel :: Label t Variable - } - deriving Typeable - -deriving instance (ShowLabel t) => Show (Variable t) -deriving instance (EqLabel t) => Eq (Variable t) - --- ====================== --- == Basic structures == --- ====================== - -data Length = - LiteralLen Int - | UndefinedLen - deriving (Eq,Show) - -data Size = S8 | S16 | S32 | S40 | S64 - deriving (Eq,Show) - -data Signedness = Signed | Unsigned - deriving (Eq,Show) - -data Type = - VoidType - | BoolType - | BitType - | FloatType - | NumType Signedness Size - | ComplexType Type - | UserType String - | ArrayType Length Type - | StructType [(String, Type)] - deriving (Eq,Show) - -data FunctionMode = Prefix | Infix - deriving (Eq,Show) - -data VariableRole = Value | Pointer - deriving (Eq,Show) - ----------------------- --- Type inference -- ----------------------- - -class HasType a where - type TypeOf a - typeof :: a -> TypeOf a - -instance HasType (Variable t) where - type TypeOf (Variable t) = Type - typeof (Variable r t s _) = t - -instance (ShowLabel t) => HasType (Constant t) where - type TypeOf (Constant t) = Type - typeof (IntConst _ t _ _) = t - typeof (FloatConst _ _ _) = FloatType - typeof (BoolConst _ _ _) = BoolType - typeof (ComplexConst r i _ _) = ComplexType (typeof r) - -instance (ShowLabel t) => HasType (Expression t) where - type TypeOf (Expression t) = Type - typeof (VarExpr v _) = typeof v - typeof (ArrayElem n i _ _) = decrArrayDepth (typeof n) - where - decrArrayDepth :: Type -> Type - decrArrayDepth (ArrayType _ t) = t - decrArrayDepth t = reprError InternalError $ "Non-array variable is indexed! " ++ show t - typeof (StructField s f _ _) = getStructFieldType f (typeof s) - where - getStructFieldType :: String -> Type -> Type - getStructFieldType f (StructType l) = case List.find (\(a,_) -> a == f) l of - Just (_,t) -> t - Nothing -> structFieldNotFound f - getStructFieldType f t = reprError InternalError $ - "Trying to get a struct field from not a struct typed expression\n" ++ "Field: " ++ f ++ "\nType: " ++ show t - structFieldNotFound f = reprError InternalError $ "Not found struct field with this name: " ++ f - typeof (ConstExpr c _) = typeof c - typeof (FunctionCall f p _ _) = returnType f - typeof (Cast t e _ _) = t - typeof (SizeOf s _ _) = NumType Signed S32 - -instance (ShowLabel t) => HasType (ActualParameter t) where - type TypeOf (ActualParameter t) = Type - typeof (In e _) = typeof e - typeof (Out l _) = typeof l - -reprError = handleError "Feldspar.Compiler.Imperative.Representation" - --- ===================== --- == Technical types == --- ===================== - -data Struct t -data ProcDef t -data ProcDecl t -data Empty t -data Comment t -data Assign t -data ProcedureCall t -data Sequence t -data Branch t -data SeqLoop t -data ParLoop t -data FunctionCall t -data Cast t -data SizeOf t -data ArrayElem t -data StructField t -data LeftFunCall t -data IntConst t -data FloatConst t -data BoolConst t -data ArrayConst t -data ComplexConst t - --- ========================== --- == Show and Eq instance == --- ========================== - -class ( Show (Label t Module) - , Show (Label t Entity) - , Show (Label t Struct) - , Show (Label t ProcDef) - , Show (Label t ProcDecl) - , Show (Label t StructMember) - , Show (Label t Block) - , Show (Label t Program) - , Show (Label t Empty) - , Show (Label t Comment) - , Show (Label t Assign) - , Show (Label t ProcedureCall) - , Show (Label t Sequence) - , Show (Label t Branch) - , Show (Label t SeqLoop) - , Show (Label t ParLoop) - , Show (Label t ActualParameter) - , Show (Label t Declaration) - , Show (Label t Expression) - , Show (Label t FunctionCall) - , Show (Label t Cast) - , Show (Label t SizeOf) - , Show (Label t ArrayElem) - , Show (Label t StructField) - , Show (Label t Constant) - , Show (Label t IntConst) - , Show (Label t FloatConst) - , Show (Label t BoolConst) - , Show (Label t ArrayConst) - , Show (Label t ComplexConst) - , Show (Label t Variable) - ) => ShowLabel t - -instance ( Show (Label t Module) - , Show (Label t Entity) - , Show (Label t Struct) - , Show (Label t ProcDef) - , Show (Label t ProcDecl) - , Show (Label t StructMember) - , Show (Label t Block) - , Show (Label t Program) - , Show (Label t Empty) - , Show (Label t Comment) - , Show (Label t Assign) - , Show (Label t ProcedureCall) - , Show (Label t Sequence) - , Show (Label t Branch) - , Show (Label t SeqLoop) - , Show (Label t ParLoop) - , Show (Label t ActualParameter) - , Show (Label t Declaration) - , Show (Label t Expression) - , Show (Label t FunctionCall) - , Show (Label t Cast) - , Show (Label t SizeOf) - , Show (Label t ArrayElem) - , Show (Label t StructField) - , Show (Label t Constant) - , Show (Label t IntConst) - , Show (Label t FloatConst) - , Show (Label t BoolConst) - , Show (Label t ArrayConst) - , Show (Label t ComplexConst) - , Show (Label t Variable) - ) => ShowLabel t - -class ( Eq (Label t Module) - , Eq (Label t Entity) - , Eq (Label t Struct) - , Eq (Label t ProcDef) - , Eq (Label t ProcDecl) - , Eq (Label t StructMember) - , Eq (Label t Block) - , Eq (Label t Program) - , Eq (Label t Empty) - , Eq (Label t Comment) - , Eq (Label t Assign) - , Eq (Label t ProcedureCall) - , Eq (Label t Sequence) - , Eq (Label t Branch) - , Eq (Label t SeqLoop) - , Eq (Label t ParLoop) - , Eq (Label t ActualParameter) - , Eq (Label t Declaration) - , Eq (Label t Expression) - , Eq (Label t FunctionCall) - , Eq (Label t Cast) - , Eq (Label t SizeOf) - , Eq (Label t StructField) - , Eq (Label t ArrayElem) - , Eq (Label t Constant) - , Eq (Label t IntConst) - , Eq (Label t FloatConst) - , Eq (Label t BoolConst) - , Eq (Label t ArrayConst) - , Eq (Label t ComplexConst) - , Eq (Label t Variable) - ) => EqLabel t - -instance ( Eq (Label t Module) - , Eq (Label t Entity) - , Eq (Label t Struct) - , Eq (Label t ProcDef) - , Eq (Label t ProcDecl) - , Eq (Label t StructMember) - , Eq (Label t Block) - , Eq (Label t Program) - , Eq (Label t Empty) - , Eq (Label t Comment) - , Eq (Label t Assign) - , Eq (Label t ProcedureCall) - , Eq (Label t Sequence) - , Eq (Label t Branch) - , Eq (Label t SeqLoop) - , Eq (Label t ParLoop) - , Eq (Label t ActualParameter) - , Eq (Label t Declaration) - , Eq (Label t Expression) - , Eq (Label t FunctionCall) - , Eq (Label t Cast) - , Eq (Label t SizeOf) - , Eq (Label t StructField) - , Eq (Label t ArrayElem) - , Eq (Label t Constant) - , Eq (Label t IntConst) - , Eq (Label t FloatConst) - , Eq (Label t BoolConst) - , Eq (Label t ArrayConst) - , Eq (Label t ComplexConst) - , Eq (Label t Variable) - ) => EqLabel t - --- * Set and get labels - -class Labeled c where - label :: c t -> Label t c - setLabel :: c t -> Label t c -> c t - -instance Labeled Module where - label = moduleLabel - setLabel c lab = c{ moduleLabel = lab } - -instance Labeled Entity where - label = definitionLabel - setLabel c lab = c{ definitionLabel = lab } - -instance Labeled Program where - label = programLabel - setLabel c lab = c{ programLabel = lab } - -instance Labeled Declaration where - label = declLabel - setLabel c lab = c{ declLabel = lab } - -instance Labeled Constant where - label = constLabel - setLabel c lab = c{ constLabel = lab } - -instance Labeled StructMember where - label = structMemberLabel - setLabel c lab = c{ structMemberLabel = lab } - -instance Labeled Variable where - label = varLabel - setLabel c lab = c{ varLabel = lab } - -instance Labeled Expression where - label = exprLabel - setLabel c lab = c{ exprLabel = lab } - -instance Labeled ActualParameter where - label = actParamLabel - setLabel c lab = c{ actParamLabel = lab } - -instance Labeled Block where - label = blockLabel - setLabel c lab = c{ blockLabel = lab } diff --git a/Feldspar/Compiler/Imperative/TransformationInstance.hs b/Feldspar/Compiler/Imperative/TransformationInstance.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/TransformationInstance.hs +++ /dev/null @@ -1,171 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE UndecidableInstances, OverlappingInstances #-} - -module Feldspar.Compiler.Imperative.TransformationInstance where - - -import Feldspar.Transformation.Framework -import Feldspar.Compiler.Imperative.Representation - --- ========================================= --- == Classes for the plugin architecture == --- ========================================= - --- class to simplify contexts -class (Transformation t, Convert (Label (From t) s) (Label (To t) s), Default (Label (To t) s)) => Conversion t s - -instance (Transformation t, Convert (Label (From t) s) (Label (To t) s), Default (Label (To t) s)) => Conversion t s - --- ==================== --- == Transformation == --- ==================== - -instance (Transformable1 t [] Entity, Conversion t Module) - => DefaultTransformable t Module where - defaultTransform t s d (Module m inf) = Result (Module (result1 tr) $ convert inf) (state1 tr) (up1 tr) where - tr = transform1 t s d m - -instance (Transformable1 t [] StructMember, Transformable1 t [] Variable, Transformable t Block, Transformable t Declaration, Conversion t Entity, Conversion t Struct, Conversion t ProcDef, Conversion t ProcDecl) - => DefaultTransformable t Entity where - defaultTransform t s d (StructDef n m inf1 inf2) = - Result (StructDef n (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where - tr = transform1 t s d m - defaultTransform t s d (ProcDef n i o p inf1 inf2) = - Result (ProcDef n (result1 tr1) (result1 tr2) (result tr3) (convert inf1) $ convert inf2) - (state tr3) (foldl combine (up1 tr1) [up1 tr2, up tr3]) where - tr1 = transform1 t s d i - tr2 = transform1 t (state1 tr1) d o - tr3 = transform t (state1 tr2) d p - defaultTransform t s d (ProcDecl name inp outp inf1 inf2) = - Result (ProcDecl name (result1 tr1) (result1 tr2) (convert inf1) (convert inf2)) - (state1 tr2) (foldl1 combine [up1 tr1, up1 tr2]) where - tr1 = transform1 t s d inp - tr2 = transform1 t (state1 tr1) d outp - -instance (Conversion t StructMember, Default (Up t)) - => DefaultTransformable t StructMember where - defaultTransform t s d (StructMember n typ inf) = Result (StructMember n typ $ convert inf) s def - -instance (Transformable1 t [] Declaration, Transformable t Program, Conversion t Block) - => DefaultTransformable t Block where - defaultTransform t s d (Block l b inf) = Result (Block (result1 tr1) (result tr2) $ convert inf) (state tr2) (combine (up1 tr1) (up tr2)) where - tr1 = transform1 t s d l - tr2 = transform t (state1 tr1) d b - -instance (Transformable1 t [] Program, Transformable t Expression, Transformable1 t [] ActualParameter, Transformable t Block, Transformable t Variable, Conversion t Program, Conversion t Empty, Conversion t Comment, Conversion t Assign, Conversion t ProcedureCall, Conversion t Sequence, Conversion t Branch, Conversion t SeqLoop, Conversion t ParLoop, Default (Up t)) - => DefaultTransformable t Program where - defaultTransform t s d (Empty inf1 inf2) = Result (Empty (convert inf1) $ convert inf2) s def - defaultTransform t s d (Comment b c inf1 inf2) = Result (Comment b c (convert inf1) $ convert inf2) s def - defaultTransform t s d (Assign l r inf1 inf2) = Result (Assign (result tr1) (result tr2) (convert inf1) $ convert inf2) (state tr2) (combine (up tr1) (up tr2)) where - tr1 = transform t s d l - tr2 = transform t (state tr1) d r - defaultTransform t s d (ProcedureCall f par inf1 inf2) = Result (ProcedureCall f (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where - tr = transform1 t s d par - defaultTransform t s d (Sequence p inf1 inf2) = Result (Sequence (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where - tr = transform1 t s d p - defaultTransform t s d (Branch e p1 p2 inf1 inf2) = Result (Branch (result tr1) (result tr2) (result tr3) (convert inf1) $ convert inf2) (state tr3) (foldl combine (up tr1) [up tr2, up tr3]) where - tr1 = transform t s d e - tr2 = transform t (state tr1) d p1 - tr3 = transform t (state tr2) d p2 - defaultTransform t s d (SeqLoop v c p inf1 inf2) = Result (SeqLoop (result tr1) (result tr2) (result tr3) (convert inf1) $ convert inf2) (state tr3) (foldl combine (up tr1) [up tr2, up tr3]) where - tr1 = transform t s d v - tr2 = transform t (state tr1) d c - tr3 = transform t (state tr2) d p - defaultTransform t s d (ParLoop v b i p inf1 inf2) = Result (ParLoop (result tr1) (result tr2) i (result tr3) (convert inf1) $ convert inf2) (state tr3) (foldl combine (up tr1) [up tr2, up tr3]) where - tr1 = transform t s d v - tr2 = transform t (state tr1) d b - tr3 = transform t (state tr2) d p - defaultTransform t s d (BlockProgram b inf) = Result (BlockProgram (result tr) $ convert inf) (state tr) (up tr) where - tr = transform t s d b - -instance (Transformable t Expression, Conversion t ActualParameter) - => DefaultTransformable t ActualParameter where - defaultTransform t s d (In p inf) = Result (In (result tr) $ convert inf) (state tr) (up tr) where - tr = transform t s d p - defaultTransform t s d (Out p inf) = Result (Out (result tr) $ convert inf) (state tr) (up tr) where - tr = transform t s d p - -instance (Transformable t Variable, Transformable1 t Maybe Expression, Conversion t Declaration) - => DefaultTransformable t Declaration where - defaultTransform t s d (Declaration v i inf) = Result (Declaration (result tr1) (result1 tr2) $ convert inf) (state1 tr2) (combine (up tr1) (up1 tr2)) where - tr1 = transform t s d v - tr2 = transform1 t (state tr1) d i - -instance (Transformable t Expression, Transformable t Variable, Transformable t Constant, Transformable1 t [] Expression, Conversion t Expression, Conversion t FunctionCall, Conversion t ArrayElem, Conversion t StructField, Conversion t SizeOf, Conversion t Cast, Default (Up t)) - => DefaultTransformable t Expression where - defaultTransform t s d (VarExpr v inf) = Result (VarExpr (result tr) $ convert inf) (state tr) (up tr) where - tr = transform t s d v - defaultTransform t s d (ArrayElem a i inf1 inf2) = Result (ArrayElem (result tr1) (result tr2) (convert inf1) (convert inf2)) (state tr2) (combine (up tr1) (up tr2)) where - tr1 = transform t s d a - tr2 = transform t (state tr1) d i - defaultTransform t s d (StructField l n inf1 inf2) = Result (StructField (result tr) n (convert inf1) $ convert inf2) (state tr) (up tr) where - tr = transform t s d l - defaultTransform t s d (ConstExpr c inf) = Result (ConstExpr (result tr) $ convert inf) (state tr) (up tr) where - tr = transform t s d c - defaultTransform t s d (FunctionCall f par inf1 inf2) = - Result (FunctionCall f (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where - tr = transform1 t s d par - defaultTransform t s d (Cast typ exp inf1 inf2) = Result (Cast typ (result tr) (convert inf1) $ convert inf2) (state tr) (up tr) where - tr = transform t s d exp - defaultTransform t s d (SizeOf par inf1 inf2) = case par of - Left typ -> Result (SizeOf (Left typ) (convert inf1) $ convert inf2) s def - Right exp -> Result (SizeOf (Right $ result tr) (convert inf1) $ convert inf2) (state tr) (up tr) where - tr = transform t s d exp - -instance (Transformable t Constant, Transformable1 t [] Constant, Conversion t Constant, Conversion t IntConst, Conversion t FloatConst, Conversion t BoolConst, Conversion t ArrayConst, Conversion t ComplexConst, Default (Up t)) - => DefaultTransformable t Constant where - defaultTransform t s d (IntConst c typ inf1 inf2) = Result (IntConst c typ (convert inf1) $ convert inf2) s def - defaultTransform t s d (FloatConst c inf1 inf2) = Result (FloatConst c (convert inf1) $ convert inf2) s def - defaultTransform t s d (BoolConst c inf1 inf2) = Result (BoolConst c (convert inf1) $ convert inf2) s def - -- defaultTransform t s d (ArrayConst c inf1 inf2) = Result (ArrayConst (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where - -- tr = transform1 t s d c - defaultTransform t s d (ComplexConst re im inf1 inf2) = Result (ComplexConst (result tr1) (result tr2) (convert inf1) $ convert inf2) (state tr2) (combine (up tr1) $ up tr2) where - tr1 = transform t s d re - tr2 = transform t (state tr1) d im - -instance (Conversion t Variable, Default (Up t)) - => DefaultTransformable t Variable where - defaultTransform t s d (Variable name typ role inf) = Result (Variable name typ role $ convert inf) s def - - -instance (Transformable t a, Default (Up t), Combine (Up t)) - => DefaultTransformable1 t [] a where - defaultTransform1 t s d [] = Result1 [] s def - defaultTransform1 t s d [x] = Result1 [result tr] (state tr) (up tr) where - tr = transform t s d x - defaultTransform1 t s d (x:xs) = Result1 ((result tr1):(result1 tr2)) (state1 tr2) (combine (up tr1) (up1 tr2)) where - tr1 = transform t s d x - tr2 = transform1 t (state tr1) d xs - -instance (Transformable t a, Default (Up t)) - => DefaultTransformable1 t Maybe a where - defaultTransform1 t s d Nothing = Result1 Nothing s def - defaultTransform1 t s d (Just x) = Result1 (Just $ result tr) (state tr) (up tr) where - tr = transform t s d x diff --git a/Feldspar/NameExtractor.hs b/Feldspar/NameExtractor.hs deleted file mode 100644 --- a/Feldspar/NameExtractor.hs +++ /dev/null @@ -1,147 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -module Feldspar.NameExtractor where - -import System.IO -import System.IO.Unsafe -import Language.Haskell.Exts -import Feldspar.Compiler.Error -import Feldspar.Compiler.Backend.C.Library - -data OriginalFunctionSignature = OriginalFunctionSignature { - originalFunctionName :: String, - originalParameterNames :: [Maybe String] -} deriving (Show, Eq) - -nameExtractorError errorClass msg = handleError "NameExtractor" errorClass msg - -neutralName = "\\"++(r 4)++"/\\"++(r 7)++"\n ) ( ')"++(r 6)++"\n( / )"++(r 7)++"\n \\(__)|" - where r n = replicate n ' ' - -ignore = OriginalFunctionSignature neutralName [] - -warning msg retval = unsafePerformIO $ do - withColor Yellow $ putStrLn $ "Warning: " ++ msg - return retval - --- Module SrcLoc ModuleName [OptionPragma] (Maybe WarningText) (Maybe [ExportSpec]) [ImportDecl] [Decl] -stripModule x = case x of - Module a b c d e f g -> g - -stripFunBind :: Decl -> OriginalFunctionSignature -stripFunBind x = case x of - FunBind [Match a b c d e f] -> - OriginalFunctionSignature (stripName b) (map stripPattern c) -- going for name and parameter list - -- "Match SrcLoc Name [Pat] (Maybe Type) Rhs Binds" - FunBind l@((Match a b c d e f):rest) | length l > 1 -> warning - ("Ignoring function " ++ (stripName b) ++ - ": multi-pattern function definitions are not compilable as Feldspar functions.") ignore - PatBind a b c d e -> case stripPattern b of - Just functionName -> OriginalFunctionSignature functionName [] -- parameterless declarations (?) - Nothing -> nameExtractorError InternalError ("Unsupported pattern binding: " ++ show b) - TypeSig a b c -> ignore --head b -- we don't need the type signature (yet) - DataDecl a b c d e f g -> ignore - InstDecl a b c d e -> ignore - -- TypeDecl SrcLoc Name [TyVarBind] Type - TypeDecl a b c d -> ignore - unknown -> nameExtractorError InternalError ("Unexpected language element [SFB/1]: " ++ show unknown - ++ "\nPlease file a feature request with an example attached.") - -stripPattern :: Pat -> Maybe String -stripPattern (PVar x) = Just $ stripName x -stripPattern PWildCard = Nothing -stripPattern (PAsPat x _) = Just $ stripName x -stripPattern (PParen pattern) = stripPattern pattern -stripPattern _ = Nothing - -stripName :: Name -> String -stripName (Ident a) = a -stripName (Symbol a) = a - -stripModule2 (Module a b c d e f g) = b - -stripModuleName (ModuleName x) = x - -getModuleName :: FilePath -> String -> String -- filename, filecontents -> modulename -getModuleName fileName = stripModuleName . stripModule2 . fromParseResult . customizedParse fileName - -usedExtensions = glasgowExts ++ [ExplicitForall] - --- Ultimate debug function -getParseOutput fileName = parseFileWithMode (defaultParseMode { extensions = usedExtensions }) fileName - -customizedParse fileName = parseFileContentsWithMode - (defaultParseMode - { extensions = usedExtensions - , parseFilename = fileName - }) - -getFullDeclarationListWithParameterList :: FilePath -> String -> [OriginalFunctionSignature] -getFullDeclarationListWithParameterList fileName fileContents = - map stripFunBind (stripModule $ fromParseResult $ customizedParse fileName fileContents ) - -functionNameNeeded :: String -> Bool -functionNameNeeded functionName = (functionName /= neutralName) - -stripUnnecessary :: [String] -> [String] -stripUnnecessary = filter functionNameNeeded - -printDeclarationList fileName = do - handle <- openFile fileName ReadMode - fileContents <- hGetContents handle - return $ getDeclarationList fileContents - -printDeclarationListWithParameterList fileName = do - handle <- openFile fileName ReadMode - fileContents <- hGetContents handle - putStrLn $ show $ filter (functionNameNeeded . originalFunctionName) (getFullDeclarationListWithParameterList fileName fileContents) - -printParameterListOfFunction :: FilePath -> String -> IO [Maybe String] -printParameterListOfFunction fileName functionName = getParameterList fileName functionName - --- The interface -getDeclarationList :: FilePath -> String -> [String] -- filename, filecontents -> Stringlist -getDeclarationList fileName = stripUnnecessary . (map originalFunctionName) . getFullDeclarationListWithParameterList fileName - -getExtendedDeclarationList :: FilePath -> String -> [OriginalFunctionSignature] -- filename, filecontents -> ExtDeclList -getExtendedDeclarationList fileName fileContents = - filter (functionNameNeeded . originalFunctionName) - (getFullDeclarationListWithParameterList fileName fileContents) - -getParameterListOld :: FilePath -> String -> String -> [Maybe String] -getParameterListOld fileName fileContents funName = originalParameterNames $ head $ - filter ((==funName) . originalFunctionName) - (getExtendedDeclarationList fileName fileContents) - -getParameterList :: FilePath -> String -> IO [Maybe String] -getParameterList fileName funName = do - handle <- openFile fileName ReadMode - fileContents <- hGetContents handle - return $ originalParameterNames $ head $ - filter ((==funName) . originalFunctionName) (getExtendedDeclarationList fileName fileContents) diff --git a/Feldspar/Transformation.hs b/Feldspar/Transformation.hs deleted file mode 100644 --- a/Feldspar/Transformation.hs +++ /dev/null @@ -1,49 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE TypeFamilies, FlexibleContexts, Rank2Types #-} - -module Feldspar.Transformation - ( module Feldspar.Transformation - , module Feldspar.Transformation.Framework - , module Feldspar.Compiler.Imperative.TransformationInstance - , module Feldspar.Compiler.Imperative.Representation - ) where - -import Feldspar.Transformation.Framework -import Feldspar.Compiler.Imperative.TransformationInstance -import Feldspar.Compiler.Imperative.Representation - --- ================================================================================================ --- == Plugin class --- ================================================================================================ - - -class (Transformable t Module) => Plugin t where - type ExternalInfo t - executePlugin :: t -> ExternalInfo t -> Module (From t) -> Module (To t) diff --git a/Feldspar/Transformation/Framework.hs b/Feldspar/Transformation/Framework.hs deleted file mode 100644 --- a/Feldspar/Transformation/Framework.hs +++ /dev/null @@ -1,140 +0,0 @@ --- --- Copyright (c) 2009-2011, ERICSSON AB --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" --- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE --- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE --- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, --- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- - -{-# LANGUAGE OverlappingInstances, UndecidableInstances, StandaloneDeriving #-} - -module Feldspar.Transformation.Framework where - -import Feldspar.Compiler.Error -import Feldspar.Compiler.Imperative.Representation - -transformationError = handleError "PluginArch/TransformationFramework" InternalError - --- =========== --- == Utils == --- =========== - -class Default t where - def :: t - def = transformationError "Default value requested." - -class Combine t where - combine :: t -> t -> t - combine = transformationError "Default combination function used." - -class Convert a b where - convert :: a -> b - -instance Default () where - def = () - -instance Default [a] where - def = [] - -instance Default Int where - def = 0 - -instance (Default a, Default b) => Default (a,b) where - def = (def, def) - -instance (Default a, Default b, Default c) => Default (a,b,c) where - def = (def, def, def) - -instance Combine () where - combine _ _ = () - -instance Combine String where - combine s1 s2 = s1 ++ s2 - -instance Combine Int where - combine i1 i2 = i1 + i2 - -instance (Combine a, Combine b) - => Combine (a,b) where - combine (x,y) (v,w) = (combine x v, combine y w) - -instance Default b => Convert a b where - convert _ = def - --- ============================= --- == TransformationFramework == --- ============================= - -class (Default (Up t), Combine (Up t)) - => Transformation t where - type From t - type To t - - type State t - type Down t - type Up t - -data (Transformation t) - => Result t s - = Result - { result :: s (To t) - , state :: State t - , up :: Up t - } - -deriving instance (Transformation t, Show (s (To t)), Show (State t), Show (Up t)) => Show (Result t s) - -data (Transformation t) - => Result1 t s a - = Result1 - { result1 :: s (a (To t)) - , state1 :: State t - , up1 :: Up t - } - -deriving instance (Transformation t, Show (s (b (To t))), Show (State t), Show (Up t)) => Show (Result1 t s b) - -class (Transformation t) - => Transformable t s where - transform :: t -> State t -> Down t -> s (From t) -> Result t s - -class (Transformation t) - => Transformable1 t s a where - transform1 :: t -> State t -> Down t -> s (a (From t)) -> Result1 t s a - -class (Transformation t) - => DefaultTransformable t s where - defaultTransform :: t -> State t -> Down t -> s (From t) -> Result t s - -class (Transformation t) - => DefaultTransformable1 t s a where - defaultTransform1 :: t -> State t -> Down t -> s (a (From t)) -> Result1 t s a - -instance (DefaultTransformable t s) - => Transformable t s where - transform = defaultTransform - -instance (DefaultTransformable1 t s a) - => Transformable1 t s a where - transform1 = defaultTransform1 - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,3 +1,5 @@ +Copyright (c) 2012, Emil Axelsson, Gergely Dévai, Anders Persson and + Josef Svenningsson Copyright (c) 2009-2011, ERICSSON AB All rights reserved. diff --git a/feldspar-compiler.cabal b/feldspar-compiler.cabal --- a/feldspar-compiler.cabal +++ b/feldspar-compiler.cabal @@ -1,15 +1,18 @@ name: feldspar-compiler -version: 0.5.0.1 -cabal-version: >= 1.6 +version: 0.6.0.2 +cabal-version: >= 1.14 build-type: Simple license: BSD3 license-file: LICENSE -copyright: Copyright (c) 2009-2011, ERICSSON AB +copyright: Copyright (c) 2012 Emil Axelsson, Gergely Dévai, + Anders Persson, Josef Svenningsson + Copyright (c) 2009-2011, ERICSSON AB author: Feldspar group, Eotvos Lorand University Faculty of Informatics maintainer: deva@inf.elte.hu stability: experimental -homepage: http://feldspar.inf.elte.hu/feldspar/ +homepage: https://feldspar.github.com +bug-reports: https://github.com/feldspar/feldspar-compiler/issues synopsis: Compiler for the Feldspar language description: Feldspar (**F**unctional **E**mbedded **L**anguage for **DSP** and **PAR**allelism) is an embedded DSL for describing digital @@ -19,9 +22,15 @@ language both according to ANSI C and also targeted to a real DSP HW. category: Compiler -tested-with: GHC==7.0 +tested-with: GHC==7.6.1, GHC==7.4.2 +source-repository head + type: git + location: git://github.com/feldspar/feldspar-compiler.git + library + hs-source-dirs: lib + exposed-modules: Feldspar.Compiler.Imperative.Representation Feldspar.Compiler.Imperative.FromCore @@ -30,11 +39,13 @@ Feldspar.Compiler.Imperative.FromCore.Condition Feldspar.Compiler.Imperative.FromCore.ConditionM Feldspar.Compiler.Imperative.FromCore.Error + Feldspar.Compiler.Imperative.FromCore.Future Feldspar.Compiler.Imperative.FromCore.Interpretation Feldspar.Compiler.Imperative.FromCore.Literal Feldspar.Compiler.Imperative.FromCore.Loop Feldspar.Compiler.Imperative.FromCore.Mutable Feldspar.Compiler.Imperative.FromCore.MutableToPure + Feldspar.Compiler.Imperative.FromCore.NoInline Feldspar.Compiler.Imperative.FromCore.Par Feldspar.Compiler.Imperative.FromCore.Primitive Feldspar.Compiler.Imperative.FromCore.SizeProp @@ -44,7 +55,10 @@ Feldspar.Compiler.Imperative.FromCore.Save Feldspar.Compiler.Imperative.Frontend Feldspar.Compiler.Imperative.TransformationInstance + Feldspar.Compiler.Imperative.Plugin.CollectFreeVars Feldspar.Compiler.Imperative.Plugin.ConstantFolding + Feldspar.Compiler.Imperative.Plugin.Free + Feldspar.Compiler.Imperative.Plugin.IVars Feldspar.Compiler.Imperative.Plugin.Unroll Feldspar.Compiler.Imperative.Plugin.Naming Feldspar.Compiler.Backend.C.CodeGeneration @@ -54,15 +68,10 @@ Feldspar.Compiler.Backend.C.Plugin.TypeCorrector Feldspar.Compiler.Backend.C.Plugin.TypeDefinitionGenerator Feldspar.Compiler.Backend.C.Plugin.VariableRoleAssigner - Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator Feldspar.Compiler.Backend.C.Plugin.Rule Feldspar.Compiler.Backend.C.Library Feldspar.Compiler.Backend.C.Options Feldspar.Compiler.Backend.C.Platforms - Feldspar.Compiler.Frontend.CommandLine.API.Library - Feldspar.Compiler.Frontend.CommandLine.API.Constants - Feldspar.Compiler.Frontend.CommandLine.API.Options - Feldspar.Compiler.Frontend.CommandLine.API Feldspar.Compiler.Frontend.Interactive.Interface Feldspar.Compiler.Compiler Feldspar.Compiler.Error @@ -71,21 +80,22 @@ Feldspar.Transformation.Framework Feldspar.NameExtractor + default-language: Haskell98 + build-depends: - feldspar-language == 0.5.*, + feldspar-language >= 0.6 && < 0.7, ansi-terminal, - base >= 4 && < 4.4, + base >= 4 && < 4.7, containers, - haskell-src-exts, + haskell-src-exts >= 1.12, directory, filepath, - hint, MonadCatchIO-mtl, mtl, process, - syntactic >= 0.8 + syntactic >= 1.4 && < 1.5 - extensions: + default-extensions: DeriveDataTypeable EmptyDataDecls FlexibleContexts @@ -104,11 +114,13 @@ ViewPatterns include-dirs: - ./Feldspar/C + ./lib/Feldspar/C c-sources: --- ./Feldspar/C/feldspar_c99.c --- ./Feldspar/C/feldspar_array.c +-- lib/Feldspar/C/feldspar_c99.c +-- lib/Feldspar/C/feldspar_array.c +-- lib/Feldspar/C/ivar.c +-- lib/Feldspar/C/taskpool.c cc-options: -std=c99 -Wall @@ -119,29 +131,46 @@ feldspar_c99.c feldspar_tic64x.h feldspar_tic64x.c + feldspar_future.h + log.h + ivar.h + ivar.c + taskpool.h + taskpool.c ghc-options: -fcontext-stack=100 cpp-options: -DRELEASE executable feldspar - main-is : ./Feldspar/Compiler/Frontend/CommandLine/Main.hs + hs-source-dirs: src + main-is : Feldspar/Compiler/Frontend/CommandLine/Main.hs + + default-language: Haskell98 + + other-modules: + Feldspar.Compiler.Frontend.CommandLine.API.Library + Feldspar.Compiler.Frontend.CommandLine.API.Constants + Feldspar.Compiler.Frontend.CommandLine.API.Options + Feldspar.Compiler.Frontend.CommandLine.API + build-depends: --- feldspar-language == 0.5.*, --- syntactic >= 0.8.*, - ansi-terminal --- base >= 4 && < 4.4, --- mtl, --- hint, --- process, --- filepath, --- directory, --- containers, --- haskell-src-exts, --- MonadCatchIO-mtl + feldspar-language >= 0.6 && < 0.7, + feldspar-compiler, + syntactic >= 1.4 && < 1.5, + base >= 4 && < 4.7, + hint, + MonadCatchIO-mtl, + mtl, + directory, + filepath, + process, + ansi-terminal, + containers, + haskell-src-exts >= 1.12 - extensions: + default-extensions: CPP DeriveDataTypeable EmptyDataDecls @@ -163,3 +192,4 @@ ghc-options: -fcontext-stack=100 cpp-options: -DRELEASE + diff --git a/lib/Feldspar/C/feldspar_array.c b/lib/Feldspar/C/feldspar_array.c new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/feldspar_array.c @@ -0,0 +1,61 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#include "feldspar_array.h" +#include +#include +#include +//#define LOG +#include "log.h" + +unsigned int feldspar_array_linker_hook = 0xDECAFBAD; + +/* Deep array copy with a given length */ +void copyArrayLen(struct array *to, struct array *from, int32_t len) +{ + assert(to); + assert(from); + log_3("copyArrayLen %p %p %d - enter\n", to, from, len); + if( from->elemSize < 0 ) + { + unsigned i; + log_3("copyArrayLen %p %p %d - nested\n", to, from, len); + for( i = 0; i < len; ++i ) + copyArray( &at(struct array, to, i), &at(struct array, from, i) ); + } + else + { + assert(to->buffer); + assert(from->buffer); + log_4("copyArrayLen %p %p %d - memcpy %d bytes\n", to, from, len + , len*from->elemSize); + memcpy( to->buffer, from->buffer, len * from->elemSize ); + } + log_3("copyArrayLen %p %p %d - leave\n", to, from, len); +} + diff --git a/lib/Feldspar/C/feldspar_array.h b/lib/Feldspar/C/feldspar_array.h new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/feldspar_array.h @@ -0,0 +1,225 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#ifndef FELDSPAR_ARRAY_H +#define FELDSPAR_ARRAY_H + +#include +#include +#include +#include +//#define LOG +#include "log.h" + +#include /* to be removed */ + +/* Important: Always zero-initialize struct arrays in the definitions + * and call initArray on them before use: + * + * struct array my = {0}; + * initArray( &my, sizeof(elementType), numberOfElements ); + * + * Zero initialization certifies that initArray works correctly. + * (There is a "magic number" check in initArray in case you forget to + * zero-initialize, but it is not 100% safe.) + */ + +/* TODO qualify the names to avoid clashes with Haskell names */ + +struct array +{ + void* buffer; /* pointer to the buffer of elements */ + int32_t length; /* number of elements in the array */ + int32_t elemSize; /* size of elements in bytes; (- sizeof(struct array)) for nested arrays */ + uint32_t bytes; /* The number of bytes the buffer can hold */ + uint32_t inited; /* To decide between first initialization and reinitialization - This is to catch */ +}; + +/* Magic number */ +#define INITED 0x89abcdef + +/* Indexing into an array: */ +/* Result: element of type 'type' */ +#define at(type,arr,idx) (((type*)((arr)->buffer))[idx]) + +/* Array (re)initialization */ +static inline void initArray(struct array *arr, int32_t size, int32_t len) +{ + int newBytes; + + log_3("initArray %p %d %d - enter\n", arr, size, len); + assert(arr); + arr->elemSize = size; + arr->length = len; + if( size < 0 ) + size = sizeof(struct array); + newBytes = size * len; + if( arr->buffer && (arr->inited == INITED) ) + { + // Re-initialization + log_1("initArray %p - reinitialize\n",arr); + if( arr->bytes < newBytes ) + { + log_3("initArray %p - realloc since %d < %d\n" + , arr, arr->bytes, newBytes); + // Not enough space: reallocation needed + arr->bytes = newBytes; + free(arr->buffer); + arr->buffer = (void*)malloc( newBytes ); + } + else + { + // Otherwise: space is enough, nothing to do + log_3("initArray %p - large enough %d >= %d\n" + , arr, arr->bytes, newBytes); + } + } + else + { + // First initialization + arr->bytes = newBytes; + arr->buffer = (void*)malloc( newBytes ); + log_5("initArray %p - alloc %d * %d bytes %d at %p\n" + , arr, arr->length, arr->elemSize, newBytes, arr->buffer); + arr->inited = INITED; + } + assert( arr->buffer ); + log_3("initArray %p %d %d - leave\n", arr, size, len); +} + +// Free array +// TODO: Think about arrays escaping from their scope. +static inline void freeArray(struct array *arr) +{ + log_1("freeArray %p - enter\n", arr); + // assert(arr); + // if( !arr->buffer || arr->inited != INITED ) + // { + // return; + // } + // if( arr->elemSize < 0 ) + // { + // int i; + // for( i=0; ilength; ++i ) + // freeArray( &at(struct array,arr,i) ); + // } + // free(arr->buffer); + // For the sake of extra safety: + // arr->buffer = 0; + // arr->length = 0; + // arr->bytes = 0; + // arr->inited = 0; + log_1("freeArray %p - leave\n", arr); +} + +/* Deep array copy */ +static inline void copyArray(struct array *to, struct array *from) +{ + assert(to); + assert(from); + log_2("copyArray %p %p - enter\n", to, from); + if( from->elemSize < 0 ) + { + log_2("copyArray %p %p - nested enter\n", to, from); + unsigned i; + for( i = 0; i < from->length; ++i ) + { + struct array *to_row = &at(struct array, to, i); + struct array *from_row = &at(struct array, from, i); + if( !to_row->buffer || to_row->inited != INITED ) + initArray( to_row, from_row->elemSize, from_row->length ); + copyArray( to_row, from_row ); + } + log_2("copyArray %p %p - nested leave\n", to, from); + } + else + { + assert(to->buffer); + assert(from->buffer); + log_3("copyArray %p %p - memcpy %d bytes\n", to, from + , from->length * from->elemSize); + memcpy( to->buffer, from->buffer, from->length * from->elemSize ); + } + log_2("copyArray %p %p - leave\n", to, from); +} + +/* Deep array copy to a given position */ +static inline void copyArrayPos(struct array *to, unsigned pos, struct array *from) +{ + assert(to); + assert(from); + log_3("copyArrayPos %p %d %p - enter\n", to, pos, from); + if( from->elemSize < 0 ) + { + unsigned i; + for( i = 0; i < from->length; ++i ) + copyArray( &at(struct array, to, i + pos), &at(struct array, from, i) ); + } + else + { + assert(to->buffer); + assert(from->buffer); + memcpy( (char*)(to->buffer) + pos * to->elemSize, from->buffer, from->length * from->elemSize ); + } + log_3("copyArrayPos %p %d %p - leave\n", to, pos, from); +} + + +/* Deep array copy with a given length */ +void copyArrayLen(struct array *to, struct array *from, int32_t len); + +/* Array length */ +static inline int32_t getLength(struct array *arr) +{ + assert(arr); + return arr->length; +} + +/* Reset array length */ +static inline void setLength(struct array *arr, int32_t len) +{ + assert(arr); + log_2("setLength %p %d - enter\n", arr, len); + int newBytes = arr->elemSize * len; + if( arr->bytes >= newBytes ) + { + arr->length = len; + } + else + { + log_3("setLength %p %d - realloc %d bytes\n", arr, len, newBytes); + // TODO: copy + arr->bytes = newBytes; + free( arr->buffer ); + arr->buffer = malloc( newBytes ); + assert( arr->buffer ); + } + log_2("setLength %p %d - leave\n", arr, len); +} + +#endif diff --git a/lib/Feldspar/C/feldspar_c99.c b/lib/Feldspar/C/feldspar_c99.c new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/feldspar_c99.c @@ -0,0 +1,1894 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#include "feldspar_c99.h" + +#include +#include +#include +#include +#include + +#if defined(WIN32) + #include +#else + #include + #include +#endif /* WIN32 */ + + +unsigned int feldspar_c99_linker_hook = 0xDECAFBAD; + +/*--------------------------------------------------------------------------* + * pow(), abs(), signum(), logBase() * + *--------------------------------------------------------------------------*/ + +int8_t pow_fun_int8( int8_t a, int8_t b ) +{ + int8_t r = 1; + int i; + if (b < 0) { + fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); + exit(1); + } + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +int16_t pow_fun_int16( int16_t a, int16_t b ) +{ + int16_t r = 1; + int i; + if (b < 0) { + fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); + exit(1); + } + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +int32_t pow_fun_int32( int32_t a, int32_t b ) +{ + int32_t r = 1; + int i; + if (b < 0) { + fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); + exit(1); + } + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +int64_t pow_fun_int64( int64_t a, int64_t b ) +{ + int64_t r = 1; + int i; + if (b < 0) { + fprintf(stderr, "Negative exponent in function pow_fun_(): %lld `pow` %lld", a, b); + exit(1); + } + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +uint8_t pow_fun_uint8( uint8_t a, uint8_t b ) +{ + uint8_t r = 1; + int i; + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +uint16_t pow_fun_uint16( uint16_t a, uint16_t b ) +{ + uint16_t r = 1; + int i; + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +uint32_t pow_fun_uint32( uint32_t a, uint32_t b ) +{ + uint32_t r = 1; + int i; + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +uint64_t pow_fun_uint64( uint64_t a, uint64_t b ) +{ + uint64_t r = 1; + int i; + for(i = 0; i < b; ++i) + r *= a; + return r; +} + + + +int8_t abs_fun_int8( int8_t a ) +{ + // From Bit Twiddling Hacks: + // "Compute the integer absolute value (abs) without branching" + int8_t mask = a >> 7; + return (a + mask) ^ mask; +} + +int16_t abs_fun_int16( int16_t a ) +{ + // From Bit Twiddling Hacks: + // "Compute the integer absolute value (abs) without branching" + int16_t mask = a >> 15; + return (a + mask) ^ mask; +} + +int32_t abs_fun_int32( int32_t a ) +{ + // From Bit Twiddling Hacks: + // "Compute the integer absolute value (abs) without branching" + int32_t mask = a >> 31; + return (a + mask) ^ mask; +} + +int64_t abs_fun_int64( int64_t a ) +{ + // From Bit Twiddling Hacks: + // "Compute the integer absolute value (abs) without branching" + int64_t mask = a >> 63; + return (a + mask) ^ mask; +} + + + +int8_t signum_fun_int8( int8_t a ) +{ + // From Bit Twiddling Hacks: "Compute the sign of an integer" + return (a != 0) | (a >> 7); +} + +int16_t signum_fun_int16( int16_t a ) +{ + // From Bit Twiddling Hacks: "Compute the sign of an integer" + return (a != 0) | (a >> 15); +} + +int32_t signum_fun_int32( int32_t a ) +{ + // From Bit Twiddling Hacks: "Compute the sign of an integer" + return (a != 0) | (a >> 31); +} + +int64_t signum_fun_int64( int64_t a ) +{ + // From Bit Twiddling Hacks: "Compute the sign of an integer" + return (a != 0) | (a >> 63); +} + +uint8_t signum_fun_uint8( uint8_t a ) +{ + return (a > 0); +} + +uint16_t signum_fun_uint16( uint16_t a ) +{ + return (a > 0); +} + +uint32_t signum_fun_uint32( uint32_t a ) +{ + return (a > 0); +} + +uint64_t signum_fun_uint64( uint64_t a ) +{ + return (a > 0); +} + +float signum_fun_float( float a ) +{ + // From Bit Twiddling Hacks: "Compute the sign of an integer" + return (a > 0) - (a < 0); +} + + + +float logBase_fun_float( float a, float b ) +{ + return logf(b) / logf(a); +} + + + +/*--------------------------------------------------------------------------* + * Bit operations * + *--------------------------------------------------------------------------*/ + +int8_t setBit_fun_int8( int8_t x, uint32_t i ) +{ + return x | 1 << i; +} + +int16_t setBit_fun_int16( int16_t x, uint32_t i ) +{ + return x | 1 << i; +} + +int32_t setBit_fun_int32( int32_t x, uint32_t i ) +{ + return x | 1 << i; +} + +int64_t setBit_fun_int64( int64_t x, uint32_t i ) +{ + return x | 1 << i; +} + +uint8_t setBit_fun_uint8( uint8_t x, uint32_t i ) +{ + return x | 1 << i; +} + +uint16_t setBit_fun_uint16( uint16_t x, uint32_t i ) +{ + return x | 1 << i; +} + +uint32_t setBit_fun_uint32( uint32_t x, uint32_t i ) +{ + return x | 1 << i; +} + +uint64_t setBit_fun_uint64( uint64_t x, uint32_t i ) +{ + return x | 1 << i; +} + + + +int8_t clearBit_fun_int8( int8_t x, uint32_t i ) +{ + return x & ~(1 << i); +} + +int16_t clearBit_fun_int16( int16_t x, uint32_t i ) +{ + return x & ~(1 << i); +} + +int32_t clearBit_fun_int32( int32_t x, uint32_t i ) +{ + return x & ~(1 << i); +} + +int64_t clearBit_fun_int64( int64_t x, uint32_t i ) +{ + return x & ~(1 << i); +} + +uint8_t clearBit_fun_uint8( uint8_t x, uint32_t i ) +{ + return x & ~(1 << i); +} + +uint16_t clearBit_fun_uint16( uint16_t x, uint32_t i ) +{ + return x & ~(1 << i); +} + +uint32_t clearBit_fun_uint32( uint32_t x, uint32_t i ) +{ + return x & ~(1 << i); +} + +uint64_t clearBit_fun_uint64( uint64_t x, uint32_t i ) +{ + return x & ~(1 << i); +} + + + +int8_t complementBit_fun_int8( int8_t x, uint32_t i ) +{ + return x ^ 1 << i; +} + +int16_t complementBit_fun_int16( int16_t x, uint32_t i ) +{ + return x ^ 1 << i; +} + +int32_t complementBit_fun_int32( int32_t x, uint32_t i ) +{ + return x ^ 1 << i; +} + +int64_t complementBit_fun_int64( int64_t x, uint32_t i ) +{ + return x ^ 1 << i; +} + +uint8_t complementBit_fun_uint8( uint8_t x, uint32_t i ) +{ + return x ^ 1 << i; +} + +uint16_t complementBit_fun_uint16( uint16_t x, uint32_t i ) +{ + return x ^ 1 << i; +} + +uint32_t complementBit_fun_uint32( uint32_t x, uint32_t i ) +{ + return x ^ 1 << i; +} + +uint64_t complementBit_fun_uint64( uint64_t x, uint32_t i ) +{ + return x ^ 1 << i; +} + + + +int testBit_fun_int8( int8_t x, uint32_t i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_int16( int16_t x, uint32_t i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_int32( int32_t x, uint32_t i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_int64( int64_t x, uint32_t i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_uint8( uint8_t x, uint32_t i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_uint16( uint16_t x, uint32_t i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_uint32( uint32_t x, uint32_t i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_uint64( uint64_t x, uint32_t i ) +{ + return (x & 1 << i) != 0; +} + + + +int8_t rotateL_fun_int8( int8_t x, int32_t i ) +{ + if ((i %= 8) == 0) return x; + return (x << i) | ((0x7f >> (7 - i)) & (x >> (8 - i))); +} + +int16_t rotateL_fun_int16( int16_t x, int32_t i ) +{ + if ((i %= 16) == 0) return x; + return (x << i) | ((0x7fff >> (15 - i)) & (x >> (16 - i))); +} + +int32_t rotateL_fun_int32( int32_t x, int32_t i ) +{ + if ((i %= 32) == 0) return x; + return (x << i) | ((0x7fffffff >> (31 - i)) & (x >> (32 - i))); +} + +int64_t rotateL_fun_int64( int64_t x, int32_t i ) +{ + if ((i %= 64) == 0) return x; + return (x << i) | ((0x7fffffffffffffffll >> (63 - i)) & (x >> (64 - i))); +} + +uint8_t rotateL_fun_uint8( uint8_t x, int32_t i ) +{ + if ((i %= 8) == 0) return x; + return (x << i) | (x >> (8 - i)); +} + +uint16_t rotateL_fun_uint16( uint16_t x, int32_t i ) +{ + if ((i %= 16) == 0) return x; + return (x << i) | (x >> (16 - i)); +} + +uint32_t rotateL_fun_uint32( uint32_t x, int32_t i ) +{ + if ((i %= 32) == 0) return x; + return (x << i) | (x >> (32 - i)); +} + +uint64_t rotateL_fun_uint64( uint64_t x, int32_t i ) +{ + if ((i %= 64) == 0) return x; + return (x << i) | (x >> (64 - i)); +} + + + +int8_t rotateR_fun_int8( int8_t x, int32_t i ) +{ + if ((i %= 8) == 0) return x; + return (x << (8 - i)) | ((0x7f >> (i - 1)) & (x >> i)); +} + +int16_t rotateR_fun_int16( int16_t x, int32_t i ) +{ + if ((i %= 16) == 0) return x; + return (x << (16 - i)) | ((0x7fff >> (i - 1)) & (x >> i)); +} + +int32_t rotateR_fun_int32( int32_t x, int32_t i ) +{ + if ((i %= 32) == 0) return x; + return (x << (32 - i)) | ((0x7fffffff >> (i - 1)) & (x >> i)); +} + +int64_t rotateR_fun_int64( int64_t x, int32_t i ) +{ + if ((i %= 64) == 0) return x; + return (x << (64 - i)) | ((0x7fffffffffffffffll >> (i - 1)) & (x >> i)); +} + +uint8_t rotateR_fun_uint8( uint8_t x, int32_t i ) +{ + if ((i %= 8) == 0) return x; + return (x << (8 - i)) | (x >> i); +} + +uint16_t rotateR_fun_uint16( uint16_t x, int32_t i ) +{ + if ((i %= 16) == 0) return x; + return (x << (16 - i)) | (x >> i); +} + +uint32_t rotateR_fun_uint32( uint32_t x, int32_t i ) +{ + if ((i %= 32) == 0) return x; + return (x << (32 - i)) | (x >> i); +} + +uint64_t rotateR_fun_uint64( uint64_t x, int32_t i ) +{ + if ((i %= 64) == 0) return x; + return (x << (64 - i)) | (x >> i); +} + + + +int8_t reverseBits_fun_int8( int8_t x ) +{ + int8_t r = x; + int i = 7; + for (x = x >> 1 & 0x7f; x; x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +int16_t reverseBits_fun_int16( int16_t x ) +{ + int16_t r = x; + int i = 15; + for (x = x >> 1 & 0x7fff; x; x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +int32_t reverseBits_fun_int32( int32_t x ) +{ + int32_t r = x; + int i = 31; + for (x = x >> 1 & 0x7fffffff; x; x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +int64_t reverseBits_fun_int64( int64_t x ) +{ + int64_t r = x; + int i = 63; + for (x = x >> 1 & 0x7fffffffffffffffll; x; x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +uint8_t reverseBits_fun_uint8( uint8_t x ) +{ + uint8_t r = x; + int i = 7; + while (x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +uint16_t reverseBits_fun_uint16( uint16_t x ) +{ + uint16_t r = x; + int i = 15; + while (x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +uint32_t reverseBits_fun_uint32( uint32_t x ) +{ + uint32_t r = x; + int i = 31; + while (x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +uint64_t reverseBits_fun_uint64( uint64_t x ) +{ + uint64_t r = x; + int i = 63; + while (x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + + + +uint32_t bitScan_fun_int8( int8_t x ) +{ + uint32_t r = 0; + int8_t s = (x & 0x80); + if (x == 0) return 7; + while ((int8_t)((x <<= 1) & 0x80) == s) + ++r; + return r; +} + +uint32_t bitScan_fun_int16( int16_t x ) +{ + uint32_t r = 0; + int16_t s = (x & 0x8000); + if (x == 0) return 15; + while ((int16_t)((x <<= 1) & 0x8000) == s) + ++r; + return r; +} + +uint32_t bitScan_fun_int32( int32_t x ) +{ + uint32_t r = 0; + int32_t s = (x & 0x80000000); + if (x == 0) return 31; + while ((int32_t)((x <<= 1) & 0x80000000) == s) + ++r; + return r; +} + +uint32_t bitScan_fun_int64( int64_t x ) +{ + uint32_t r = 0; + int64_t s = (x & 0x8000000000000000ll); + if (x == 0) return 63; + while ((int64_t)((x <<= 1) & 0x8000000000000000ll) == s) + ++r; + return r; +} + +uint32_t bitScan_fun_uint8( uint8_t x ) +{ + uint32_t r = 8; + while (x) + { + --r; + x >>= 1; + } + return r; +} + +uint32_t bitScan_fun_uint16( uint16_t x ) +{ + uint32_t r = 16; + while (x) + { + --r; + x >>= 1; + } + return r; +} + +uint32_t bitScan_fun_uint32( uint32_t x ) +{ + uint32_t r = 32; + while (x) + { + --r; + x >>= 1; + } + return r; +} + +uint32_t bitScan_fun_uint64( uint64_t x ) +{ + uint32_t r = 64; + while (x) + { + --r; + x >>= 1; + } + return r; +} + + + +uint32_t bitCount_fun_int8( int8_t x ) +{ + uint32_t r = x & 1; + for (x = x >> 1 & 0x7f; x; x >>= 1) + r += x & 1; + return r; +} + +uint32_t bitCount_fun_int16( int16_t x ) +{ + uint32_t r = x & 1; + for (x = x >> 1 & 0x7fff; x; x >>= 1) + r += x & 1; + return r; +} + +uint32_t bitCount_fun_int32( int32_t x ) +{ + uint32_t r = x & 1; + for (x = x >> 1 & 0x7fffffff; x; x >>= 1) + r += x & 1; + return r; +} + +uint32_t bitCount_fun_int64( int64_t x ) +{ + uint32_t r = x & 1; + for (x = x >> 1 & 0x7fffffffffffffffll; x; x >>= 1) + r += x & 1; + return r; +} + +uint32_t bitCount_fun_uint8( uint8_t x ) +{ + uint32_t r = x & 1; + while (x >>= 1) + r += x & 1; + return r; +} + +uint32_t bitCount_fun_uint16( uint16_t x ) +{ + uint32_t r = x & 1; + while (x >>= 1) + r += x & 1; + return r; +} + +uint32_t bitCount_fun_uint32( uint32_t x ) +{ + uint32_t r = x & 1; + while (x >>= 1) + r += x & 1; + return r; +} + +uint32_t bitCount_fun_uint64( uint64_t x ) +{ + uint32_t r = x & 1; + while (x >>= 1) + r += x & 1; + return r; +} + + + +/*--------------------------------------------------------------------------* + * Complex numbers * + *--------------------------------------------------------------------------*/ + +int equal_fun_complexOf_int8( complexOf_int8 a, complexOf_int8 b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_int16( complexOf_int16 a, complexOf_int16 b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_int32( complexOf_int32 a, complexOf_int32 b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_int64( complexOf_int64 a, complexOf_int64 b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_uint8( complexOf_uint8 a, complexOf_uint8 b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_uint16( complexOf_uint16 a, complexOf_uint16 b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_uint32( complexOf_uint32 a, complexOf_uint32 b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_uint64( complexOf_uint64 a, complexOf_uint64 b ) +{ + return a.re == b.re && a.im == b.im; +} + + + +complexOf_int8 negate_fun_complexOf_int8( complexOf_int8 a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_int16 negate_fun_complexOf_int16( complexOf_int16 a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_int32 negate_fun_complexOf_int32( complexOf_int32 a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_int64 negate_fun_complexOf_int64( complexOf_int64 a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_uint8 negate_fun_complexOf_uint8( complexOf_uint8 a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_uint16 negate_fun_complexOf_uint16( complexOf_uint16 a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_uint32 negate_fun_complexOf_uint32( complexOf_uint32 a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_uint64 negate_fun_complexOf_uint64( complexOf_uint64 a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + + + +complexOf_int8 abs_fun_complexOf_int8( complexOf_int8 a ) +{ + a.re = magnitude_fun_complexOf_int8(a); + a.im = 0; + return a; +} + +complexOf_int16 abs_fun_complexOf_int16( complexOf_int16 a ) +{ + a.re = magnitude_fun_complexOf_int16(a); + a.im = 0; + return a; +} + +complexOf_int32 abs_fun_complexOf_int32( complexOf_int32 a ) +{ + a.re = magnitude_fun_complexOf_int32(a); + a.im = 0; + return a; +} + +complexOf_int64 abs_fun_complexOf_int64( complexOf_int64 a ) +{ + a.re = magnitude_fun_complexOf_int64(a); + a.im = 0; + return a; +} + +complexOf_uint8 abs_fun_complexOf_uint8( complexOf_uint8 a ) +{ + a.re = magnitude_fun_complexOf_uint8(a); + a.im = 0; + return a; +} + +complexOf_uint16 abs_fun_complexOf_uint16( complexOf_uint16 a ) +{ + a.re = magnitude_fun_complexOf_uint16(a); + a.im = 0; + return a; +} + +complexOf_uint32 abs_fun_complexOf_uint32( complexOf_uint32 a ) +{ + a.re = magnitude_fun_complexOf_uint32(a); + a.im = 0; + return a; +} + +complexOf_uint64 abs_fun_complexOf_uint64( complexOf_uint64 a ) +{ + a.re = magnitude_fun_complexOf_uint64(a); + a.im = 0; + return a; +} + + + +complexOf_int8 signum_fun_complexOf_int8( complexOf_int8 a ) +{ + int8_t m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_int8(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_int16 signum_fun_complexOf_int16( complexOf_int16 a ) +{ + int16_t m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_int16(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_int32 signum_fun_complexOf_int32( complexOf_int32 a ) +{ + int32_t m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_int32(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_int64 signum_fun_complexOf_int64( complexOf_int64 a ) +{ + int64_t m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_int64(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_uint8 signum_fun_complexOf_uint8( complexOf_uint8 a ) +{ + uint8_t m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_uint8(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_uint16 signum_fun_complexOf_uint16( complexOf_uint16 a ) +{ + uint16_t m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_uint16(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_uint32 signum_fun_complexOf_uint32( complexOf_uint32 a ) +{ + uint32_t m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_uint32(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_uint64 signum_fun_complexOf_uint64( complexOf_uint64 a ) +{ + uint64_t m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_uint64(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +float complex signum_fun_complexOf_float( float complex a ) +{ + float m; + if (a == 0) { + return a; + } else { + m = cabsf(a); + return crealf(a) / m + cimagf(a) / m * I; + } +} + + + +complexOf_int8 add_fun_complexOf_int8( complexOf_int8 a, complexOf_int8 b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_int16 add_fun_complexOf_int16( complexOf_int16 a, complexOf_int16 b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_int32 add_fun_complexOf_int32( complexOf_int32 a, complexOf_int32 b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_int64 add_fun_complexOf_int64( complexOf_int64 a, complexOf_int64 b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_uint8 add_fun_complexOf_uint8( complexOf_uint8 a, complexOf_uint8 b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_uint16 add_fun_complexOf_uint16( complexOf_uint16 a, complexOf_uint16 b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_uint32 add_fun_complexOf_uint32( complexOf_uint32 a, complexOf_uint32 b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_uint64 add_fun_complexOf_uint64( complexOf_uint64 a, complexOf_uint64 b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + + + +complexOf_int8 sub_fun_complexOf_int8( complexOf_int8 a, complexOf_int8 b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_int16 sub_fun_complexOf_int16( complexOf_int16 a, complexOf_int16 b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_int32 sub_fun_complexOf_int32( complexOf_int32 a, complexOf_int32 b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_int64 sub_fun_complexOf_int64( complexOf_int64 a, complexOf_int64 b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_uint8 sub_fun_complexOf_uint8( complexOf_uint8 a, complexOf_uint8 b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_uint16 sub_fun_complexOf_uint16( complexOf_uint16 a, complexOf_uint16 b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_uint32 sub_fun_complexOf_uint32( complexOf_uint32 a, complexOf_uint32 b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_uint64 sub_fun_complexOf_uint64( complexOf_uint64 a, complexOf_uint64 b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + + + +complexOf_int8 mult_fun_complexOf_int8( complexOf_int8 a, complexOf_int8 b ) +{ + complexOf_int8 r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_int16 mult_fun_complexOf_int16( complexOf_int16 a, complexOf_int16 b ) +{ + complexOf_int16 r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_int32 mult_fun_complexOf_int32( complexOf_int32 a, complexOf_int32 b ) +{ + complexOf_int32 r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_int64 mult_fun_complexOf_int64( complexOf_int64 a, complexOf_int64 b ) +{ + complexOf_int64 r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_uint8 mult_fun_complexOf_uint8( complexOf_uint8 a, complexOf_uint8 b ) +{ + complexOf_uint8 r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_uint16 mult_fun_complexOf_uint16( complexOf_uint16 a, complexOf_uint16 b ) +{ + complexOf_uint16 r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_uint32 mult_fun_complexOf_uint32( complexOf_uint32 a, complexOf_uint32 b ) +{ + complexOf_uint32 r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_uint64 mult_fun_complexOf_uint64( complexOf_uint64 a, complexOf_uint64 b ) +{ + complexOf_uint64 r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +#ifdef __FreeBSD__ +float complex clogf( float complex x ) +{ + return (I * atan2f(cimagf(x), crealf(x))) + logf(cabsf(x)); +} +#endif + + +float complex logBase_fun_complexOf_float( float complex a, float complex b ) +{ + return clogf(b) / clogf(a); +} + + + +complexOf_int8 complex_fun_int8( int8_t re, int8_t im ) +{ + complexOf_int8 r; + r.re = re; + r.im = im; + return r; +} + +complexOf_int16 complex_fun_int16( int16_t re, int16_t im ) +{ + complexOf_int16 r; + r.re = re; + r.im = im; + return r; +} + +complexOf_int32 complex_fun_int32( int32_t re, int32_t im ) +{ + complexOf_int32 r; + r.re = re; + r.im = im; + return r; +} + +complexOf_int64 complex_fun_int64( int64_t re, int64_t im ) +{ + complexOf_int64 r; + r.re = re; + r.im = im; + return r; +} + +complexOf_uint8 complex_fun_uint8( uint8_t re, uint8_t im ) +{ + complexOf_uint8 r; + r.re = re; + r.im = im; + return r; +} + +complexOf_uint16 complex_fun_uint16( uint16_t re, uint16_t im ) +{ + complexOf_uint16 r; + r.re = re; + r.im = im; + return r; +} + +complexOf_uint32 complex_fun_uint32( uint32_t re, uint32_t im ) +{ + complexOf_uint32 r; + r.re = re; + r.im = im; + return r; +} + +complexOf_uint64 complex_fun_uint64( uint64_t re, uint64_t im ) +{ + complexOf_uint64 r; + r.re = re; + r.im = im; + return r; +} + +float complex complex_fun_float( float re, float im ) +{ + return ( re + im * I ); +} + + + +int8_t creal_fun_complexOf_int8( complexOf_int8 a ) +{ + return a.re; +} + +int16_t creal_fun_complexOf_int16( complexOf_int16 a ) +{ + return a.re; +} + +int32_t creal_fun_complexOf_int32( complexOf_int32 a ) +{ + return a.re; +} + +int64_t creal_fun_complexOf_int64( complexOf_int64 a ) +{ + return a.re; +} + +uint8_t creal_fun_complexOf_uint8( complexOf_uint8 a ) +{ + return a.re; +} + +uint16_t creal_fun_complexOf_uint16( complexOf_uint16 a ) +{ + return a.re; +} + +uint32_t creal_fun_complexOf_uint32( complexOf_uint32 a ) +{ + return a.re; +} + +uint64_t creal_fun_complexOf_uint64( complexOf_uint64 a ) +{ + return a.re; +} + + + +int8_t cimag_fun_complexOf_int8( complexOf_int8 a ) +{ + return a.im; +} + +int16_t cimag_fun_complexOf_int16( complexOf_int16 a ) +{ + return a.im; +} + +int32_t cimag_fun_complexOf_int32( complexOf_int32 a ) +{ + return a.im; +} + +int64_t cimag_fun_complexOf_int64( complexOf_int64 a ) +{ + return a.im; +} + +uint8_t cimag_fun_complexOf_uint8( complexOf_uint8 a ) +{ + return a.im; +} + +uint16_t cimag_fun_complexOf_uint16( complexOf_uint16 a ) +{ + return a.im; +} + +uint32_t cimag_fun_complexOf_uint32( complexOf_uint32 a ) +{ + return a.im; +} + +uint64_t cimag_fun_complexOf_uint64( complexOf_uint64 a ) +{ + return a.im; +} + + + +complexOf_int8 conj_fun_complexOf_int8( complexOf_int8 a ) +{ + a.im = -a.im; + return a; +} + +complexOf_int16 conj_fun_complexOf_int16( complexOf_int16 a ) +{ + a.im = -a.im; + return a; +} + +complexOf_int32 conj_fun_complexOf_int32( complexOf_int32 a ) +{ + a.im = -a.im; + return a; +} + +complexOf_int64 conj_fun_complexOf_int64( complexOf_int64 a ) +{ + a.im = -a.im; + return a; +} + +complexOf_uint8 conj_fun_complexOf_uint8( complexOf_uint8 a ) +{ + a.im = -a.im; + return a; +} + +complexOf_uint16 conj_fun_complexOf_uint16( complexOf_uint16 a ) +{ + a.im = -a.im; + return a; +} + +complexOf_uint32 conj_fun_complexOf_uint32( complexOf_uint32 a ) +{ + a.im = -a.im; + return a; +} + +complexOf_uint64 conj_fun_complexOf_uint64( complexOf_uint64 a ) +{ + a.im = -a.im; + return a; +} + + + +int8_t magnitude_fun_complexOf_int8( complexOf_int8 a ) +{ + return lroundf(hypotf(a.re, a.im)); +} + +int16_t magnitude_fun_complexOf_int16( complexOf_int16 a ) +{ + return lroundf(hypotf(a.re, a.im)); +} + +int32_t magnitude_fun_complexOf_int32( complexOf_int32 a ) +{ + return lroundf(hypotf(a.re, a.im)); +} + +int64_t magnitude_fun_complexOf_int64( complexOf_int64 a ) +{ + return llroundf(hypotf(a.re, a.im)); +} + +uint8_t magnitude_fun_complexOf_uint8( complexOf_uint8 a ) +{ + return lroundf(hypotf(a.re, a.im)); +} + +uint16_t magnitude_fun_complexOf_uint16( complexOf_uint16 a ) +{ + return lroundf(hypotf(a.re, a.im)); +} + +uint32_t magnitude_fun_complexOf_uint32( complexOf_uint32 a ) +{ + return lroundf(hypotf(a.re, a.im)); +} + +uint64_t magnitude_fun_complexOf_uint64( complexOf_uint64 a ) +{ + return llroundf(hypotf(a.re, a.im)); +} + + + +int8_t phase_fun_complexOf_int8( complexOf_int8 a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return lroundf(atan2f(a.im, a.re)); +} + +int16_t phase_fun_complexOf_int16( complexOf_int16 a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return lroundf(atan2f(a.im, a.re)); +} + +int32_t phase_fun_complexOf_int32( complexOf_int32 a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return lroundf(atan2f(a.im, a.re)); +} + +int64_t phase_fun_complexOf_int64( complexOf_int64 a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return llroundf(atan2f(a.im, a.re)); +} + +uint8_t phase_fun_complexOf_uint8( complexOf_uint8 a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return lroundf(atan2f(a.im, a.re)); +} + +uint16_t phase_fun_complexOf_uint16( complexOf_uint16 a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return lroundf(atan2f(a.im, a.re)); +} + +uint32_t phase_fun_complexOf_uint32( complexOf_uint32 a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return lroundf(atan2f(a.im, a.re)); +} + +uint64_t phase_fun_complexOf_uint64( complexOf_uint64 a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return llroundf(atan2f(a.im, a.re)); +} + + + +complexOf_int8 mkPolar_fun_int8( int8_t r, int8_t t ) +{ + complexOf_int8 a; + a.re = lroundf(r * cosf(t)); + a.im = lroundf(r * sinf(t)); + return a; +} + +complexOf_int16 mkPolar_fun_int16( int16_t r, int16_t t ) +{ + complexOf_int16 a; + a.re = lroundf(r * cosf(t)); + a.im = lroundf(r * sinf(t)); + return a; +} + +complexOf_int32 mkPolar_fun_int32( int32_t r, int32_t t ) +{ + complexOf_int32 a; + a.re = lroundf(r * cosf(t)); + a.im = lroundf(r * sinf(t)); + return a; +} + +complexOf_int64 mkPolar_fun_int64( int64_t r, int64_t t ) +{ + complexOf_int64 a; + a.re = llroundf(r * cosf(t)); + a.im = llroundf(r * sinf(t)); + return a; +} + +complexOf_uint8 mkPolar_fun_uint8( uint8_t r, uint8_t t ) +{ + complexOf_uint8 a; + a.re = lroundf(r * cosf(t)); + a.im = lroundf(r * sinf(t)); + return a; +} + +complexOf_uint16 mkPolar_fun_uint16( uint16_t r, uint16_t t ) +{ + complexOf_uint16 a; + a.re = lroundf(r * cosf(t)); + a.im = lroundf(r * sinf(t)); + return a; +} + +complexOf_uint32 mkPolar_fun_uint32( uint32_t r, uint32_t t ) +{ + complexOf_uint32 a; + a.re = lroundf(r * cosf(t)); + a.im = lroundf(r * sinf(t)); + return a; +} + +complexOf_uint64 mkPolar_fun_uint64( uint64_t r, uint64_t t ) +{ + complexOf_uint64 a; + a.re = llroundf(r * cosf(t)); + a.im = llroundf(r * sinf(t)); + return a; +} + +float complex mkPolar_fun_float( float r, float t ) +{ + return r * cosf(t) + r * sinf(t) * I; +} + + + +complexOf_int8 cis_fun_int8( int8_t t ) +{ + complexOf_int8 r; + r.re = lroundf(cosf(t)); + r.im = lroundf(sinf(t)); + return r; +} + +complexOf_int16 cis_fun_int16( int16_t t ) +{ + complexOf_int16 r; + r.re = lroundf(cosf(t)); + r.im = lroundf(sinf(t)); + return r; +} + +complexOf_int32 cis_fun_int32( int32_t t ) +{ + complexOf_int32 r; + r.re = lroundf(cosf(t)); + r.im = lroundf(sinf(t)); + return r; +} + +complexOf_int64 cis_fun_int64( int64_t t ) +{ + complexOf_int64 r; + r.re = llroundf(cosf(t)); + r.im = llroundf(sinf(t)); + return r; +} + +complexOf_uint8 cis_fun_uint8( uint8_t t ) +{ + complexOf_uint8 r; + r.re = lroundf(cosf(t)); + r.im = lroundf(sinf(t)); + return r; +} + +complexOf_uint16 cis_fun_uint16( uint16_t t ) +{ + complexOf_uint16 r; + r.re = lroundf(cosf(t)); + r.im = lroundf(sinf(t)); + return r; +} + +complexOf_uint32 cis_fun_uint32( uint32_t t ) +{ + complexOf_uint32 r; + r.re = lroundf(cosf(t)); + r.im = lroundf(sinf(t)); + return r; +} + +complexOf_uint64 cis_fun_uint64( uint64_t t ) +{ + complexOf_uint64 r; + r.re = llroundf(cosf(t)); + r.im = llroundf(sinf(t)); + return r; +} + +float complex cis_fun_float( float t ) +{ + return cosf(t) + sinf(t) * I; +} + + + +/*--------------------------------------------------------------------------* + * Trace functions * + *--------------------------------------------------------------------------*/ + +static FILE *trace_log_file; + +#if defined(WIN32) + +static DWORD trace_start_time; + +void traceStart() +{ + SYSTEMTIME lt; + GetLocalTime(<); + char str [256]; + sprintf(str, "trace-%04d%02d%02d-%02d%02d%02d.log", + lt.wYear, lt.wMonth, lt.wDay, lt.wHour, lt.wMinute, lt.wSecond); + trace_log_file = fopen(str, "a"); + if (trace_log_file == NULL) { + fprintf(stderr,"Can not open trace file.\n"); + exit (8); + } + fprintf(trace_log_file, + "Logging started at %02d-%02d-%04d %02d:%02d:%02d.\n", + lt.wDay, lt.wMonth, lt.wYear, lt.wHour, lt.wMinute, lt.wSecond); + fflush(trace_log_file); + trace_start_time = GetTickCount(); +} + +void elapsedTimeString( char* str ) +{ + DWORD diff_ms = GetTickCount() - trace_start_time; + DWORD diff = diff_ms / 1000; + diff_ms = diff_ms % 1000; + sprintf(str, "%d.%.3d", diff, diff_ms); +} + +#else + +static struct timeval trace_start_time; + +void traceStart() +{ + gettimeofday(&trace_start_time, NULL); + struct tm * timeinfo = localtime(&(trace_start_time.tv_sec)); + char timestr [80]; + char str [256]; + strftime(timestr, 80, "%Y%m%d-%H%M%S", timeinfo); + sprintf(str, "trace-%s.log", timestr); + trace_log_file = fopen(str, "a"); + if (trace_log_file == NULL) { + fprintf(stderr,"Can not open trace file.\n"); + exit (8); + } + strftime(timestr, 80, "%d-%b-%Y %H:%M:%S", timeinfo); + fprintf(trace_log_file, "Logging started at %s.\n", timestr); + fflush(trace_log_file); + gettimeofday(&trace_start_time, NULL); +} + +void elapsedTimeString( char* str ) +{ + struct timeval tv; + gettimeofday (&tv, NULL); + if (trace_start_time.tv_usec <= tv.tv_usec) { + tv.tv_sec = tv.tv_sec - trace_start_time.tv_sec; + tv.tv_usec = tv.tv_usec - trace_start_time.tv_usec; + } else { + tv.tv_sec = tv.tv_sec - trace_start_time.tv_sec - 1; + tv.tv_usec = 1000000 + tv.tv_usec - trace_start_time.tv_usec; + } + sprintf(str, "%ld.%06d", tv.tv_sec, (int)tv.tv_usec); +} + +#endif /* WIN32 */ + +void traceEnd() +{ + fprintf(trace_log_file, "Logging finished.\n"); + fclose(trace_log_file); +} + +void trace_int8( int8_t val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_int16( int16_t val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_int32( int32_t val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_int64( int64_t val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%lld\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_uint8( uint8_t val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_uint16( uint16_t val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_uint32( uint32_t val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_uint64( uint64_t val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%llu\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_float( float val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%f\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_complexOf_int8( complexOf_int8 val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_int16( complexOf_int16 val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_int32( complexOf_int32 val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_int64( complexOf_int64 val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%lld+%lld*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_uint8( complexOf_uint8 val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_uint16( complexOf_uint16 val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_uint32( complexOf_uint32 val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_uint64( complexOf_uint64 val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%llu+%llu*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_float( float complex val, int32_t id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%f+%f*I\n", id, timestr, creal(val), cimag(val)); + fflush(trace_log_file); +} + diff --git a/lib/Feldspar/C/feldspar_c99.h b/lib/Feldspar/C/feldspar_c99.h new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/feldspar_c99.h @@ -0,0 +1,356 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#ifndef FELDSPAR_C99_H +#define FELDSPAR_C99_H + +#include +#include + + + +#define min(X, Y) ((X) < (Y) ? (X) : (Y)) +#define max(X, Y) ((X) > (Y) ? (X) : (Y)) + +int8_t pow_fun_int8( int8_t, int8_t ); +int16_t pow_fun_int16( int16_t, int16_t ); +int32_t pow_fun_int32( int32_t, int32_t ); +int64_t pow_fun_int64( int64_t, int64_t ); +uint8_t pow_fun_uint8( uint8_t, uint8_t ); +uint16_t pow_fun_uint16( uint16_t, uint16_t ); +uint32_t pow_fun_uint32( uint32_t, uint32_t ); +uint64_t pow_fun_uint64( uint64_t, uint64_t ); + +int8_t abs_fun_int8( int8_t ); +int16_t abs_fun_int16( int16_t ); +int32_t abs_fun_int32( int32_t ); +int64_t abs_fun_int64( int64_t ); + +int8_t signum_fun_int8( int8_t ); +int16_t signum_fun_int16( int16_t ); +int32_t signum_fun_int32( int32_t ); +int64_t signum_fun_int64( int64_t ); +uint8_t signum_fun_uint8( uint8_t ); +uint16_t signum_fun_uint16( uint16_t ); +uint32_t signum_fun_uint32( uint32_t ); +uint64_t signum_fun_uint64( uint64_t ); +float signum_fun_float( float ); + +float logBase_fun_float( float, float ); + + + +int8_t setBit_fun_int8( int8_t, uint32_t ); +int16_t setBit_fun_int16( int16_t, uint32_t ); +int32_t setBit_fun_int32( int32_t, uint32_t ); +int64_t setBit_fun_int64( int64_t, uint32_t ); +uint8_t setBit_fun_uint8( uint8_t, uint32_t ); +uint16_t setBit_fun_uint16( uint16_t, uint32_t ); +uint32_t setBit_fun_uint32( uint32_t, uint32_t ); +uint64_t setBit_fun_uint64( uint64_t, uint32_t ); + +int8_t clearBit_fun_int8( int8_t, uint32_t ); +int16_t clearBit_fun_int16( int16_t, uint32_t ); +int32_t clearBit_fun_int32( int32_t, uint32_t ); +int64_t clearBit_fun_int64( int64_t, uint32_t ); +uint8_t clearBit_fun_uint8( uint8_t, uint32_t ); +uint16_t clearBit_fun_uint16( uint16_t, uint32_t ); +uint32_t clearBit_fun_uint32( uint32_t, uint32_t ); +uint64_t clearBit_fun_uint64( uint64_t, uint32_t ); + +int8_t complementBit_fun_int8( int8_t, uint32_t ); +int16_t complementBit_fun_int16( int16_t, uint32_t ); +int32_t complementBit_fun_int32( int32_t, uint32_t ); +int64_t complementBit_fun_int64( int64_t, uint32_t ); +uint8_t complementBit_fun_uint8( uint8_t, uint32_t ); +uint16_t complementBit_fun_uint16( uint16_t, uint32_t ); +uint32_t complementBit_fun_uint32( uint32_t, uint32_t ); +uint64_t complementBit_fun_uint64( uint64_t, uint32_t ); + +int testBit_fun_int8( int8_t, uint32_t ); +int testBit_fun_int16( int16_t, uint32_t ); +int testBit_fun_int32( int32_t, uint32_t ); +int testBit_fun_int64( int64_t, uint32_t ); +int testBit_fun_uint8( uint8_t, uint32_t ); +int testBit_fun_uint16( uint16_t, uint32_t ); +int testBit_fun_uint32( uint32_t, uint32_t ); +int testBit_fun_uint64( uint64_t, uint32_t ); + +int8_t rotateL_fun_int8( int8_t, int32_t ); +int16_t rotateL_fun_int16( int16_t, int32_t ); +int32_t rotateL_fun_int32( int32_t, int32_t ); +int64_t rotateL_fun_int64( int64_t, int32_t ); +uint8_t rotateL_fun_uint8( uint8_t, int32_t ); +uint16_t rotateL_fun_uint16( uint16_t, int32_t ); +uint32_t rotateL_fun_uint32( uint32_t, int32_t ); +uint64_t rotateL_fun_uint64( uint64_t, int32_t ); + +int8_t rotateR_fun_int8( int8_t, int32_t ); +int16_t rotateR_fun_int16( int16_t, int32_t ); +int32_t rotateR_fun_int32( int32_t, int32_t ); +int64_t rotateR_fun_int64( int64_t, int32_t ); +uint8_t rotateR_fun_uint8( uint8_t, int32_t ); +uint16_t rotateR_fun_uint16( uint16_t, int32_t ); +uint32_t rotateR_fun_uint32( uint32_t, int32_t ); +uint64_t rotateR_fun_uint64( uint64_t, int32_t ); + +int8_t reverseBits_fun_int8( int8_t ); +int16_t reverseBits_fun_int16( int16_t ); +int32_t reverseBits_fun_int32( int32_t ); +int64_t reverseBits_fun_int64( int64_t ); +uint8_t reverseBits_fun_uint8( uint8_t ); +uint16_t reverseBits_fun_uint16( uint16_t ); +uint32_t reverseBits_fun_uint32( uint32_t ); +uint64_t reverseBits_fun_uint64( uint64_t ); + +uint32_t bitScan_fun_int8( int8_t ); +uint32_t bitScan_fun_int16( int16_t ); +uint32_t bitScan_fun_int32( int32_t ); +uint32_t bitScan_fun_int64( int64_t ); +uint32_t bitScan_fun_uint8( uint8_t ); +uint32_t bitScan_fun_uint16( uint16_t ); +uint32_t bitScan_fun_uint32( uint32_t ); +uint32_t bitScan_fun_uint64( uint64_t ); + +uint32_t bitCount_fun_int8( int8_t ); +uint32_t bitCount_fun_int16( int16_t ); +uint32_t bitCount_fun_int32( int32_t ); +uint32_t bitCount_fun_int64( int64_t ); +uint32_t bitCount_fun_uint8( uint8_t ); +uint32_t bitCount_fun_uint16( uint16_t ); +uint32_t bitCount_fun_uint32( uint32_t ); +uint32_t bitCount_fun_uint64( uint64_t ); + + + +typedef struct { + int8_t re; + int8_t im; +} complexOf_int8; + +typedef struct { + int16_t re; + int16_t im; +} complexOf_int16; + +typedef struct { + int32_t re; + int32_t im; +} complexOf_int32; + +typedef struct { + int64_t re; + int64_t im; +} complexOf_int64; + +typedef struct { + uint8_t re; + uint8_t im; +} complexOf_uint8; + +typedef struct { + uint16_t re; + uint16_t im; +} complexOf_uint16; + +typedef struct { + uint32_t re; + uint32_t im; +} complexOf_uint32; + +typedef struct { + uint64_t re; + uint64_t im; +} complexOf_uint64; + +int equal_fun_complexOf_int8( complexOf_int8, complexOf_int8 ); +int equal_fun_complexOf_int16( complexOf_int16, complexOf_int16 ); +int equal_fun_complexOf_int32( complexOf_int32, complexOf_int32 ); +int equal_fun_complexOf_int64( complexOf_int64, complexOf_int64 ); +int equal_fun_complexOf_uint8( complexOf_uint8, complexOf_uint8 ); +int equal_fun_complexOf_uint16( complexOf_uint16, complexOf_uint16 ); +int equal_fun_complexOf_uint32( complexOf_uint32, complexOf_uint32 ); +int equal_fun_complexOf_uint64( complexOf_uint64, complexOf_uint64 ); + +complexOf_int8 negate_fun_complexOf_int8( complexOf_int8 ); +complexOf_int16 negate_fun_complexOf_int16( complexOf_int16 ); +complexOf_int32 negate_fun_complexOf_int32( complexOf_int32 ); +complexOf_int64 negate_fun_complexOf_int64( complexOf_int64 ); +complexOf_uint8 negate_fun_complexOf_uint8( complexOf_uint8 ); +complexOf_uint16 negate_fun_complexOf_uint16( complexOf_uint16 ); +complexOf_uint32 negate_fun_complexOf_uint32( complexOf_uint32 ); +complexOf_uint64 negate_fun_complexOf_uint64( complexOf_uint64 ); + +complexOf_int8 abs_fun_complexOf_int8( complexOf_int8 ); +complexOf_int16 abs_fun_complexOf_int16( complexOf_int16 ); +complexOf_int32 abs_fun_complexOf_int32( complexOf_int32 ); +complexOf_int64 abs_fun_complexOf_int64( complexOf_int64 ); +complexOf_uint8 abs_fun_complexOf_uint8( complexOf_uint8 ); +complexOf_uint16 abs_fun_complexOf_uint16( complexOf_uint16 ); +complexOf_uint32 abs_fun_complexOf_uint32( complexOf_uint32 ); +complexOf_uint64 abs_fun_complexOf_uint64( complexOf_uint64 ); + +complexOf_int8 signum_fun_complexOf_int8( complexOf_int8 ); +complexOf_int16 signum_fun_complexOf_int16( complexOf_int16 ); +complexOf_int32 signum_fun_complexOf_int32( complexOf_int32 ); +complexOf_int64 signum_fun_complexOf_int64( complexOf_int64 ); +complexOf_uint8 signum_fun_complexOf_uint8( complexOf_uint8 ); +complexOf_uint16 signum_fun_complexOf_uint16( complexOf_uint16 ); +complexOf_uint32 signum_fun_complexOf_uint32( complexOf_uint32 ); +complexOf_uint64 signum_fun_complexOf_uint64( complexOf_uint64 ); +float complex signum_fun_complexOf_float( float complex ); + +complexOf_int8 add_fun_complexOf_int8( complexOf_int8, complexOf_int8 ); +complexOf_int16 add_fun_complexOf_int16( complexOf_int16, complexOf_int16 ); +complexOf_int32 add_fun_complexOf_int32( complexOf_int32, complexOf_int32 ); +complexOf_int64 add_fun_complexOf_int64( complexOf_int64, complexOf_int64 ); +complexOf_uint8 add_fun_complexOf_uint8( complexOf_uint8, complexOf_uint8 ); +complexOf_uint16 add_fun_complexOf_uint16( complexOf_uint16, complexOf_uint16 ); +complexOf_uint32 add_fun_complexOf_uint32( complexOf_uint32, complexOf_uint32 ); +complexOf_uint64 add_fun_complexOf_uint64( complexOf_uint64, complexOf_uint64 ); + +complexOf_int8 sub_fun_complexOf_int8( complexOf_int8, complexOf_int8 ); +complexOf_int16 sub_fun_complexOf_int16( complexOf_int16, complexOf_int16 ); +complexOf_int32 sub_fun_complexOf_int32( complexOf_int32, complexOf_int32 ); +complexOf_int64 sub_fun_complexOf_int64( complexOf_int64, complexOf_int64 ); +complexOf_uint8 sub_fun_complexOf_uint8( complexOf_uint8, complexOf_uint8 ); +complexOf_uint16 sub_fun_complexOf_uint16( complexOf_uint16, complexOf_uint16 ); +complexOf_uint32 sub_fun_complexOf_uint32( complexOf_uint32, complexOf_uint32 ); +complexOf_uint64 sub_fun_complexOf_uint64( complexOf_uint64, complexOf_uint64 ); + +complexOf_int8 mult_fun_complexOf_int8( complexOf_int8, complexOf_int8 ); +complexOf_int16 mult_fun_complexOf_int16( complexOf_int16, complexOf_int16 ); +complexOf_int32 mult_fun_complexOf_int32( complexOf_int32, complexOf_int32 ); +complexOf_int64 mult_fun_complexOf_int64( complexOf_int64, complexOf_int64 ); +complexOf_uint8 mult_fun_complexOf_uint8( complexOf_uint8, complexOf_uint8 ); +complexOf_uint16 mult_fun_complexOf_uint16( complexOf_uint16, complexOf_uint16 ); +complexOf_uint32 mult_fun_complexOf_uint32( complexOf_uint32, complexOf_uint32 ); +complexOf_uint64 mult_fun_complexOf_uint64( complexOf_uint64, complexOf_uint64 ); + +float complex logBase_fun_complexOf_float( float complex, float complex ); + +complexOf_int8 complex_fun_int8( int8_t, int8_t ); +complexOf_int16 complex_fun_int16( int16_t, int16_t ); +complexOf_int32 complex_fun_int32( int32_t, int32_t ); +complexOf_int64 complex_fun_int64( int64_t, int64_t ); +complexOf_uint8 complex_fun_uint8( uint8_t, uint8_t ); +complexOf_uint16 complex_fun_uint16( uint16_t, uint16_t ); +complexOf_uint32 complex_fun_uint32( uint32_t, uint32_t ); +complexOf_uint64 complex_fun_uint64( uint64_t, uint64_t ); +float complex complex_fun_float( float, float ); + +int8_t creal_fun_complexOf_int8( complexOf_int8 ); +int16_t creal_fun_complexOf_int16( complexOf_int16 ); +int32_t creal_fun_complexOf_int32( complexOf_int32 ); +int64_t creal_fun_complexOf_int64( complexOf_int64 ); +uint8_t creal_fun_complexOf_uint8( complexOf_uint8 ); +uint16_t creal_fun_complexOf_uint16( complexOf_uint16 ); +uint32_t creal_fun_complexOf_uint32( complexOf_uint32 ); +uint64_t creal_fun_complexOf_uint64( complexOf_uint64 ); + +int8_t cimag_fun_complexOf_int8( complexOf_int8 ); +int16_t cimag_fun_complexOf_int16( complexOf_int16 ); +int32_t cimag_fun_complexOf_int32( complexOf_int32 ); +int64_t cimag_fun_complexOf_int64( complexOf_int64 ); +uint8_t cimag_fun_complexOf_uint8( complexOf_uint8 ); +uint16_t cimag_fun_complexOf_uint16( complexOf_uint16 ); +uint32_t cimag_fun_complexOf_uint32( complexOf_uint32 ); +uint64_t cimag_fun_complexOf_uint64( complexOf_uint64 ); + +complexOf_int8 conj_fun_complexOf_int8( complexOf_int8 ); +complexOf_int16 conj_fun_complexOf_int16( complexOf_int16 ); +complexOf_int32 conj_fun_complexOf_int32( complexOf_int32 ); +complexOf_int64 conj_fun_complexOf_int64( complexOf_int64 ); +complexOf_uint8 conj_fun_complexOf_uint8( complexOf_uint8 ); +complexOf_uint16 conj_fun_complexOf_uint16( complexOf_uint16 ); +complexOf_uint32 conj_fun_complexOf_uint32( complexOf_uint32 ); +complexOf_uint64 conj_fun_complexOf_uint64( complexOf_uint64 ); + +int8_t magnitude_fun_complexOf_int8( complexOf_int8 ); +int16_t magnitude_fun_complexOf_int16( complexOf_int16 ); +int32_t magnitude_fun_complexOf_int32( complexOf_int32 ); +int64_t magnitude_fun_complexOf_int64( complexOf_int64 ); +uint8_t magnitude_fun_complexOf_uint8( complexOf_uint8 ); +uint16_t magnitude_fun_complexOf_uint16( complexOf_uint16 ); +uint32_t magnitude_fun_complexOf_uint32( complexOf_uint32 ); +uint64_t magnitude_fun_complexOf_uint64( complexOf_uint64 ); + +int8_t phase_fun_complexOf_int8( complexOf_int8 ); +int16_t phase_fun_complexOf_int16( complexOf_int16 ); +int32_t phase_fun_complexOf_int32( complexOf_int32 ); +int64_t phase_fun_complexOf_int64( complexOf_int64 ); +uint8_t phase_fun_complexOf_uint8( complexOf_uint8 ); +uint16_t phase_fun_complexOf_uint16( complexOf_uint16 ); +uint32_t phase_fun_complexOf_uint32( complexOf_uint32 ); +uint64_t phase_fun_complexOf_uint64( complexOf_uint64 ); + +complexOf_int8 mkPolar_fun_int8( int8_t, int8_t ); +complexOf_int16 mkPolar_fun_int16( int16_t, int16_t ); +complexOf_int32 mkPolar_fun_int32( int32_t, int32_t ); +complexOf_int64 mkPolar_fun_int64( int64_t, int64_t ); +complexOf_uint8 mkPolar_fun_uint8( uint8_t, uint8_t ); +complexOf_uint16 mkPolar_fun_uint16( uint16_t, uint16_t ); +complexOf_uint32 mkPolar_fun_uint32( uint32_t, uint32_t ); +complexOf_uint64 mkPolar_fun_uint64( uint64_t, uint64_t ); +float complex mkPolar_fun_float( float, float ); + +complexOf_int8 cis_fun_int8( int8_t ); +complexOf_int16 cis_fun_int16( int16_t ); +complexOf_int32 cis_fun_int32( int32_t ); +complexOf_int64 cis_fun_int64( int64_t ); +complexOf_uint8 cis_fun_uint8( uint8_t ); +complexOf_uint16 cis_fun_uint16( uint16_t ); +complexOf_uint32 cis_fun_uint32( uint32_t ); +complexOf_uint64 cis_fun_uint64( uint64_t ); +float complex cis_fun_float( float ); + + + +void traceStart(); +void traceEnd(); + +void trace_int8( int8_t, int32_t ); +void trace_int16( int16_t, int32_t ); +void trace_int32( int32_t, int32_t ); +void trace_int64( int64_t, int32_t ); +void trace_uint8( uint8_t, int32_t ); +void trace_uint16( uint16_t, int32_t ); +void trace_uint32( uint32_t, int32_t ); +void trace_uint64( uint64_t, int32_t ); +void trace_float( float, int32_t ); +void trace_complexOf_int8( complexOf_int8, int32_t ); +void trace_complexOf_int16( complexOf_int16, int32_t ); +void trace_complexOf_int32( complexOf_int32, int32_t ); +void trace_complexOf_int64( complexOf_int64, int32_t ); +void trace_complexOf_uint8( complexOf_uint8, int32_t ); +void trace_complexOf_uint16( complexOf_uint16, int32_t ); +void trace_complexOf_uint32( complexOf_uint32, int32_t ); +void trace_complexOf_uint64( complexOf_uint64, int32_t ); +void trace_complexOf_float( float complex, int32_t ); + +#endif /* FELDSPAR_C99_H */ diff --git a/lib/Feldspar/C/feldspar_future.h b/lib/Feldspar/C/feldspar_future.h new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/feldspar_future.h @@ -0,0 +1,30 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#include + diff --git a/lib/Feldspar/C/feldspar_tic64x.c b/lib/Feldspar/C/feldspar_tic64x.c new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/feldspar_tic64x.c @@ -0,0 +1,2364 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#include "feldspar_tic64x.h" + +#include +#include +#include +#include + +float hypotf(float x, float y) { + return sqrtf(x * x + y * y); +} + + + +/*--------------------------------------------------------------------------* + * pow(), abs(), signum(), logBase() * + *--------------------------------------------------------------------------*/ + +char pow_fun_char( char a, char b ) +{ + char r = 1; + int i; + if (b < 0) { + fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); + exit(1); + } + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +short pow_fun_short( short a, short b ) +{ + short r = 1; + int i; + if (b < 0) { + fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); + exit(1); + } + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +int pow_fun_int( int a, int b ) +{ + int r = 1; + int i; + if (b < 0) { + fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); + exit(1); + } + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +long pow_fun_long( long a, long b ) +{ + long r = 1; + int i; + if (b < 0) { + fprintf(stderr, "Negative exponent in function pow_fun_(): %ld `pow` %ld", a, b); + exit(1); + } + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +long long pow_fun_llong( long long a, long long b ) +{ + long long r = 1; + int i; + if (b < 0) { + fprintf(stderr, "Negative exponent in function pow_fun_(): %lld `pow` %lld", a, b); + exit(1); + } + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +unsigned char pow_fun_uchar( unsigned char a, unsigned char b ) +{ + unsigned char r = 1; + int i; + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +unsigned short pow_fun_ushort( unsigned short a, unsigned short b ) +{ + unsigned short r = 1; + int i; + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +unsigned pow_fun_uint( unsigned a, unsigned b ) +{ + unsigned r = 1; + int i; + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +unsigned long pow_fun_ulong( unsigned long a, unsigned long b ) +{ + unsigned long r = 1; + int i; + for(i = 0; i < b; ++i) + r *= a; + return r; +} + +unsigned long long pow_fun_ullong( unsigned long long a, unsigned long long b ) +{ + unsigned long long r = 1; + int i; + for(i = 0; i < b; ++i) + r *= a; + return r; +} + + + +char abs_fun_char( char a ) +{ + // From Bit Twiddling Hacks: + // "Compute the integer absolute value (abs) without branching" + char mask = a >> 7; + return (a + mask) ^ mask; +} + +short abs_fun_short( short a ) +{ + // From Bit Twiddling Hacks: + // "Compute the integer absolute value (abs) without branching" + short mask = a >> 15; + return (a + mask) ^ mask; +} + +long abs_fun_long( long a ) +{ + // From Bit Twiddling Hacks: + // "Compute the integer absolute value (abs) without branching" + long mask = a >> 39; + return (a + mask) ^ mask; +} + +long long abs_fun_llong( long long a ) +{ + // From Bit Twiddling Hacks: + // "Compute the integer absolute value (abs) without branching" + long long mask = a >> 63; + return (a + mask) ^ mask; +} + + + +char signum_fun_char( char a ) +{ + // From Bit Twiddling Hacks: "Compute the sign of an integer" + return (a != 0) | (a >> 7); +} + +short signum_fun_short( short a ) +{ + // From Bit Twiddling Hacks: "Compute the sign of an integer" + return (a != 0) | (a >> 15); +} + +int signum_fun_int( int a ) +{ + // From Bit Twiddling Hacks: "Compute the sign of an integer" + return (a != 0) | (a >> 31); +} + +long signum_fun_long( long a ) +{ + // From Bit Twiddling Hacks: "Compute the sign of an integer" + return (a != 0) | (a >> 39); +} + +long long signum_fun_llong( long long a ) +{ + // From Bit Twiddling Hacks: "Compute the sign of an integer" + return (a != 0) | (a >> 63); +} + +unsigned char signum_fun_uchar( unsigned char a ) +{ + return (a > 0); +} + +unsigned short signum_fun_ushort( unsigned short a ) +{ + return (a > 0); +} + +unsigned signum_fun_uint( unsigned a ) +{ + return (a > 0); +} + +unsigned long signum_fun_ulong( unsigned long a ) +{ + return (a > 0); +} + +unsigned long long signum_fun_ullong( unsigned long long a ) +{ + return (a > 0); +} + +float signum_fun_float( float a ) +{ + // From Bit Twiddling Hacks: "Compute the sign of an integer" + return (a > 0) - (a < 0); +} + + + +float logBase_fun_float( float a, float b ) +{ + return logf(b) / logf(a); +} + + + +/*--------------------------------------------------------------------------* + * Bit operations * + *--------------------------------------------------------------------------*/ + +char setBit_fun_char( char x, unsigned i ) +{ + return x | 1 << i; +} + +short setBit_fun_short( short x, unsigned i ) +{ + return x | 1 << i; +} + +int setBit_fun_int( int x, unsigned i ) +{ + return x | 1 << i; +} + +long setBit_fun_long( long x, unsigned i ) +{ + return x | 1 << i; +} + +long long setBit_fun_llong( long long x, unsigned i ) +{ + return x | 1 << i; +} + +unsigned char setBit_fun_uchar( unsigned char x, unsigned i ) +{ + return x | 1 << i; +} + +unsigned short setBit_fun_ushort( unsigned short x, unsigned i ) +{ + return x | 1 << i; +} + +unsigned setBit_fun_uint( unsigned x, unsigned i ) +{ + return x | 1 << i; +} + +unsigned long setBit_fun_ulong( unsigned long x, unsigned i ) +{ + return x | 1 << i; +} + +unsigned long long setBit_fun_ullong( unsigned long long x, unsigned i ) +{ + return x | 1 << i; +} + + + +char clearBit_fun_char( char x, unsigned i ) +{ + return x & ~(1 << i); +} + +short clearBit_fun_short( short x, unsigned i ) +{ + return x & ~(1 << i); +} + +int clearBit_fun_int( int x, unsigned i ) +{ + return x & ~(1 << i); +} + +long clearBit_fun_long( long x, unsigned i ) +{ + return x & ~(1 << i); +} + +long long clearBit_fun_llong( long long x, unsigned i ) +{ + return x & ~(1 << i); +} + +unsigned char clearBit_fun_uchar( unsigned char x, unsigned i ) +{ + return x & ~(1 << i); +} + +unsigned short clearBit_fun_ushort( unsigned short x, unsigned i ) +{ + return x & ~(1 << i); +} + +unsigned clearBit_fun_uint( unsigned x, unsigned i ) +{ + return x & ~(1 << i); +} + +unsigned long clearBit_fun_ulong( unsigned long x, unsigned i ) +{ + return x & ~(1 << i); +} + +unsigned long long clearBit_fun_ullong( unsigned long long x, unsigned i ) +{ + return x & ~(1 << i); +} + + + +char complementBit_fun_char( char x, unsigned i ) +{ + return x ^ 1 << i; +} + +short complementBit_fun_short( short x, unsigned i ) +{ + return x ^ 1 << i; +} + +int complementBit_fun_int( int x, unsigned i ) +{ + return x ^ 1 << i; +} + +long complementBit_fun_long( long x, unsigned i ) +{ + return x ^ 1 << i; +} + +long long complementBit_fun_llong( long long x, unsigned i ) +{ + return x ^ 1 << i; +} + +unsigned char complementBit_fun_uchar( unsigned char x, unsigned i ) +{ + return x ^ 1 << i; +} + +unsigned short complementBit_fun_ushort( unsigned short x, unsigned i ) +{ + return x ^ 1 << i; +} + +unsigned complementBit_fun_uint( unsigned x, unsigned i ) +{ + return x ^ 1 << i; +} + +unsigned long complementBit_fun_ulong( unsigned long x, unsigned i ) +{ + return x ^ 1 << i; +} + +unsigned long long complementBit_fun_ullong( unsigned long long x, unsigned i ) +{ + return x ^ 1 << i; +} + + + +int testBit_fun_char( char x, unsigned i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_short( short x, unsigned i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_int( int x, unsigned i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_long( long x, unsigned i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_llong( long long x, unsigned i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_uchar( unsigned char x, unsigned i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_ushort( unsigned short x, unsigned i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_uint( unsigned x, unsigned i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_ulong( unsigned long x, unsigned i ) +{ + return (x & 1 << i) != 0; +} + +int testBit_fun_ullong( unsigned long long x, unsigned i ) +{ + return (x & 1 << i) != 0; +} + + + +char rotateL_fun_char( char x, int i ) +{ + if ((i %= 8) == 0) return x; + return (x << i) | ((0x7f >> (7 - i)) & (x >> (8 - i))); +} + +short rotateL_fun_short( short x, int i ) +{ + if ((i %= 16) == 0) return x; + return (x << i) | ((0x7fff >> (15 - i)) & (x >> (16 - i))); +} + +long rotateL_fun_long( long x, int i ) +{ + if ((i %= 40) == 0) return x; + return (x << i) | ((0x7fffffffffl >> (39 - i)) & (x >> (40 - i))); +} + +long long rotateL_fun_llong( long long x, int i ) +{ + if ((i %= 64) == 0) return x; + return (x << i) | ((0x7fffffffffffffffll >> (63 - i)) & (x >> (64 - i))); +} + +int rotateL_fun_int( int x, int i ) +{ + return (int)_rotl((unsigned)x, (unsigned)i); +} + +unsigned char rotateL_fun_uchar( unsigned char x, int i ) +{ + if ((i %= 8) == 0) return x; + return (x << i) | (x >> (8 - i)); +} + +unsigned short rotateL_fun_ushort( unsigned short x, int i ) +{ + if ((i %= 16) == 0) return x; + return (x << i) | (x >> (16 - i)); +} + +unsigned long rotateL_fun_ulong( unsigned long x, int i ) +{ + if ((i %= 40) == 0) return x; + return (x << i) | (x >> (40 - i)); +} + +unsigned long long rotateL_fun_ullong( unsigned long long x, int i ) +{ + if ((i %= 64) == 0) return x; + return (x << i) | (x >> (64 - i)); +} + + + +char rotateR_fun_char( char x, int i ) +{ + if ((i %= 8) == 0) return x; + return (x << (8 - i)) | ((0x7f >> (i - 1)) & (x >> i)); +} + +short rotateR_fun_short( short x, int i ) +{ + if ((i %= 16) == 0) return x; + return (x << (16 - i)) | ((0x7fff >> (i - 1)) & (x >> i)); +} + +int rotateR_fun_int( int x, int i ) +{ + if ((i %= 32) == 0) return x; + return (x << (32 - i)) | ((0x7fffffff >> (i - 1)) & (x >> i)); +} + +long rotateR_fun_long( long x, int i ) +{ + if ((i %= 40) == 0) return x; + return (x << (40 - i)) | ((0x7fffffffffl >> (i - 1)) & (x >> i)); +} + +long long rotateR_fun_llong( long long x, int i ) +{ + if ((i %= 64) == 0) return x; + return (x << (64 - i)) | ((0x7fffffffffffffffll >> (i - 1)) & (x >> i)); +} + +unsigned char rotateR_fun_uchar( unsigned char x, int i ) +{ + if ((i %= 8) == 0) return x; + return (x << (8 - i)) | (x >> i); +} + +unsigned short rotateR_fun_ushort( unsigned short x, int i ) +{ + if ((i %= 16) == 0) return x; + return (x << (16 - i)) | (x >> i); +} + +unsigned rotateR_fun_uint( unsigned x, int i ) +{ + if ((i %= 32) == 0) return x; + return (x << (32 - i)) | (x >> i); +} + +unsigned long rotateR_fun_ulong( unsigned long x, int i ) +{ + if ((i %= 40) == 0) return x; + return (x << (40 - i)) | (x >> i); +} + +unsigned long long rotateR_fun_ullong( unsigned long long x, int i ) +{ + if ((i %= 64) == 0) return x; + return (x << (64 - i)) | (x >> i); +} + + + +char reverseBits_fun_char( char x ) +{ + char r = x; + int i = 7; + for (x = x >> 1 & 0x7f; x; x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +short reverseBits_fun_short( short x ) +{ + short r = x; + int i = 15; + for (x = x >> 1 & 0x7fff; x; x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +int reverseBits_fun_int( int x ) +{ + int r = x; + int i = 31; + for (x = x >> 1 & 0x7fffffff; x; x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +long reverseBits_fun_long( long x ) +{ + long r = x; + int i = 39; + for (x = x >> 1 & 0x7fffffffffl; x; x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +long long reverseBits_fun_llong( long long x ) +{ + long long r = x; + int i = 63; + for (x = x >> 1 & 0x7fffffffffffffffll; x; x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +unsigned char reverseBits_fun_uchar( unsigned char x ) +{ + unsigned char r = x; + int i = 7; + while (x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +unsigned short reverseBits_fun_ushort( unsigned short x ) +{ + unsigned short r = x; + int i = 15; + while (x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +unsigned long reverseBits_fun_ulong( unsigned long x ) +{ + unsigned long r = x; + int i = 39; + while (x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + +unsigned long long reverseBits_fun_ullong( unsigned long long x ) +{ + unsigned long long r = x; + int i = 63; + while (x >>= 1) + { + r = (r << 1) | (x & 1); + --i; + } + return r << i; +} + + + +unsigned bitScan_fun_char( char x ) +{ + unsigned r = 0; + char s = (x & 0x80); + if (x == 0) return 7; + while (((x <<= 1) & 0x80) == s) + ++r; + return r; +} + +unsigned bitScan_fun_short( short x ) +{ + unsigned r = 0; + short s = (x & 0x8000); + if (x == 0) return 15; + while (((x <<= 1) & 0x8000) == s) + ++r; + return r; +} + +unsigned bitScan_fun_int( int x ) +{ + unsigned r = 0; + int s = (x & 0x80000000); + if (x == 0) return 31; + while (((x <<= 1) & 0x80000000) == s) + ++r; + return r; +} + +unsigned bitScan_fun_long( long x ) +{ + unsigned r = 0; + long s = (x & 0x8000000000l); + if (x == 0) return 39; + while (((x <<= 1) & 0x8000000000l) == s) + ++r; + return r; +} + +unsigned bitScan_fun_llong( long long x ) +{ + unsigned r = 0; + long long s = (x & 0x8000000000000000ll); + if (x == 0) return 63; + while (((x <<= 1) & 0x8000000000000000ll) == s) + ++r; + return r; +} + +unsigned bitScan_fun_uchar( unsigned char x ) +{ + unsigned r = 8; + while (x) + { + --r; + x >>= 1; + } + return r; +} + +unsigned bitScan_fun_ushort( unsigned short x ) +{ + unsigned r = 16; + while (x) + { + --r; + x >>= 1; + } + return r; +} + +unsigned bitScan_fun_uint( unsigned x ) +{ + unsigned r = 32; + while (x) + { + --r; + x >>= 1; + } + return r; +} + +unsigned bitScan_fun_ulong( unsigned long x ) +{ + unsigned r = 40; + while (x) + { + --r; + x >>= 1; + } + return r; +} + +unsigned bitScan_fun_ullong( unsigned long long x ) +{ + unsigned r = 64; + while (x) + { + --r; + x >>= 1; + } + return r; +} + + + +unsigned bitCount_fun_char( char x ) +{ + unsigned r = x & 1; + for (x = x >> 1 & 0x7f; x; x >>= 1) + r += x & 1; + return r; +} + +unsigned bitCount_fun_short( short x ) +{ + unsigned r = x & 1; + for (x = x >> 1 & 0x7fff; x; x >>= 1) + r += x & 1; + return r; +} + +unsigned bitCount_fun_int( int x ) +{ + unsigned r = x & 1; + for (x = x >> 1 & 0x7fffffff; x; x >>= 1) + r += x & 1; + return r; +} + +unsigned bitCount_fun_long( long x ) +{ + unsigned r = x & 1; + for (x = x >> 1 & 0x7fffffffffl; x; x >>= 1) + r += x & 1; + return r; +} + +unsigned bitCount_fun_llong( long long x ) +{ + unsigned r = x & 1; + for (x = x >> 1 & 0x7fffffffffffffffll; x; x >>= 1) + r += x & 1; + return r; +} + +unsigned bitCount_fun_uchar( unsigned char x ) +{ + unsigned r = x & 1; + while (x >>= 1) + r += x & 1; + return r; +} + +unsigned bitCount_fun_ushort( unsigned short x ) +{ + unsigned r = x & 1; + while (x >>= 1) + r += x & 1; + return r; +} + +unsigned bitCount_fun_ulong( unsigned long x ) +{ + unsigned r = x & 1; + while (x >>= 1) + r += x & 1; + return r; +} + +unsigned bitCount_fun_ullong( unsigned long long x ) +{ + unsigned r = x & 1; + while (x >>= 1) + r += x & 1; + return r; +} + + + +/*--------------------------------------------------------------------------* + * Complex numbers * + *--------------------------------------------------------------------------*/ + +int equal_fun_complexOf_char( complexOf_char a, complexOf_char b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_int( complexOf_int a, complexOf_int b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_long( complexOf_long a, complexOf_long b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_llong( complexOf_llong a, complexOf_llong b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_uchar( complexOf_uchar a, complexOf_uchar b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_uint( complexOf_uint a, complexOf_uint b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_ulong( complexOf_ulong a, complexOf_ulong b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_ullong( complexOf_ullong a, complexOf_ullong b ) +{ + return a.re == b.re && a.im == b.im; +} + +int equal_fun_complexOf_float( complexOf_float a, complexOf_float b ) +{ + return a.re == b.re && a.im == b.im; +} + + + +complexOf_char negate_fun_complexOf_char( complexOf_char a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_int negate_fun_complexOf_int( complexOf_int a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_long negate_fun_complexOf_long( complexOf_long a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_llong negate_fun_complexOf_llong( complexOf_llong a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_uchar negate_fun_complexOf_uchar( complexOf_uchar a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_uint negate_fun_complexOf_uint( complexOf_uint a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_ulong negate_fun_complexOf_ulong( complexOf_ulong a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_ullong negate_fun_complexOf_ullong( complexOf_ullong a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + +complexOf_float negate_fun_complexOf_float( complexOf_float a ) +{ + a.re = -a.re; + a.im = -a.im; + return a; +} + + + +complexOf_char abs_fun_complexOf_char( complexOf_char a ) +{ + a.re = magnitude_fun_complexOf_char(a); + a.im = 0; + return a; +} + +complexOf_int abs_fun_complexOf_int( complexOf_int a ) +{ + a.re = magnitude_fun_complexOf_int(a); + a.im = 0; + return a; +} + +complexOf_long abs_fun_complexOf_long( complexOf_long a ) +{ + a.re = magnitude_fun_complexOf_long(a); + a.im = 0; + return a; +} + +complexOf_llong abs_fun_complexOf_llong( complexOf_llong a ) +{ + a.re = magnitude_fun_complexOf_llong(a); + a.im = 0; + return a; +} + +complexOf_uchar abs_fun_complexOf_uchar( complexOf_uchar a ) +{ + a.re = magnitude_fun_complexOf_uchar(a); + a.im = 0; + return a; +} + +complexOf_uint abs_fun_complexOf_uint( complexOf_uint a ) +{ + a.re = magnitude_fun_complexOf_uint(a); + a.im = 0; + return a; +} + +complexOf_ulong abs_fun_complexOf_ulong( complexOf_ulong a ) +{ + a.re = magnitude_fun_complexOf_ulong(a); + a.im = 0; + return a; +} + +complexOf_ullong abs_fun_complexOf_ullong( complexOf_ullong a ) +{ + a.re = magnitude_fun_complexOf_ullong(a); + a.im = 0; + return a; +} + +complexOf_float abs_fun_complexOf_float( complexOf_float a ) +{ + a.re = magnitude_fun_complexOf_float(a); + a.im = 0; + return a; +} + +unsigned abs_fun_complexOf_short( unsigned a ) +{ + return _pack2(magnitude_fun_complexOf_short(a), 0); +} + +unsigned abs_fun_complexOf_ushort( unsigned a ) +{ + return _pack2(magnitude_fun_complexOf_ushort(a), 0); +} + + + +complexOf_char signum_fun_complexOf_char( complexOf_char a ) +{ + char m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_char(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_int signum_fun_complexOf_int( complexOf_int a ) +{ + int m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_int(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_long signum_fun_complexOf_long( complexOf_long a ) +{ + long m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_long(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_llong signum_fun_complexOf_llong( complexOf_llong a ) +{ + long long m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_llong(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_uchar signum_fun_complexOf_uchar( complexOf_uchar a ) +{ + unsigned char m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_uchar(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_uint signum_fun_complexOf_uint( complexOf_uint a ) +{ + unsigned m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_uint(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_ulong signum_fun_complexOf_ulong( complexOf_ulong a ) +{ + unsigned long m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_ulong(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_ullong signum_fun_complexOf_ullong( complexOf_ullong a ) +{ + unsigned long long m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_ullong(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +complexOf_float signum_fun_complexOf_float( complexOf_float a ) +{ + float m; + if (a.re == 0 && a.im == 0) { + return a; + } else { + m = magnitude_fun_complexOf_float(a); + a.re = a.re / m; + a.im = a.im / m; + return a; + } +} + +unsigned signum_fun_complexOf_short( unsigned a ) +{ + short m; + if (a == 0) { + return a; + } else { + m = magnitude_fun_complexOf_short(a); + return _pack2((a >> 16) / m, (a & 0x0000ffff) / m); + } +} + +unsigned signum_fun_complexOf_ushort( unsigned a ) +{ + unsigned short m; + if (a == 0) { + return a; + } else { + m = magnitude_fun_complexOf_ushort(a); + return _pack2((a >> 16) / m, (a & 0x0000ffff) / m); + } +} + + + +complexOf_char add_fun_complexOf_char( complexOf_char a, complexOf_char b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_int add_fun_complexOf_int( complexOf_int a, complexOf_int b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_long add_fun_complexOf_long( complexOf_long a, complexOf_long b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_llong add_fun_complexOf_llong( complexOf_llong a, complexOf_llong b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_uchar add_fun_complexOf_uchar( complexOf_uchar a, complexOf_uchar b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_uint add_fun_complexOf_uint( complexOf_uint a, complexOf_uint b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_ulong add_fun_complexOf_ulong( complexOf_ulong a, complexOf_ulong b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_ullong add_fun_complexOf_ullong( complexOf_ullong a, complexOf_ullong b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + +complexOf_float add_fun_complexOf_float( complexOf_float a, complexOf_float b ) +{ + a.re = a.re + b.re; + a.im = a.im + b.im; + return a; +} + + + +complexOf_char sub_fun_complexOf_char( complexOf_char a, complexOf_char b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_int sub_fun_complexOf_int( complexOf_int a, complexOf_int b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_long sub_fun_complexOf_long( complexOf_long a, complexOf_long b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_llong sub_fun_complexOf_llong( complexOf_llong a, complexOf_llong b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_uchar sub_fun_complexOf_uchar( complexOf_uchar a, complexOf_uchar b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_uint sub_fun_complexOf_uint( complexOf_uint a, complexOf_uint b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_ulong sub_fun_complexOf_ulong( complexOf_ulong a, complexOf_ulong b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_ullong sub_fun_complexOf_ullong( complexOf_ullong a, complexOf_ullong b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + +complexOf_float sub_fun_complexOf_float( complexOf_float a, complexOf_float b ) +{ + a.re = a.re - b.re; + a.im = a.im - b.im; + return a; +} + + + +complexOf_char mult_fun_complexOf_char( complexOf_char a, complexOf_char b ) +{ + complexOf_char r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_int mult_fun_complexOf_int( complexOf_int a, complexOf_int b ) +{ + complexOf_int r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_long mult_fun_complexOf_long( complexOf_long a, complexOf_long b ) +{ + complexOf_long r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_llong mult_fun_complexOf_llong( complexOf_llong a, complexOf_llong b ) +{ + complexOf_llong r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_uchar mult_fun_complexOf_uchar( complexOf_uchar a, complexOf_uchar b ) +{ + complexOf_uchar r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_uint mult_fun_complexOf_uint( complexOf_uint a, complexOf_uint b ) +{ + complexOf_uint r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_ulong mult_fun_complexOf_ulong( complexOf_ulong a, complexOf_ulong b ) +{ + complexOf_ulong r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_ullong mult_fun_complexOf_ullong( complexOf_ullong a, complexOf_ullong b ) +{ + complexOf_ullong r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +complexOf_float mult_fun_complexOf_float( complexOf_float a, complexOf_float b ) +{ + complexOf_float r; + r.re = a.re * b.re - a.im * b.im; + r.im = a.im * b.re + a.re * b.im; + return r; +} + +unsigned mult_fun_complexOf_short( unsigned a, unsigned b ) +{ + short are = (short)(a >> 16); + short aim = (short)(a & 0x0000ffff); + short bre = (short)(b >> 16); + short bim = (short)(b & 0x0000ffff); + return _pack2(are * bre - aim * bim, aim * bre + are * bim); +} + +unsigned mult_fun_complexOf_ushort( unsigned a, unsigned b ) +{ + unsigned short are = (unsigned short)(a >> 16); + unsigned short aim = (unsigned short)(a & 0x0000ffff); + unsigned short bre = (unsigned short)(b >> 16); + unsigned short bim = (unsigned short)(b & 0x0000ffff); + return _pack2(are * bre - aim * bim, aim * bre + are * bim); +} + + + +complexOf_float div_fun_complexOf_float( complexOf_float a, complexOf_float b ) +{ + float x = b.re * b.re + b.im * b.im; + complexOf_float r; + r.re = (a.re * b.re + a.im * b.im) / x; + r.im = (a.im * b.re - a.re * b.im) / x; + return r; +} + + + +complexOf_float exp_fun_complexOf_float( complexOf_float a ) +{ + float expre = expf(a.re); + a.re = expre * cosf(a.im); + a.im = expre * sinf(a.im); + return a; +} + + + +complexOf_float sqrt_fun_complexOf_float( complexOf_float a ) +{ + float magare = magnitude_fun_complexOf_float(a) + a.re; + a.re = sqrtf(magare / 2); + a.im = a.im / sqrtf(2 * magare); + return a; +} + + + +complexOf_float log_fun_complexOf_float( complexOf_float a ) +{ + complexOf_float r; + r.re = logf(magnitude_fun_complexOf_float(a)); + r.im = phase_fun_complexOf_float(a); + return r; +} + + + +complexOf_float pow_fun_complexOf_float( complexOf_float a, complexOf_float b ) +{ + return exp_fun_complexOf_float(mult_fun_complexOf_float(log_fun_complexOf_float(a), b)); +} + + + +complexOf_float logBase_fun_complexOf_float( complexOf_float a, complexOf_float b ) +{ + return div_fun_complexOf_float(log_fun_complexOf_float(b), log_fun_complexOf_float(a)); +} + + + +complexOf_float sin_fun_complexOf_float( complexOf_float a ) +{ + complexOf_float r; + r.re = sinf(a.re) * coshf(a.im); + r.im = cosf(a.re) * sinhf(a.im); + return r; +} + + + +complexOf_float cos_fun_complexOf_float( complexOf_float a ) +{ + complexOf_float r; + r.re = cosf(a.re) * coshf(a.im); + r.im = - sinf(a.re) * sinhf(a.im); + return r; +} + + + +complexOf_float tan_fun_complexOf_float( complexOf_float a ) +{ + return div_fun_complexOf_float(sin_fun_complexOf_float(a), cos_fun_complexOf_float(a)); +} + + + +complexOf_float sinh_fun_complexOf_float( complexOf_float a ) +{ + complexOf_float r; + r.re = sinhf(a.re) * cosf(a.im); + r.im = coshf(a.re) * sinf(a.im); + return r; +} + + + +complexOf_float cosh_fun_complexOf_float( complexOf_float a ) +{ + complexOf_float r; + r.re = cosf(a.re) * coshf(a.im); + r.im = sinhf(a.re) * sinf(a.im); + return r; +} + + + +complexOf_float tanh_fun_complexOf_float( complexOf_float a ) +{ + return div_fun_complexOf_float(sinh_fun_complexOf_float(a), cosh_fun_complexOf_float(a)); +} + + + +complexOf_float asin_fun_complexOf_float( complexOf_float a ) +{ + complexOf_float b = add_fun_complexOf_float(log_fun_complexOf_float(complex_fun_float(-a.im, a.re)), sqrt_fun_complexOf_float(sub_fun_complexOf_float(complex_fun_float(1, 0), mult_fun_complexOf_float(a, a)))); + a.re = b.im; + a.im = -b.re; + return a; +} + + + +complexOf_float acos_fun_complexOf_float( complexOf_float a ) +{ + complexOf_float b = sqrt_fun_complexOf_float(sub_fun_complexOf_float(complex_fun_float(1, 0), mult_fun_complexOf_float(a, a))); + complexOf_float c = log_fun_complexOf_float(add_fun_complexOf_float(a, complex_fun_float(-b.im, b.re))); + a.re = c.im; + a.im = -c.re; + return a; +} + + + +complexOf_float atan_fun_complexOf_float( complexOf_float a ) +{ + complexOf_float b = log_fun_complexOf_float(div_fun_complexOf_float(complex_fun_float(1 - a.im, a.re), sqrt_fun_complexOf_float(add_fun_complexOf_float(complex_fun_float(1, 0), mult_fun_complexOf_float(a, a))))); + a.re = b.im; + a.im = -b.re; + return a; +} + + + +complexOf_float asinh_fun_complexOf_float( complexOf_float a ) +{ + return log_fun_complexOf_float(add_fun_complexOf_float(a, sqrt_fun_complexOf_float(add_fun_complexOf_float(complex_fun_float(1, 0), mult_fun_complexOf_float(a, a))))); +} + + + +complexOf_float acosh_fun_complexOf_float( complexOf_float a ) +{ + complexOf_float b = {1, 0}; + complexOf_float c = add_fun_complexOf_float(a, b); + return log_fun_complexOf_float(add_fun_complexOf_float(a, mult_fun_complexOf_float(c, sqrt_fun_complexOf_float(div_fun_complexOf_float(sub_fun_complexOf_float(a, b), c))))); +} + + + +complexOf_float atanh_fun_complexOf_float( complexOf_float a ) +{ + complexOf_float b = {1, 0}; + return log_fun_complexOf_float(div_fun_complexOf_float(add_fun_complexOf_float(b, a), sqrt_fun_complexOf_float(sub_fun_complexOf_float(b, mult_fun_complexOf_float(a, a))))); +} + + + +complexOf_char complex_fun_char( char re, char im ) +{ + complexOf_char r; + r.re = re; + r.im = im; + return r; +} + +complexOf_int complex_fun_int( int re, int im ) +{ + complexOf_int r; + r.re = re; + r.im = im; + return r; +} + +complexOf_long complex_fun_long( long re, long im ) +{ + complexOf_long r; + r.re = re; + r.im = im; + return r; +} + +complexOf_llong complex_fun_llong( long long re, long long im ) +{ + complexOf_llong r; + r.re = re; + r.im = im; + return r; +} + +complexOf_uchar complex_fun_uchar( unsigned char re, unsigned char im ) +{ + complexOf_uchar r; + r.re = re; + r.im = im; + return r; +} + +complexOf_uint complex_fun_uint( unsigned re, unsigned im ) +{ + complexOf_uint r; + r.re = re; + r.im = im; + return r; +} + +complexOf_ulong complex_fun_ulong( unsigned long re, unsigned long im ) +{ + complexOf_ulong r; + r.re = re; + r.im = im; + return r; +} + +complexOf_ullong complex_fun_ullong( unsigned long long re, unsigned long long im ) +{ + complexOf_ullong r; + r.re = re; + r.im = im; + return r; +} + +complexOf_float complex_fun_float( float re, float im ) +{ + complexOf_float r; + r.re = re; + r.im = im; + return r; +} + + + +char creal_fun_complexOf_char( complexOf_char a ) +{ + return a.re; +} + +int creal_fun_complexOf_int( complexOf_int a ) +{ + return a.re; +} + +long creal_fun_complexOf_long( complexOf_long a ) +{ + return a.re; +} + +long long creal_fun_complexOf_llong( complexOf_llong a ) +{ + return a.re; +} + +unsigned char creal_fun_complexOf_uchar( complexOf_uchar a ) +{ + return a.re; +} + +unsigned creal_fun_complexOf_uint( complexOf_uint a ) +{ + return a.re; +} + +unsigned long creal_fun_complexOf_ulong( complexOf_ulong a ) +{ + return a.re; +} + +unsigned long long creal_fun_complexOf_ullong( complexOf_ullong a ) +{ + return a.re; +} + +float creal_fun_complexOf_float( complexOf_float a ) +{ + return a.re; +} + +short creal_fun_complexOf_short( unsigned a ) +{ + return a >> 16; +} + +unsigned short creal_fun_complexOf_ushort( unsigned a ) +{ + return a >> 16; +} + + + +char cimag_fun_complexOf_char( complexOf_char a ) +{ + return a.im; +} + +int cimag_fun_complexOf_int( complexOf_int a ) +{ + return a.im; +} + +long cimag_fun_complexOf_long( complexOf_long a ) +{ + return a.im; +} + +long long cimag_fun_complexOf_llong( complexOf_llong a ) +{ + return a.im; +} + +unsigned char cimag_fun_complexOf_uchar( complexOf_uchar a ) +{ + return a.im; +} + +unsigned cimag_fun_complexOf_uint( complexOf_uint a ) +{ + return a.im; +} + +unsigned long cimag_fun_complexOf_ulong( complexOf_ulong a ) +{ + return a.im; +} + +unsigned long long cimag_fun_complexOf_ullong( complexOf_ullong a ) +{ + return a.im; +} + +float cimag_fun_complexOf_float( complexOf_float a ) +{ + return a.im; +} + +short cimag_fun_complexOf_short( unsigned a ) +{ + return a & 0x0000ffff; +} + +unsigned short cimag_fun_complexOf_ushort( unsigned a ) +{ + return a & 0x0000ffff; +} + + + +complexOf_char conj_fun_complexOf_char( complexOf_char a ) +{ + a.im = -a.im; + return a; +} + +complexOf_int conj_fun_complexOf_int( complexOf_int a ) +{ + a.im = -a.im; + return a; +} + +complexOf_long conj_fun_complexOf_long( complexOf_long a ) +{ + a.im = -a.im; + return a; +} + +complexOf_llong conj_fun_complexOf_llong( complexOf_llong a ) +{ + a.im = -a.im; + return a; +} + +complexOf_uchar conj_fun_complexOf_uchar( complexOf_uchar a ) +{ + a.im = -a.im; + return a; +} + +complexOf_uint conj_fun_complexOf_uint( complexOf_uint a ) +{ + a.im = -a.im; + return a; +} + +complexOf_ulong conj_fun_complexOf_ulong( complexOf_ulong a ) +{ + a.im = -a.im; + return a; +} + +complexOf_ullong conj_fun_complexOf_ullong( complexOf_ullong a ) +{ + a.im = -a.im; + return a; +} + +complexOf_float conj_fun_complexOf_float( complexOf_float a ) +{ + a.im = -a.im; + return a; +} + +unsigned conj_fun_complexOf_short( unsigned a ) +{ + return _pack2(a >> 16, -(a & 0x0000ffff)); +} + +unsigned conj_fun_complexOf_ushort( unsigned a ) +{ + return _pack2(a >> 16, -(a & 0x0000ffff)); +} + + + +char magnitude_fun_complexOf_char( complexOf_char a ) +{ + return roundf(hypotf(a.re, a.im)); +} + +int magnitude_fun_complexOf_int( complexOf_int a ) +{ + return roundf(hypotf(a.re, a.im)); +} + +long magnitude_fun_complexOf_long( complexOf_long a ) +{ + return roundf(hypotf(a.re, a.im)); +} + +long long magnitude_fun_complexOf_llong( complexOf_llong a ) +{ + return roundf(hypotf(a.re, a.im)); +} + +unsigned char magnitude_fun_complexOf_uchar( complexOf_uchar a ) +{ + return roundf(hypotf(a.re, a.im)); +} + +unsigned magnitude_fun_complexOf_uint( complexOf_uint a ) +{ + return roundf(hypotf(a.re, a.im)); +} + +unsigned long magnitude_fun_complexOf_ulong( complexOf_ulong a ) +{ + return roundf(hypotf(a.re, a.im)); +} + +unsigned long long magnitude_fun_complexOf_ullong( complexOf_ullong a ) +{ + return roundf(hypotf(a.re, a.im)); +} + +float magnitude_fun_complexOf_float( complexOf_float a ) +{ + return (hypotf(a.re, a.im)); +} + +short magnitude_fun_complexOf_short( unsigned a ) +{ + return roundf(hypotf((a >> 16), (a & 0x0000ffff))); +} + +unsigned short magnitude_fun_complexOf_ushort( unsigned a ) +{ + return roundf(hypotf((a >> 16), (a & 0x0000ffff))); +} + + + +char phase_fun_complexOf_char( complexOf_char a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return roundf(atan2f(a.im, a.re)); +} + +int phase_fun_complexOf_int( complexOf_int a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return roundf(atan2f(a.im, a.re)); +} + +long phase_fun_complexOf_long( complexOf_long a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return roundf(atan2f(a.im, a.re)); +} + +long long phase_fun_complexOf_llong( complexOf_llong a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return roundf(atan2f(a.im, a.re)); +} + +unsigned char phase_fun_complexOf_uchar( complexOf_uchar a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return roundf(atan2f(a.im, a.re)); +} + +unsigned phase_fun_complexOf_uint( complexOf_uint a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return roundf(atan2f(a.im, a.re)); +} + +unsigned long phase_fun_complexOf_ulong( complexOf_ulong a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return roundf(atan2f(a.im, a.re)); +} + +unsigned long long phase_fun_complexOf_ullong( complexOf_ullong a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return roundf(atan2f(a.im, a.re)); +} + +float phase_fun_complexOf_float( complexOf_float a ) +{ + if (a.re == 0 && a.im == 0) return 0; + else return (atan2f(a.im, a.re)); +} + +short phase_fun_complexOf_short( unsigned a ) +{ + short re = (a >> 16); + short im = (a & 0x0000ffff); + if (re == 0 && im == 0) return 0; + else return roundf(atan2f(im, re)); +} + +unsigned short phase_fun_complexOf_ushort( unsigned a ) +{ + unsigned short re = (a >> 16); + unsigned short im = (a & 0x0000ffff); + if (re == 0 && im == 0) return 0; + else return roundf(atan2f(im, re)); +} + + + +complexOf_char mkPolar_fun_char( char r, char t ) +{ + complexOf_char a; + a.re = roundf(r * cosf(t)); + a.im = roundf(r * sinf(t)); + return a; +} + +complexOf_int mkPolar_fun_int( int r, int t ) +{ + complexOf_int a; + a.re = roundf(r * cosf(t)); + a.im = roundf(r * sinf(t)); + return a; +} + +complexOf_long mkPolar_fun_long( long r, long t ) +{ + complexOf_long a; + a.re = roundf(r * cosf(t)); + a.im = roundf(r * sinf(t)); + return a; +} + +complexOf_llong mkPolar_fun_llong( long long r, long long t ) +{ + complexOf_llong a; + a.re = roundf(r * cosf(t)); + a.im = roundf(r * sinf(t)); + return a; +} + +complexOf_uchar mkPolar_fun_uchar( unsigned char r, unsigned char t ) +{ + complexOf_uchar a; + a.re = roundf(r * cosf(t)); + a.im = roundf(r * sinf(t)); + return a; +} + +complexOf_uint mkPolar_fun_uint( unsigned r, unsigned t ) +{ + complexOf_uint a; + a.re = roundf(r * cosf(t)); + a.im = roundf(r * sinf(t)); + return a; +} + +complexOf_ulong mkPolar_fun_ulong( unsigned long r, unsigned long t ) +{ + complexOf_ulong a; + a.re = roundf(r * cosf(t)); + a.im = roundf(r * sinf(t)); + return a; +} + +complexOf_ullong mkPolar_fun_ullong( unsigned long long r, unsigned long long t ) +{ + complexOf_ullong a; + a.re = roundf(r * cosf(t)); + a.im = roundf(r * sinf(t)); + return a; +} + +complexOf_float mkPolar_fun_float( float r, float t ) +{ + complexOf_float a; + a.re = (r * cosf(t)); + a.im = (r * sinf(t)); + return a; +} + +unsigned mkPolar_fun_short( short r, short t ) +{ + return _pack2(roundf(r * cosf(t)), roundf(r * sinf(t))); +} + +unsigned mkPolar_fun_ushort( unsigned short r, unsigned short t ) +{ + return _pack2(roundf(r * cosf(t)), roundf(r * sinf(t))); +} + + + +complexOf_char cis_fun_char( char t ) +{ + complexOf_char r; + r.re = roundf(cosf(t)); + r.im = roundf(sinf(t)); + return r; +} + +complexOf_int cis_fun_int( int t ) +{ + complexOf_int r; + r.re = roundf(cosf(t)); + r.im = roundf(sinf(t)); + return r; +} + +complexOf_long cis_fun_long( long t ) +{ + complexOf_long r; + r.re = roundf(cosf(t)); + r.im = roundf(sinf(t)); + return r; +} + +complexOf_llong cis_fun_llong( long long t ) +{ + complexOf_llong r; + r.re = roundf(cosf(t)); + r.im = roundf(sinf(t)); + return r; +} + +complexOf_uchar cis_fun_uchar( unsigned char t ) +{ + complexOf_uchar r; + r.re = roundf(cosf(t)); + r.im = roundf(sinf(t)); + return r; +} + +complexOf_uint cis_fun_uint( unsigned t ) +{ + complexOf_uint r; + r.re = roundf(cosf(t)); + r.im = roundf(sinf(t)); + return r; +} + +complexOf_ulong cis_fun_ulong( unsigned long t ) +{ + complexOf_ulong r; + r.re = roundf(cosf(t)); + r.im = roundf(sinf(t)); + return r; +} + +complexOf_ullong cis_fun_ullong( unsigned long long t ) +{ + complexOf_ullong r; + r.re = roundf(cosf(t)); + r.im = roundf(sinf(t)); + return r; +} + +complexOf_float cis_fun_float( float t ) +{ + complexOf_float r; + r.re = (cosf(t)); + r.im = (sinf(t)); + return r; +} + +unsigned cis_fun_short( short t ) +{ + return _pack2(roundf(cosf(t)), roundf(sinf(t))); +} + +unsigned cis_fun_ushort( unsigned short t ) +{ + return _pack2(roundf(cosf(t)), roundf(sinf(t))); +} + + + +/*--------------------------------------------------------------------------* + * Trace functions * + *--------------------------------------------------------------------------*/ + +static FILE *trace_log_file; +static time_t trace_start_time; + +void traceStart() +{ + char timestr [80]; + char str [256]; + struct tm * timeinfo; + trace_start_time = time(NULL); + timeinfo = localtime(&(trace_start_time)); + strftime(timestr, 80, "%Y%m%d-%H%M%S", timeinfo); + sprintf(str, "trace-%s.log", timestr); + trace_log_file = fopen(str, "a"); + if (trace_log_file == NULL) { + fprintf(stderr,"Can not open trace file.\n"); + exit (8); + } + strftime(timestr, 80, "%d-%b-%Y %H:%M:%S", timeinfo); + fprintf(trace_log_file, "Logging started at %s.\n", timestr); + fflush(trace_log_file); + trace_start_time = time(NULL); +} + +void elapsedTimeString( char* str ) +{ + sprintf(str, "%ld.000", time(NULL) - trace_start_time); +} + +void traceEnd() +{ + fprintf(trace_log_file, "Logging finished.\n"); + fclose(trace_log_file); +} + +void trace_char( char val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_short( short val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_int( int val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_long( long val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%ld\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_llong( long long val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%lld\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_uchar( unsigned char val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_ushort( unsigned short val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_uint( unsigned val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_ulong( unsigned long val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%lu\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_ullong( unsigned long long val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%llu\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_float( float val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%f\n", id, timestr, val); + fflush(trace_log_file); +} + +void trace_complexOf_char( complexOf_char val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_short( unsigned val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, (short)(val >> 16), (short)(val & 0x0000ffff)); + fflush(trace_log_file); +} + +void trace_complexOf_int( complexOf_int val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%d+%d*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_long( complexOf_long val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%ld+%ld*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_llong( complexOf_llong val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%lld+%lld*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_uchar( complexOf_uchar val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_ushort( unsigned val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, (val >> 16), (val & 0x0000ffff)); + fflush(trace_log_file); +} + +void trace_complexOf_uint( complexOf_uint val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%u+%u*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_ulong( complexOf_ulong val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%lu+%lu*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_ullong( complexOf_ullong val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%llu+%llu*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + +void trace_complexOf_float( complexOf_float val, int id ) +{ + char timestr [80]; + elapsedTimeString(timestr); + fprintf(trace_log_file, "id=%d, time=%s, value=%f+%f*I\n", id, timestr, val.re, val.im); + fflush(trace_log_file); +} + diff --git a/lib/Feldspar/C/feldspar_tic64x.h b/lib/Feldspar/C/feldspar_tic64x.h new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/feldspar_tic64x.h @@ -0,0 +1,443 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#ifndef FELDSPAR_TI_C64X_H +#define FELDSPAR_TI_C64X_H + + + +char pow_fun_char( char, char ); +short pow_fun_short( short, short ); +int pow_fun_int( int, int ); +long pow_fun_long( long, long ); +long long pow_fun_llong( long long, long long ); +unsigned char pow_fun_uchar( unsigned char, unsigned char ); +unsigned short pow_fun_ushort( unsigned short, unsigned short ); +unsigned pow_fun_uint( unsigned, unsigned ); +unsigned long pow_fun_ulong( unsigned long, unsigned long ); +unsigned long long pow_fun_ullong( unsigned long long, unsigned long long ); + +char abs_fun_char( char ); +short abs_fun_short( short ); +long abs_fun_long( long ); +long long abs_fun_llong( long long ); + +char signum_fun_char( char ); +short signum_fun_short( short ); +int signum_fun_int( int ); +long signum_fun_long( long ); +long long signum_fun_llong( long long ); +unsigned char signum_fun_uchar( unsigned char ); +unsigned short signum_fun_ushort( unsigned short ); +unsigned signum_fun_uint( unsigned ); +unsigned long signum_fun_ulong( unsigned long ); +unsigned long long signum_fun_ullong( unsigned long long ); +float signum_fun_float( float ); + +float logBase_fun_float( float, float ); + + + +char setBit_fun_char( char, unsigned ); +short setBit_fun_short( short, unsigned ); +int setBit_fun_int( int, unsigned ); +long setBit_fun_long( long, unsigned ); +long long setBit_fun_llong( long long, unsigned ); +unsigned char setBit_fun_uchar( unsigned char, unsigned ); +unsigned short setBit_fun_ushort( unsigned short, unsigned ); +unsigned setBit_fun_uint( unsigned, unsigned ); +unsigned long setBit_fun_ulong( unsigned long, unsigned ); +unsigned long long setBit_fun_ullong( unsigned long long, unsigned ); + +char clearBit_fun_char( char, unsigned ); +short clearBit_fun_short( short, unsigned ); +int clearBit_fun_int( int, unsigned ); +long clearBit_fun_long( long, unsigned ); +long long clearBit_fun_llong( long long, unsigned ); +unsigned char clearBit_fun_uchar( unsigned char, unsigned ); +unsigned short clearBit_fun_ushort( unsigned short, unsigned ); +unsigned clearBit_fun_uint( unsigned, unsigned ); +unsigned long clearBit_fun_ulong( unsigned long, unsigned ); +unsigned long long clearBit_fun_ullong( unsigned long long, unsigned ); + +char complementBit_fun_char( char, unsigned ); +short complementBit_fun_short( short, unsigned ); +int complementBit_fun_int( int, unsigned ); +long complementBit_fun_long( long, unsigned ); +long long complementBit_fun_llong( long long, unsigned ); +unsigned char complementBit_fun_uchar( unsigned char, unsigned ); +unsigned short complementBit_fun_ushort( unsigned short, unsigned ); +unsigned complementBit_fun_uint( unsigned, unsigned ); +unsigned long complementBit_fun_ulong( unsigned long, unsigned ); +unsigned long long complementBit_fun_ullong( unsigned long long, unsigned ); + +int testBit_fun_char( char, unsigned ); +int testBit_fun_short( short, unsigned ); +int testBit_fun_int( int, unsigned ); +int testBit_fun_long( long, unsigned ); +int testBit_fun_llong( long long, unsigned ); +int testBit_fun_uchar( unsigned char, unsigned ); +int testBit_fun_ushort( unsigned short, unsigned ); +int testBit_fun_uint( unsigned, unsigned ); +int testBit_fun_ulong( unsigned long, unsigned ); +int testBit_fun_ullong( unsigned long long, unsigned ); + +char rotateL_fun_char( char, int ); +short rotateL_fun_short( short, int ); +long rotateL_fun_long( long, int ); +long long rotateL_fun_llong( long long, int ); +int rotateL_fun_int( int, int ); +unsigned char rotateL_fun_uchar( unsigned char, int ); +unsigned short rotateL_fun_ushort( unsigned short, int ); +unsigned long rotateL_fun_ulong( unsigned long, int ); +unsigned long long rotateL_fun_ullong( unsigned long long, int ); + +char rotateR_fun_char( char, int ); +short rotateR_fun_short( short, int ); +int rotateR_fun_int( int, int ); +long rotateR_fun_long( long, int ); +long long rotateR_fun_llong( long long, int ); +unsigned char rotateR_fun_uchar( unsigned char, int ); +unsigned short rotateR_fun_ushort( unsigned short, int ); +unsigned rotateR_fun_uint( unsigned, int ); +unsigned long rotateR_fun_ulong( unsigned long, int ); +unsigned long long rotateR_fun_ullong( unsigned long long, int ); + +char reverseBits_fun_char( char ); +short reverseBits_fun_short( short ); +int reverseBits_fun_int( int ); +long reverseBits_fun_long( long ); +long long reverseBits_fun_llong( long long ); +unsigned char reverseBits_fun_uchar( unsigned char ); +unsigned short reverseBits_fun_ushort( unsigned short ); +unsigned long reverseBits_fun_ulong( unsigned long ); +unsigned long long reverseBits_fun_ullong( unsigned long long ); + +unsigned bitScan_fun_char( char ); +unsigned bitScan_fun_short( short ); +unsigned bitScan_fun_int( int ); +unsigned bitScan_fun_long( long ); +unsigned bitScan_fun_llong( long long ); +unsigned bitScan_fun_uchar( unsigned char ); +unsigned bitScan_fun_ushort( unsigned short ); +unsigned bitScan_fun_uint( unsigned ); +unsigned bitScan_fun_ulong( unsigned long ); +unsigned bitScan_fun_ullong( unsigned long long ); + +unsigned bitCount_fun_char( char ); +unsigned bitCount_fun_short( short ); +unsigned bitCount_fun_int( int ); +unsigned bitCount_fun_long( long ); +unsigned bitCount_fun_llong( long long ); +unsigned bitCount_fun_uchar( unsigned char ); +unsigned bitCount_fun_ushort( unsigned short ); +unsigned bitCount_fun_ulong( unsigned long ); +unsigned bitCount_fun_ullong( unsigned long long ); + + + +typedef struct { + char re; + char im; +} complexOf_char; + +typedef struct { + int re; + int im; +} complexOf_int; + +typedef struct { + long re; + long im; +} complexOf_long; + +typedef struct { + long long re; + long long im; +} complexOf_llong; + +typedef struct { + unsigned char re; + unsigned char im; +} complexOf_uchar; + +typedef struct { + unsigned re; + unsigned im; +} complexOf_uint; + +typedef struct { + unsigned long re; + unsigned long im; +} complexOf_ulong; + +typedef struct { + unsigned long long re; + unsigned long long im; +} complexOf_ullong; + +typedef struct { + float re; + float im; +} complexOf_float; + +int equal_fun_complexOf_char( complexOf_char, complexOf_char ); +int equal_fun_complexOf_int( complexOf_int, complexOf_int ); +int equal_fun_complexOf_long( complexOf_long, complexOf_long ); +int equal_fun_complexOf_llong( complexOf_llong, complexOf_llong ); +int equal_fun_complexOf_uchar( complexOf_uchar, complexOf_uchar ); +int equal_fun_complexOf_uint( complexOf_uint, complexOf_uint ); +int equal_fun_complexOf_ulong( complexOf_ulong, complexOf_ulong ); +int equal_fun_complexOf_ullong( complexOf_ullong, complexOf_ullong ); +int equal_fun_complexOf_float( complexOf_float, complexOf_float ); + +complexOf_char negate_fun_complexOf_char( complexOf_char ); +complexOf_int negate_fun_complexOf_int( complexOf_int ); +complexOf_long negate_fun_complexOf_long( complexOf_long ); +complexOf_llong negate_fun_complexOf_llong( complexOf_llong ); +complexOf_uchar negate_fun_complexOf_uchar( complexOf_uchar ); +complexOf_uint negate_fun_complexOf_uint( complexOf_uint ); +complexOf_ulong negate_fun_complexOf_ulong( complexOf_ulong ); +complexOf_ullong negate_fun_complexOf_ullong( complexOf_ullong ); +complexOf_float negate_fun_complexOf_float( complexOf_float ); + +complexOf_char abs_fun_complexOf_char( complexOf_char ); +complexOf_int abs_fun_complexOf_int( complexOf_int ); +complexOf_long abs_fun_complexOf_long( complexOf_long ); +complexOf_llong abs_fun_complexOf_llong( complexOf_llong ); +complexOf_uchar abs_fun_complexOf_uchar( complexOf_uchar ); +complexOf_uint abs_fun_complexOf_uint( complexOf_uint ); +complexOf_ulong abs_fun_complexOf_ulong( complexOf_ulong ); +complexOf_ullong abs_fun_complexOf_ullong( complexOf_ullong ); +complexOf_float abs_fun_complexOf_float( complexOf_float ); +unsigned abs_fun_complexOf_short( unsigned ); +unsigned abs_fun_complexOf_ushort( unsigned ); + +complexOf_char signum_fun_complexOf_char( complexOf_char ); +complexOf_int signum_fun_complexOf_int( complexOf_int ); +complexOf_long signum_fun_complexOf_long( complexOf_long ); +complexOf_llong signum_fun_complexOf_llong( complexOf_llong ); +complexOf_uchar signum_fun_complexOf_uchar( complexOf_uchar ); +complexOf_uint signum_fun_complexOf_uint( complexOf_uint ); +complexOf_ulong signum_fun_complexOf_ulong( complexOf_ulong ); +complexOf_ullong signum_fun_complexOf_ullong( complexOf_ullong ); +complexOf_float signum_fun_complexOf_float( complexOf_float ); +unsigned signum_fun_complexOf_short( unsigned ); +unsigned signum_fun_complexOf_ushort( unsigned ); + +complexOf_char add_fun_complexOf_char( complexOf_char, complexOf_char ); +complexOf_int add_fun_complexOf_int( complexOf_int, complexOf_int ); +complexOf_long add_fun_complexOf_long( complexOf_long, complexOf_long ); +complexOf_llong add_fun_complexOf_llong( complexOf_llong, complexOf_llong ); +complexOf_uchar add_fun_complexOf_uchar( complexOf_uchar, complexOf_uchar ); +complexOf_uint add_fun_complexOf_uint( complexOf_uint, complexOf_uint ); +complexOf_ulong add_fun_complexOf_ulong( complexOf_ulong, complexOf_ulong ); +complexOf_ullong add_fun_complexOf_ullong( complexOf_ullong, complexOf_ullong ); +complexOf_float add_fun_complexOf_float( complexOf_float, complexOf_float ); + +complexOf_char sub_fun_complexOf_char( complexOf_char, complexOf_char ); +complexOf_int sub_fun_complexOf_int( complexOf_int, complexOf_int ); +complexOf_long sub_fun_complexOf_long( complexOf_long, complexOf_long ); +complexOf_llong sub_fun_complexOf_llong( complexOf_llong, complexOf_llong ); +complexOf_uchar sub_fun_complexOf_uchar( complexOf_uchar, complexOf_uchar ); +complexOf_uint sub_fun_complexOf_uint( complexOf_uint, complexOf_uint ); +complexOf_ulong sub_fun_complexOf_ulong( complexOf_ulong, complexOf_ulong ); +complexOf_ullong sub_fun_complexOf_ullong( complexOf_ullong, complexOf_ullong ); +complexOf_float sub_fun_complexOf_float( complexOf_float, complexOf_float ); + +complexOf_char mult_fun_complexOf_char( complexOf_char, complexOf_char ); +complexOf_int mult_fun_complexOf_int( complexOf_int, complexOf_int ); +complexOf_long mult_fun_complexOf_long( complexOf_long, complexOf_long ); +complexOf_llong mult_fun_complexOf_llong( complexOf_llong, complexOf_llong ); +complexOf_uchar mult_fun_complexOf_uchar( complexOf_uchar, complexOf_uchar ); +complexOf_uint mult_fun_complexOf_uint( complexOf_uint, complexOf_uint ); +complexOf_ulong mult_fun_complexOf_ulong( complexOf_ulong, complexOf_ulong ); +complexOf_ullong mult_fun_complexOf_ullong( complexOf_ullong, complexOf_ullong ); +complexOf_float mult_fun_complexOf_float( complexOf_float, complexOf_float ); +unsigned mult_fun_complexOf_short( unsigned, unsigned ); +unsigned mult_fun_complexOf_ushort( unsigned, unsigned ); + +complexOf_float div_fun_complexOf_float( complexOf_float, complexOf_float ); + +complexOf_float exp_fun_complexOf_float( complexOf_float ); + +complexOf_float sqrt_fun_complexOf_float( complexOf_float ); + +complexOf_float log_fun_complexOf_float( complexOf_float ); + +complexOf_float pow_fun_complexOf_float( complexOf_float, complexOf_float ); + +complexOf_float logBase_fun_complexOf_float( complexOf_float, complexOf_float ); + +complexOf_float sin_fun_complexOf_float( complexOf_float ); + +complexOf_float cos_fun_complexOf_float( complexOf_float ); + +complexOf_float tan_fun_complexOf_float( complexOf_float ); + +complexOf_float sinh_fun_complexOf_float( complexOf_float ); + +complexOf_float cosh_fun_complexOf_float( complexOf_float ); + +complexOf_float tanh_fun_complexOf_float( complexOf_float ); + +complexOf_float asin_fun_complexOf_float( complexOf_float ); + +complexOf_float acos_fun_complexOf_float( complexOf_float ); + +complexOf_float atan_fun_complexOf_float( complexOf_float ); + +complexOf_float asinh_fun_complexOf_float( complexOf_float ); + +complexOf_float acosh_fun_complexOf_float( complexOf_float ); + +complexOf_float atanh_fun_complexOf_float( complexOf_float ); + +complexOf_char complex_fun_char( char, char ); +complexOf_int complex_fun_int( int, int ); +complexOf_long complex_fun_long( long, long ); +complexOf_llong complex_fun_llong( long long, long long ); +complexOf_uchar complex_fun_uchar( unsigned char, unsigned char ); +complexOf_uint complex_fun_uint( unsigned, unsigned ); +complexOf_ulong complex_fun_ulong( unsigned long, unsigned long ); +complexOf_ullong complex_fun_ullong( unsigned long long, unsigned long long ); +complexOf_float complex_fun_float( float, float ); + +char creal_fun_complexOf_char( complexOf_char ); +int creal_fun_complexOf_int( complexOf_int ); +long creal_fun_complexOf_long( complexOf_long ); +long long creal_fun_complexOf_llong( complexOf_llong ); +unsigned char creal_fun_complexOf_uchar( complexOf_uchar ); +unsigned creal_fun_complexOf_uint( complexOf_uint ); +unsigned long creal_fun_complexOf_ulong( complexOf_ulong ); +unsigned long long creal_fun_complexOf_ullong( complexOf_ullong ); +float creal_fun_complexOf_float( complexOf_float ); +short creal_fun_complexOf_short( unsigned ); +unsigned short creal_fun_complexOf_ushort( unsigned ); + +char cimag_fun_complexOf_char( complexOf_char ); +int cimag_fun_complexOf_int( complexOf_int ); +long cimag_fun_complexOf_long( complexOf_long ); +long long cimag_fun_complexOf_llong( complexOf_llong ); +unsigned char cimag_fun_complexOf_uchar( complexOf_uchar ); +unsigned cimag_fun_complexOf_uint( complexOf_uint ); +unsigned long cimag_fun_complexOf_ulong( complexOf_ulong ); +unsigned long long cimag_fun_complexOf_ullong( complexOf_ullong ); +float cimag_fun_complexOf_float( complexOf_float ); +short cimag_fun_complexOf_short( unsigned ); +unsigned short cimag_fun_complexOf_ushort( unsigned ); + +complexOf_char conj_fun_complexOf_char( complexOf_char ); +complexOf_int conj_fun_complexOf_int( complexOf_int ); +complexOf_long conj_fun_complexOf_long( complexOf_long ); +complexOf_llong conj_fun_complexOf_llong( complexOf_llong ); +complexOf_uchar conj_fun_complexOf_uchar( complexOf_uchar ); +complexOf_uint conj_fun_complexOf_uint( complexOf_uint ); +complexOf_ulong conj_fun_complexOf_ulong( complexOf_ulong ); +complexOf_ullong conj_fun_complexOf_ullong( complexOf_ullong ); +complexOf_float conj_fun_complexOf_float( complexOf_float ); +unsigned conj_fun_complexOf_short( unsigned ); +unsigned conj_fun_complexOf_ushort( unsigned ); + +char magnitude_fun_complexOf_char( complexOf_char ); +int magnitude_fun_complexOf_int( complexOf_int ); +long magnitude_fun_complexOf_long( complexOf_long ); +long long magnitude_fun_complexOf_llong( complexOf_llong ); +unsigned char magnitude_fun_complexOf_uchar( complexOf_uchar ); +unsigned magnitude_fun_complexOf_uint( complexOf_uint ); +unsigned long magnitude_fun_complexOf_ulong( complexOf_ulong ); +unsigned long long magnitude_fun_complexOf_ullong( complexOf_ullong ); +float magnitude_fun_complexOf_float( complexOf_float ); +short magnitude_fun_complexOf_short( unsigned ); +unsigned short magnitude_fun_complexOf_ushort( unsigned ); + +char phase_fun_complexOf_char( complexOf_char ); +int phase_fun_complexOf_int( complexOf_int ); +long phase_fun_complexOf_long( complexOf_long ); +long long phase_fun_complexOf_llong( complexOf_llong ); +unsigned char phase_fun_complexOf_uchar( complexOf_uchar ); +unsigned phase_fun_complexOf_uint( complexOf_uint ); +unsigned long phase_fun_complexOf_ulong( complexOf_ulong ); +unsigned long long phase_fun_complexOf_ullong( complexOf_ullong ); +float phase_fun_complexOf_float( complexOf_float ); +short phase_fun_complexOf_short( unsigned ); +unsigned short phase_fun_complexOf_ushort( unsigned ); + +complexOf_char mkPolar_fun_char( char, char ); +complexOf_int mkPolar_fun_int( int, int ); +complexOf_long mkPolar_fun_long( long, long ); +complexOf_llong mkPolar_fun_llong( long long, long long ); +complexOf_uchar mkPolar_fun_uchar( unsigned char, unsigned char ); +complexOf_uint mkPolar_fun_uint( unsigned, unsigned ); +complexOf_ulong mkPolar_fun_ulong( unsigned long, unsigned long ); +complexOf_ullong mkPolar_fun_ullong( unsigned long long, unsigned long long ); +complexOf_float mkPolar_fun_float( float, float ); +unsigned mkPolar_fun_short( short, short ); +unsigned mkPolar_fun_ushort( unsigned short, unsigned short ); + +complexOf_char cis_fun_char( char ); +complexOf_int cis_fun_int( int ); +complexOf_long cis_fun_long( long ); +complexOf_llong cis_fun_llong( long long ); +complexOf_uchar cis_fun_uchar( unsigned char ); +complexOf_uint cis_fun_uint( unsigned ); +complexOf_ulong cis_fun_ulong( unsigned long ); +complexOf_ullong cis_fun_ullong( unsigned long long ); +complexOf_float cis_fun_float( float ); +unsigned cis_fun_short( short ); +unsigned cis_fun_ushort( unsigned short ); + + + +void traceStart(); +void traceEnd(); + +void trace_char( char, int ); +void trace_short( short, int ); +void trace_int( int, int ); +void trace_long( long, int ); +void trace_llong( long long, int ); +void trace_uchar( unsigned char, int ); +void trace_ushort( unsigned short, int ); +void trace_uint( unsigned, int ); +void trace_ulong( unsigned long, int ); +void trace_ullong( unsigned long long, int ); +void trace_float( float, int ); +void trace_complexOf_char( complexOf_char, int ); +void trace_complexOf_short( unsigned, int ); +void trace_complexOf_int( complexOf_int, int ); +void trace_complexOf_long( complexOf_long, int ); +void trace_complexOf_llong( complexOf_llong, int ); +void trace_complexOf_uchar( complexOf_uchar, int ); +void trace_complexOf_ushort( unsigned, int ); +void trace_complexOf_uint( complexOf_uint, int ); +void trace_complexOf_ulong( complexOf_ulong, int ); +void trace_complexOf_ullong( complexOf_ullong, int ); +void trace_complexOf_float( complexOf_float, int ); + +#endif /* FELDSPAR_TI_C64X_H */ diff --git a/lib/Feldspar/C/ivar.c b/lib/Feldspar/C/ivar.c new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/ivar.c @@ -0,0 +1,204 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#include "ivar.h" +#include +#include +//#define LOG +#include "log.h" + +unsigned int ivar_linker_hook = 0xDECAFBAD; + +void *worker( void *p ); + +void ivar_init( struct ivar *iv ) +{ + struct ivar_internals *ivi; + int err; + log_1("ivar_init %p - enter\n", iv); + ivi = iv->internals = (struct ivar_internals*)malloc( sizeof(struct ivar_internals) ); + err = pthread_mutex_init( &(ivi->mutex), NULL ); + if (err) exit(err); + err = pthread_cond_init( &(ivi->cond), NULL ); + if (err) exit(err); + ivi->full = 0; + iv->self = iv; + log_1("ivar_init %p - leave\n", iv); +} + +void ivar_destroy( struct ivar *iv ) // TODO: Think about ivars escaping from their scope... +{ + log_1("ivar_destroy %p - enter\n", iv); + // if( iv->self == iv ) // This is true iff this iVar is not a copy. + // { + // struct ivar_internals *ivi = iv->internals; + // pthread_mutex_destroy( &(ivi->mutex) ); + // pthread_cond_destroy( &(ivi->cond) ); + // if( ivi->full ) + // free( ivi->data ); + // free( ivi ); + // } + log_1("ivar_destroy %p - leave\n", iv); +} + +void ivar_put_with_size( struct ivar iv, void *d, int size ) +{ + struct ivar_internals *ivi = iv.internals; + log_3("ivar_put_with_size %p %p %d - enter\n", &iv, d, size); + pthread_mutex_lock( &(ivi->mutex) ); + ivi->data = (void*)malloc( size ); + memcpy( ivi->data, d, size ); + ivi->full = 1; + pthread_cond_broadcast( &(ivi->cond) ); + pthread_mutex_unlock( &(ivi->mutex) ); + log_3("ivar_put_with_size %p %p %d - leave\n", &iv, d, size); +} + +void ivar_put_array( struct ivar iv, struct array *d ) +{ + struct ivar_internals *ivi = iv.internals; + log_2("ivar_put_array %p %p - enter\n", &iv, d); + pthread_mutex_lock( &(ivi->mutex) ); + ivi->data = (void*)malloc( sizeof(struct array) ); + initArray( ivi->data, d->elemSize, d->length ); + copyArray( ivi->data, d ); + ivi->full = 1; + pthread_cond_broadcast( &(ivi->cond) ); + pthread_mutex_unlock( &(ivi->mutex) ); + log_2("ivar_put_array %p %p - leave\n", &iv, d); +} + +void ivar_get_helper( struct ivar_internals *iv ) +{ + log_1("ivar_get_helper %p - enter\n", iv); + pthread_mutex_lock( &(iv->mutex) ); + if( !iv->full ) + { + log_1("ivar_get_helper %p - ivar is empty\n", iv); + int create = 0; + pthread_mutex_lock( &(feldspar_taskpool.mutex) ); + if( !feldspar_taskpool.shutdown && (feldspar_taskpool.num_threads <= feldspar_taskpool.min_threads) ) + { + create = 1; + ++feldspar_taskpool.num_threads; + log_3("ivar_get_helper %p - will create a new thread; " + "active: %d, all: %d\n" + , iv, feldspar_taskpool.act_threads, feldspar_taskpool.num_threads); + } + else + { + --feldspar_taskpool.act_threads; + log_3("ivar_get_helper %p - will NOT create a new thread; " + "active: %d, all: %d\n" + , iv, feldspar_taskpool.act_threads, feldspar_taskpool.num_threads); + } + pthread_mutex_unlock( &(feldspar_taskpool.mutex) ); + if( create ) + { + pthread_t th; + pthread_create( &th, NULL, &worker, (void*)&feldspar_taskpool ); + } + log_1("ivar_get_helper %p - blocking while waiting for data\n", iv); + pthread_cond_wait( &(iv->cond), &(iv->mutex) ); + pthread_mutex_lock( &(feldspar_taskpool.mutex) ); + ++feldspar_taskpool.act_threads; + log_3("ivar_get_helper %p - data arrived; active: %d, all: %d\n" + , iv, feldspar_taskpool.act_threads, feldspar_taskpool.num_threads); + pthread_mutex_unlock( &(feldspar_taskpool.mutex) ); + } + pthread_mutex_unlock( &(iv->mutex) ); + log_1("ivar_get_helper %p - leave\n", iv); +} + +void ivar_get_with_size( void *var, struct ivar iv, int size ) +{ + log_3("ivar_get_with_size %p %p %d - enter\n", var, &iv, size); + ivar_get_helper(iv.internals); + memcpy( var, iv.internals->data, size ); + log_3("ivar_get_with_size %p %p %d - leave\n", var, &iv, size); +} + +void ivar_get_array( struct array *var, struct ivar iv ) +{ + struct array *ptr; + log_2("ivar_get_array %p %p - enter\n", var, &iv); + ivar_get_helper(iv.internals); + ptr = (struct array*)iv.internals->data; + assert(ptr); + initArray( var, ptr->elemSize, ptr->length ); + copyArray( var, ptr ); + log_2("ivar_get_array %p %p - leave\n", var, &iv); +} + +void ivar_get_nontask_with_size( void *var, struct ivar iv, int size ) +{ + struct ivar_internals *ivi = iv.internals; + log_3("ivar_get_nontask_with_size %p %p %d - enter\n", var, &iv, size); + pthread_mutex_lock( &(ivi->mutex) ); + if ( !ivi->full ) + log_3("ivar_get_nontask_with_size %p %p %d -> waiting for data\n" + , var, &iv, size); + while( !ivi->full ) + { + int err = pthread_cond_wait( &(ivi->cond), &(ivi->mutex) ); + if (err) { exit(err); } + } + pthread_mutex_unlock( &(ivi->mutex) ); + assert(ivi->data); + memcpy( var, ivi->data, size ); + log_3("ivar_get_nontask_with_size %p %p %d - leave\n", var, &iv, size); +} + +void ivar_get_array_nontask( struct array *var, struct ivar iv ) +{ + struct ivar_internals *ivi = iv.internals; + struct array *ptr; + log_2("ivar_get_array_nontask %p %p - enter\n", var, &iv); + pthread_mutex_lock( &(ivi->mutex) ); + if ( !ivi->full ) + log_2("ivar_get_array_nontask %p %p - waiting for data\n", var, &iv); + while(!ivi->full) + { + int err = pthread_cond_wait( &(ivi->cond), &(ivi->mutex) ); + if (err) { exit(err); } + } + assert(ivi->full); + pthread_mutex_unlock( &(ivi->mutex) ); + if (NULL == ivi->data) + { + log_2("ivar_get_array_nontask %p %p - data uninitialized\n", var, &iv); + } + else + { + ptr = (struct array*)ivi->data; + initArray( var, ptr->elemSize, ptr->length ); + copyArray( var, ptr ); + } + log_2("ivar_get_array_nontask %p %p - leave\n", var, &iv); +} + diff --git a/lib/Feldspar/C/ivar.h b/lib/Feldspar/C/ivar.h new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/ivar.h @@ -0,0 +1,93 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#ifndef IVAR_H +#define IVAR_H + +#include +#include "taskpool.h" +#include "feldspar_array.h" + +/* Declaration of the Feldspar application's global taskpool. */ +extern struct taskpool feldspar_taskpool; + +struct ivar_internals +{ + pthread_mutex_t mutex; + pthread_cond_t cond; + int full; + void *data; +}; + +struct ivar +{ + struct ivar_internals *internals; + struct ivar *self; +}; + +/* Initializes 'iv'. */ +void ivar_init( struct ivar *iv ); + +/* Deinitializes ivar 'iv'. */ +void ivar_destroy( struct ivar *iv ); + +/* Copies the data at 'd' of size 'size' into the ivar 'iv'. Ivars are + * allowed to be written only once! */ +void ivar_put_with_size( struct ivar iv, void *d, int size ); + +/* Wrapper to 'ivar_put_with_size'. */ +#define ivar_put(typ,iv,d) ivar_put_with_size(iv,d,sizeof(typ)) + +/* Specialized version for arrays. */ +void ivar_put_array( struct ivar iv, struct array *d ); + +/* Copies the data of size 'size' of the ivar 'iv' to 'var'. Ivars are + * allowed to be read any number of times. Reading an empty ivar blocks + * the thread, but a new worker thread is started instead. + * Use this function only inside tasks! */ +void ivar_get_with_size( void *var, struct ivar iv, int size ); + +/* Wrapper to 'ivar_get_with_size'. */ +#define ivar_get(typ,var,iv) ivar_get_with_size(var,iv,sizeof(typ)) + +/* Specialized version for arrays. */ +void ivar_get_array( struct array *var, struct ivar iv ); + +/* Copies the data of size 'size' of the ivar 'iv' to 'var'. Ivars are + * allowed to be read any number of times. Reading an empty ivar blocks + * the thread. + * Use this function only outside tasks, eg. the main thread or similar! */ +void ivar_get_nontask_with_size( void *var, struct ivar iv, int size ); + +/* Wrapper to 'ivar_get_nontask_with_size'. */ +#define ivar_get_nontask(typ,var,iv) ivar_get_nontask_with_size(var,iv,sizeof(typ)) + +/* Specialized version for arrays. */ +void ivar_get_array_nontask( struct array *var, struct ivar iv ); + +#endif /* IVAR_H */ diff --git a/lib/Feldspar/C/log.h b/lib/Feldspar/C/log.h new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/log.h @@ -0,0 +1,50 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#ifndef LOG_H +#define LOG_H + +#include + +#ifdef LOG + #define log_0(text) printf(text) + #define log_1(text,x1) printf(text,x1) + #define log_2(text,x1,x2) printf(text,x1,x2) + #define log_3(text,x1,x2,x3) printf(text,x1,x2,x3) + #define log_4(text,x1,x2,x3,x4) printf(text,x1,x2,x3,x4) + #define log_5(text,x1,x2,x3,x4,x5) printf(text,x1,x2,x3,x4,x5) +#else + #define log_0(text) + #define log_1(text,x1) + #define log_2(text,x1,x2) + #define log_3(text,x1,x2,x3) + #define log_4(text,x1,x2,x3,x4) + #define log_5(text,x1,x2,x3,x4,x5) +#endif + +#endif /* LOG_H */ diff --git a/lib/Feldspar/C/taskpool.c b/lib/Feldspar/C/taskpool.c new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/taskpool.c @@ -0,0 +1,164 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#include +#include +#include "taskpool.h" +//#define LOG +#include "log.h" + +unsigned int taskpool_linker_hook = 0xDECAFBAD; + +/* Definition of the Feldspar application's global taskpool. */ +struct taskpool *feldspar_taskpool = 0; + +void *worker(); + +void taskpool_init( int c, int n, int m ) +{ + log_3("taskpool_init %d %d %d - enter\n",c,n,m); + log_0("taskpool_init - allocating taskpool\n"); + feldspar_taskpool = malloc(sizeof(struct taskpool)); + log_1("taskpool_init - allocating %d closures\n",c); + feldspar_taskpool->closures = malloc( c * sizeof(void*) ); + feldspar_taskpool->capacity = c; + feldspar_taskpool->head = 0; + feldspar_taskpool->tail = 0; + feldspar_taskpool->shutdown = 0; + feldspar_taskpool->num_threads = n; + feldspar_taskpool->act_threads = n; + feldspar_taskpool->min_threads = m; + feldspar_taskpool->max_threads = n; + if( n > 0 ) + pthread_mutex_init( &(feldspar_taskpool->mutex), NULL ); + log_1("taskpool_init - starting %d threads\n",n); + for( ; n > 0; --n ) + { + pthread_t th; + pthread_create( &th, NULL, &worker, NULL ); + log_1("taskpool_init - thread %p created\n", &th); + } + log_0("taskpool_init - leave\n"); +} + +void taskpool_shutdown() +{ + log_0("taskpool_shutdown - enter\n"); + feldspar_taskpool->shutdown = 1; + log_0("taskpool_shutdown - leave\n"); +} + +void spawn( void *closure ) +{ + log_1("spawn %p - enter\n", closure); + pthread_mutex_lock( &(feldspar_taskpool->mutex) ); + feldspar_taskpool->closures[feldspar_taskpool->tail] = closure; + log_3("spawn %p - saved as task %d at %p\n" + , closure, feldspar_taskpool->tail + , &feldspar_taskpool->closures[feldspar_taskpool->tail]); + ++feldspar_taskpool->tail; + if( feldspar_taskpool->tail == feldspar_taskpool->capacity ) + feldspar_taskpool->tail = 0; + pthread_mutex_unlock( &(feldspar_taskpool->mutex) ); + log_1("spawn %p - leave\n", closure); +} + +void *worker() +{ + unsigned int self; + self = (unsigned long)pthread_self(); + log_1("worker %d - enter\n", self); + struct taskpool *pool = feldspar_taskpool; + void (*fun)(); + char *closure; + int awake = 1; + log_1("worker %d - entering the loop\n", self); + while(1) + { + if( pool->shutdown && pool->head == pool->tail ) + { + log_1("worker %d - shutdown detected, going to terminate\n", self); + break; + } + if( pool->act_threads > pool->max_threads ) + { + log_1("worker %d - too many active threads, going to terminate\n", self); + break; + } + fun = NULL; + closure = NULL; + pthread_mutex_lock( &(pool->mutex) ); + if( pool->head != pool->tail ) + { + log_2("worker %d - pop task %d\n", self, pool->head); + closure = pool->closures[pool->head]; + ++pool->head; + if( pool->head == pool->capacity ) + pool->head = 0; + } + else { + } + pthread_mutex_unlock( &(pool->mutex) ); + if( closure == NULL ) + { + if (1 == awake) + { + log_1("worker %d - sleep\n", self); + awake = 0; + } + } + else + { + awake = 1; + fun = *((void(**)())closure); + log_2("worker %d - closure %p enter\n", self, fun); + fun( closure + sizeof(void(*)()) ); /* TODO: sizeof(void*) == sizeof(void(**)()) is assumed here */ + log_2("worker %d - closure %p leave\n", self, fun); + } + } + /* Cleanup before exit: */ + { + int last = 0; + log_1("worker %d - cleanup\n", self); + pthread_mutex_lock( &(pool->mutex) ); + --pool->num_threads; + --pool->act_threads; + log_3("worker %d - cleanup done; active: %d, all: %d\n" + , self, pool->act_threads, pool->num_threads); + last = (pool->num_threads == 0); + pthread_mutex_unlock( &(pool->mutex) ); + if( last ) + { + log_1("worker %d - last one does extra cleanup\n", self); + pthread_mutex_destroy( &(pool->mutex) ); + } + } + log_1("worker %d - leave\n", self); + pthread_exit(NULL); +} + diff --git a/lib/Feldspar/C/taskpool.h b/lib/Feldspar/C/taskpool.h new file mode 100644 --- /dev/null +++ b/lib/Feldspar/C/taskpool.h @@ -0,0 +1,372 @@ +// +// Copyright (c) 2009-2011, ERICSSON AB +// All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are met: +// +// * Redistributions of source code must retain the above copyright notice, +// this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// * Neither the name of the ERICSSON AB nor the names of its contributors +// may be used to endorse or promote products derived from this software +// without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +// DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +// FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// + +#ifndef TASKPOOL_H +#define TASKPOOL_H + +#include + +struct taskpool +{ + int capacity; + int num_threads, act_threads, min_threads, max_threads; + int head, tail; + void **closures; + int shutdown; + pthread_mutex_t mutex; +}; + +void taskpool_init( int c, int num, int min ); + +void taskpool_shutdown(); + +void spawn( void *closure ); + +/* Helper macro: */ +/* TODO: Replace runtime check with a compile time one! */ +#define check_array( t, temp ) \ + if( !strcmp(#t,"struct array *") ) \ + { \ + void *m = malloc( sizeof(struct array) ); \ + memcpy( m, *(void**)(&(temp)), sizeof(struct array) ); \ + memcpy( (void*)&(temp), (void*)&m, sizeof(void*) ); \ + } \ + +/* Wrappers for spawn with different number of arguments: */ + +#define spawn0( task ) \ + { \ + void *buffer = malloc( sizeof(void(*)()) ); \ + char *p = buffer; \ + void *t0 = (task); \ + memcpy( p, &t0, sizeof(void(*)()) ); \ + spawn( buffer ); \ + } \ + +#define spawn1( task, t1, p1 ) \ + { \ + void *buffer = malloc( sizeof(void(*)()) + sizeof(t1) ); \ + char *p = buffer; \ + void *t0 = task; \ + t1 temp1 = (p1); \ + memcpy( p, &t0, sizeof(void(*)()) ); \ + p += sizeof(void(*)()); \ + check_array( t1, temp1 ); \ + memcpy( p, &temp1, sizeof(t1) ); \ + spawn( buffer ); \ + } \ + +#define spawn2( task, t1, p1, t2, p2 ) \ + { \ + void *buffer = malloc( sizeof(void(*)()) + sizeof(t1) + sizeof(t2) ); \ + char *p = buffer; \ + void *t0 = task; \ + t1 temp1 = (p1); \ + t2 temp2 = (p2); \ + memcpy( p, &t0, sizeof(void(*)()) ); \ + p += sizeof(void(*)()); \ + check_array( t1, temp1 ); \ + memcpy( p, &temp1, sizeof(t1) ); \ + p += sizeof(t1); \ + check_array( t2, temp2 ); \ + memcpy( p, &temp2, sizeof(t2) ); \ + spawn( buffer ); \ + } \ + +#define spawn3( task, t1, p1, t2, p2, t3, p3 ) \ + { \ + void *buffer = malloc( sizeof(void(*)()) + sizeof(t1) + sizeof(t2) + sizeof(t3) ); \ + char *p = buffer; \ + void *t0 = task; \ + t1 temp1 = (p1); \ + t2 temp2 = (p2); \ + t3 temp3 = (p3); \ + memcpy( p, &t0, sizeof(void(*)()) ); \ + p += sizeof(void(*)()); \ + check_array( t1, temp1 ); \ + memcpy( p, &temp1, sizeof(t1) ); \ + p += sizeof(t1); \ + check_array( t2, temp2 ); \ + memcpy( p, &temp2, sizeof(t2) ); \ + p += sizeof(t2); \ + check_array( t3, temp3 ); \ + memcpy( p, &temp3, sizeof(t3) ); \ + spawn( buffer ); \ + } \ + +#define spawn4( task, t1, p1, t2, p2, t3, p3, t4, p4 ) \ + { \ + void *buffer = malloc( sizeof(void(*)()) + sizeof(t1) + sizeof(t2) + sizeof(t3) + sizeof(t4) ); \ + char *p = buffer; \ + void *t0 = task; \ + t1 temp1 = (p1); \ + t2 temp2 = (p2); \ + t3 temp3 = (p3); \ + t4 temp4 = (p4); \ + memcpy( p, &t0, sizeof(void(*)()) ); \ + p += sizeof(void(*)()); \ + check_array( t1, temp1 ); \ + memcpy( p, &temp1, sizeof(t1) ); \ + p += sizeof(t1); \ + check_array( t2, temp2 ); \ + memcpy( p, &temp2, sizeof(t2) ); \ + p += sizeof(t2); \ + check_array( t3, temp3 ); \ + memcpy( p, &temp3, sizeof(t3) ); \ + p += sizeof(t3); \ + check_array( t4, temp4 ); \ + memcpy( p, &temp4, sizeof(t4) ); \ + spawn( buffer ); \ + } \ + +#define spawn5( task, t1, p1, t2, p2, t3, p3, t4, p4, t5, p5 ) \ + { \ + void *buffer = malloc( sizeof(void(*)()) + sizeof(t1) + sizeof(t2) + sizeof(t3) + sizeof(t4) + sizeof(t5) ); \ + char *p = buffer; \ + void *t0 = task; \ + t1 temp1 = (p1); \ + t2 temp2 = (p2); \ + t3 temp3 = (p3); \ + t4 temp4 = (p4); \ + t5 temp5 = (p5); \ + memcpy( p, &t0, sizeof(void(*)()) ); \ + p += sizeof(void(*)()); \ + check_array( t1, temp1 ); \ + memcpy( p, &temp1, sizeof(t1) ); \ + p += sizeof(t1); \ + check_array( t2, temp2 ); \ + memcpy( p, &temp2, sizeof(t2) ); \ + p += sizeof(t2); \ + check_array( t3, temp3 ); \ + memcpy( p, &temp3, sizeof(t3) ); \ + p += sizeof(t3); \ + check_array( t4, temp4 ); \ + memcpy( p, &temp4, sizeof(t4) ); \ + p += sizeof(t4); \ + check_array( t5, temp5 ); \ + memcpy( p, &temp5, sizeof(t5) ); \ + spawn( buffer ); \ + } \ + +#define spawn6( task, t1, p1, t2, p2, t3, p3, t4, p4, t5, p5, t6, p6 ) \ + { \ + void *buffer = malloc( sizeof(void(*)()) + sizeof(t1) + sizeof(t2) + sizeof(t3) + sizeof(t4) + sizeof(t5) + sizeof(t6) ); \ + char *p = buffer; \ + void *t0 = task; \ + t1 temp1 = (p1); \ + t2 temp2 = (p2); \ + t3 temp3 = (p3); \ + t4 temp4 = (p4); \ + t5 temp5 = (p5); \ + t6 temp6 = (p6); \ + memcpy( p, &t0, sizeof(void(*)()) ); \ + p += sizeof(void(*)()); \ + check_array( t1, temp1 ); \ + memcpy( p, &temp1, sizeof(t1) ); \ + p += sizeof(t1); \ + check_array( t2, temp2 ); \ + memcpy( p, &temp2, sizeof(t2) ); \ + p += sizeof(t2); \ + check_array( t3, temp3 ); \ + memcpy( p, &temp3, sizeof(t3) ); \ + p += sizeof(t3); \ + check_array( t4, temp4 ); \ + memcpy( p, &temp4, sizeof(t4) ); \ + p += sizeof(t4); \ + check_array( t5, temp5 ); \ + memcpy( p, &temp5, sizeof(t5) ); \ + p += sizeof(t5); \ + check_array( t6, temp6 ); \ + memcpy( p, &temp6, sizeof(t6) ); \ + spawn( buffer ); \ + } \ + +#define spawn7( task, t1, p1, t2, p2, t3, p3, t4, p4, t5, p5, t6, p6 , t7, p7 ) \ + { \ + void *buffer = malloc( sizeof(void(*)()) + sizeof(t1) + sizeof(t2) + sizeof(t3) + sizeof(t4) + sizeof(t5) + sizeof(t6) + sizeof(t7) ); \ + char *p = buffer; \ + void *t0 = task; \ + t1 temp1 = (p1); \ + t2 temp2 = (p2); \ + t3 temp3 = (p3); \ + t4 temp4 = (p4); \ + t5 temp5 = (p5); \ + t6 temp6 = (p6); \ + t7 temp7 = (p7); \ + memcpy( p, &t0, sizeof(void(*)()) ); \ + p += sizeof(void(*)()); \ + check_array( t1, temp1 ); \ + memcpy( p, &temp1, sizeof(t1) ); \ + p += sizeof(t1); \ + check_array( t2, temp2 ); \ + memcpy( p, &temp2, sizeof(t2) ); \ + p += sizeof(t2); \ + check_array( t3, temp3 ); \ + memcpy( p, &temp3, sizeof(t3) ); \ + p += sizeof(t3); \ + check_array( t4, temp4 ); \ + memcpy( p, &temp4, sizeof(t4) ); \ + p += sizeof(t4); \ + check_array( t5, temp5 ); \ + memcpy( p, &temp5, sizeof(t5) ); \ + p += sizeof(t5); \ + check_array( t6, temp6 ); \ + memcpy( p, &temp6, sizeof(t6) ); \ + p += sizeof(t6); \ + check_array( t7, temp7 ); \ + memcpy( p, &temp7, sizeof(t7) ); \ + spawn( buffer ); \ + } \ + +/* Wrappers for task cores with different number of arguments: */ + +#define run0( task_core ) \ + { \ + (task_core)(); \ + } \ + +#define run1( task_core, t1 ) \ + { \ + t1 p1; \ + char *p = params; \ + memcpy( &p1, p, sizeof(t1) ); \ + (task_core)(p1); \ + } \ + +#define run2( task_core, t1, t2 ) \ + { \ + t1 p1; \ + t2 p2; \ + char *p = params; \ + memcpy( &p1, p, sizeof(t1) ); \ + p += sizeof(t1); \ + memcpy( &p2, p, sizeof(t2) ); \ + (task_core)(p1,p2); \ + } \ + +#define run3( task_core, t1, t2, t3 ) \ + { \ + t1 p1; \ + t2 p2; \ + t3 p3; \ + char *p = params; \ + memcpy( &p1, p, sizeof(t1) ); \ + p += sizeof(t1); \ + memcpy( &p2, p, sizeof(t2) ); \ + p += sizeof(t2); \ + memcpy( &p3, p, sizeof(t3) ); \ + (task_core)(p1,p2,p3); \ + } \ + +#define run4( task_core, t1, t2, t3, t4 ) \ + { \ + t1 p1; \ + t2 p2; \ + t3 p3; \ + t4 p4; \ + char *p = params; \ + memcpy( &p1, p, sizeof(t1) ); \ + p += sizeof(t1); \ + memcpy( &p2, p, sizeof(t2) ); \ + p += sizeof(t2); \ + memcpy( &p3, p, sizeof(t3) ); \ + p += sizeof(t3); \ + memcpy( &p4, p, sizeof(t4) ); \ + (task_core)(p1,p2,p3,p4); \ + } \ + +#define run5( task_core, t1, t2, t3, t4, t5 ) \ + { \ + t1 p1; \ + t2 p2; \ + t3 p3; \ + t4 p4; \ + t5 p5; \ + char *p = params; \ + memcpy( &p1, p, sizeof(t1) ); \ + p += sizeof(t1); \ + memcpy( &p2, p, sizeof(t2) ); \ + p += sizeof(t2); \ + memcpy( &p3, p, sizeof(t3) ); \ + p += sizeof(t3); \ + memcpy( &p4, p, sizeof(t4) ); \ + p += sizeof(t4); \ + memcpy( &p5, p, sizeof(t5) ); \ + (task_core)(p1,p2,p3,p4,p5); \ + } \ + +#define run6( task_core, t1, t2, t3, t4, t5, t6 ) \ + { \ + t1 p1; \ + t2 p2; \ + t3 p3; \ + t4 p4; \ + t5 p5; \ + t6 p6; \ + char *p = params; \ + memcpy( &p1, p, sizeof(t1) ); \ + p += sizeof(t1); \ + memcpy( &p2, p, sizeof(t2) ); \ + p += sizeof(t2); \ + memcpy( &p3, p, sizeof(t3) ); \ + p += sizeof(t3); \ + memcpy( &p4, p, sizeof(t4) ); \ + p += sizeof(t4); \ + memcpy( &p5, p, sizeof(t5) ); \ + p += sizeof(t5); \ + memcpy( &p6, p, sizeof(t6) ); \ + (task_core)(p1,p2,p3,p4,p5,p6); \ + } \ + +#define run7( task_core, t1, t2, t3, t4, t5, t6, t7 ) \ + { \ + t1 p1; \ + t2 p2; \ + t3 p3; \ + t4 p4; \ + t5 p5; \ + t6 p6; \ + t7 p7; \ + char *p = params; \ + memcpy( &p1, p, sizeof(t1) ); \ + p += sizeof(t1); \ + memcpy( &p2, p, sizeof(t2) ); \ + p += sizeof(t2); \ + memcpy( &p3, p, sizeof(t3) ); \ + p += sizeof(t3); \ + memcpy( &p4, p, sizeof(t4) ); \ + p += sizeof(t4); \ + memcpy( &p5, p, sizeof(t5) ); \ + p += sizeof(t5); \ + memcpy( &p6, p, sizeof(t6) ); \ + p += sizeof(t6); \ + memcpy( &p7, p, sizeof(t7) ); \ + (task_core)(p1,p2,p3,p4,p5,p6,p7); \ + } \ + +#endif /* TASKPOOL_H */ diff --git a/lib/Feldspar/Compiler.hs b/lib/Feldspar/Compiler.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler.hs @@ -0,0 +1,43 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +module Feldspar.Compiler + ( defaultOptions + , c99PlatformOptions + , tic64xPlatformOptions + , unrollOptions + , noPrimitiveInstructionHandling + , noMemoryInformation + , module Internal + ) where + +import Feldspar.Compiler.Compiler +import Feldspar.Compiler.Frontend.Interactive.Interface as Internal +import Feldspar.Compiler.Backend.C.Options as Internal +import Feldspar.Compiler.Imperative.Frontend as Internal hiding (Type, spawn) + diff --git a/lib/Feldspar/Compiler/Backend/C/CodeGeneration.hs b/lib/Feldspar/Compiler/Backend/C/CodeGeneration.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Backend/C/CodeGeneration.hs @@ -0,0 +1,144 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE FlexibleInstances #-} + +module Feldspar.Compiler.Backend.C.CodeGeneration where + +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Error +import Feldspar.Compiler.Backend.C.Options +import Feldspar.Compiler.Backend.C.Library + +import qualified Data.List as List (find) + +-- ======================= +-- == C code generation == +-- ======================= + +codeGenerationError :: ErrorClass -> String -> a +codeGenerationError = handleError "CodeGeneration" + +defaultMemberName :: String +defaultMemberName = "member" + +class ToC a where + toC :: Options -> Place -> a -> String + +getStructTypeName :: Options -> Place -> Type -> String +getStructTypeName options place (StructType ts) = + '_' : concatMap (\(_,t) -> (++"_") $ getStructTypeName options place t) ts +getStructTypeName options place (ArrayType len innerType) = + "arr_T" ++ getStructTypeName options place innerType ++ "_S" ++ len2str len + where + len2str :: Length -> String + len2str UndefinedLen = "UD" + len2str (LiteralLen i) = show i +getStructTypeName options place t = replace (toC options place t) " " "" -- float complex -> floatcomplex + +instance ToC Type where + toC _ MainParameter_pl VoidType = "void" + toC _ _ VoidType = "int" + toC options place t@(StructType _) = "struct s" ++ getStructTypeName options place t + toC _ _ (UserType u) = u + toC _ _ (ArrayType _ _) = arrayTypeName + toC _ _ (IVarType _) = ivarTypeName + toC options place t = case List.find (\(t',_,_) -> t == t') $ types $ platform options of + Just (_,s,_) -> s + Nothing -> codeGenerationError InternalError $ + "Unhandled type in platform " ++ name (platform options) ++ ": " ++ show t ++ " place: " ++ show place + +instance ToC (Variable ()) where + toC options place (Variable vname typ role _) = showVariable options place role typ vname + +showVariable :: Options -> Place -> VariableRole -> Type -> String -> String +showVariable options place role typ vname = listprint id " " [variableType, showName role place typ vname] where + variableType = showType options role place typ restr + restr + | place == MainParameter_pl = isRestrict $ platform options + | otherwise = NoRestrict + +showType :: Options -> VariableRole -> Place -> Type -> IsRestrict -> String +showType options role MainParameter_pl t _ + | passByReference t || role == Pointer = tname ++ " *" + | otherwise = tname + where + tname = toC options MainParameter_pl t +showType options _ Declaration_pl t _ = toC options Declaration_pl t +showType _ _ _ _ _ = "" + +arrayTypeName :: String +arrayTypeName = "struct array" + +ivarTypeName :: String +ivarTypeName = "struct ivar" + +showName :: VariableRole -> Place -> Type -> String -> String +showName Value place t n + | place == AddressNeed_pl = '&' : n + | place == FunctionCallIn_pl && passByReference t = '&' : n + | otherwise = n +showName Pointer _ ArrayType{} n = n +showName Pointer place _ n + | place == AddressNeed_pl = n + | place == Declaration_pl = codeGenerationError InternalError "Output variable of the function declared!" + | place == MainParameter_pl = n + | otherwise = "(* " ++ n ++ ")" + +passByReference :: Type -> Bool +passByReference ArrayType{} = True +passByReference StructType{} = True +passByReference _ = False + +---------------------- +-- Helper functions -- +---------------------- + +ind :: (a-> String) -> a -> String +ind f x = unlines $ map (\a -> " " ++ a) $ lines $ f x + +listprint :: (a->String) -> String -> [a] -> String +listprint f s = listprint' . filter (/= "") . map f + where + listprint' [] = "" + listprint' [x] = x + listprint' (x:xs) = x ++ s ++ listprint' xs + +decrArrayDepth :: Type -> Type +decrArrayDepth (ArrayType _ t) = t +decrArrayDepth t = codeGenerationError InternalError $ "Non-array variable of type " ++ show t ++ " is indexed!" + +getStructFieldType :: String -> Type -> Type +getStructFieldType f (StructType l) = case List.find (\(a,_) -> a == f) l of + Just (_,t) -> t + Nothing -> structFieldNotFound f +getStructFieldType f t = codeGenerationError InternalError $ + "Trying to get a struct field from not a struct typed expression\n" ++ "Field: " ++ f ++ "\nType: " ++ show t + +structFieldNotFound :: String -> a +structFieldNotFound f = codeGenerationError InternalError $ "Not found struct field with this name: " ++ f diff --git a/lib/Feldspar/Compiler/Backend/C/Library.hs b/lib/Feldspar/Compiler/Backend/C/Library.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Backend/C/Library.hs @@ -0,0 +1,85 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +module Feldspar.Compiler.Backend.C.Library + (module System.Console.ANSI, + module Feldspar.Compiler.Backend.C.Library) where + +import Control.Monad.State +import System.Console.ANSI +import System.FilePath +import qualified Feldspar.Compiler.Imperative.Representation as AIR + +data CompilationMode = Interactive | Standalone + deriving (Show, Eq) + +type AllocationInfo = ([AIR.Type],[AIR.Type],[AIR.Type]) + +-- =========================================================================== +-- == String tools +-- =========================================================================== + +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace [] _ _ = [] +replace s find repl | take (length find) s == find = repl ++ replace (drop (length find) s) find repl + | otherwise = head s : replace (tail s) find repl + +fixFunctionName :: String -> String +fixFunctionName functionName = replace (replace functionName "_" "__") "'" "_prime" + +makeDebugHFileName :: String -> String +makeDebugHFileName = (<.> "h.dbg.txt") + +makeDebugCFileName :: String -> String +makeDebugCFileName = (<.> "c.dbg.txt") + +makeHFileName :: String -> String +makeHFileName = (<.> "h") + +makeCFileName :: String -> String +makeCFileName = (<.> "c") + +-- =========================================================================== +-- == Name generator +-- =========================================================================== + +newName :: (Monad m) => String -> StateT Integer m String +newName name = do + n <- get + put $ n+1 + return $ name ++ show n + +-- =========================================================================== +-- == Console tools +-- =========================================================================== + +withColor :: Color -> IO () -> IO () +withColor color action = do + setSGR [SetColor Foreground Vivid color, SetColor Background Dull Black] -- , SetConsoleIntensity BoldIntensity] + action + setSGR [Reset] diff --git a/lib/Feldspar/Compiler/Backend/C/Options.hs b/lib/Feldspar/Compiler/Backend/C/Options.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Backend/C/Options.hs @@ -0,0 +1,101 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Backend.C.Options where + +import Data.Typeable +import Text.Show.Functions + +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Imperative.Frontend hiding (UserType, Type, Var) + +data Options = + Options + { platform :: Platform + , unroll :: UnrollStrategy + , debug :: DebugOption + , memoryInfoVisible :: Bool + , rules :: [Rule] + } deriving (Eq, Show) + +data UnrollStrategy = NoUnroll | Unroll Int + deriving (Eq, Show) + +data DebugOption = NoDebug | NoPrimitiveInstructionHandling + deriving (Eq, Show) + +data Platform = Platform { + name :: String, + types :: [(Type, String, String)], + values :: [(Type, ShowValue)], + includes :: [String], + platformRules :: [Rule], + isRestrict :: IsRestrict +} deriving (Eq, Show) + +type ShowValue = Constant () -> String + +instance Eq ShowValue where + (==) _ _ = True + +data IsRestrict = Restrict | NoRestrict + deriving (Show,Eq) + +-- * Actions and rules + +data Action t + = Replace t + | Propagate Rule + | WithId (Int -> [Action t]) + | WithOptions (Options -> [Action t]) + deriving Typeable + +data Rule where + Rule :: (Typeable t) => (t -> [Action t]) -> Rule + +instance Show Rule where + show _ = "Transformation rule." + +instance Eq Rule where + _ == _ = False + +rule :: (Interface t, Typeable (Repr t)) => (t -> [Action (Repr t)]) -> Rule +rule f = Rule $ \x -> f $ toInterface x + +replaceWith :: (Interface t) => t -> Action (Repr t) +replaceWith = Replace . fromInterface + +propagate :: (Interface t, Typeable (Repr t)) => (t -> [Action (Repr t)]) -> Action t' +propagate = Propagate . rule diff --git a/lib/Feldspar/Compiler/Backend/C/Platforms.hs b/lib/Feldspar/Compiler/Backend/C/Platforms.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Backend/C/Platforms.hs @@ -0,0 +1,280 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE ViewPatterns #-} + +module Feldspar.Compiler.Backend.C.Platforms + ( availablePlatforms + , c99 + , tic64x + , c99Rules + , tic64xRules + , traceRules + ) where + + +import Feldspar.Compiler.Backend.C.Options +import Feldspar.Compiler.Imperative.Representation hiding (Type, Cast, In, Out, Block) +import Feldspar.Compiler.Imperative.Frontend + +availablePlatforms :: [Platform] +availablePlatforms = [ c99, tic64x ] + +c99 :: Platform +c99 = Platform { + name = "c99", + types = + [ (NumType Signed S8, "int8_t", "int8") + , (NumType Signed S16, "int16_t", "int16") + , (NumType Signed S32, "int32_t", "int32") + , (NumType Signed S64, "int64_t", "int64") + , (NumType Unsigned S8, "uint8_t", "uint8") + , (NumType Unsigned S16, "uint16_t", "uint16") + , (NumType Unsigned S32, "uint32_t", "uint32") + , (NumType Unsigned S64, "uint64_t", "uint64") + , (BoolType, "uint32_t", "uint32_t") -- TODO sizeof(bool) is implementation dependent + , (FloatType, "float", "float") + , (ComplexType FloatType, "float complex", "complexOf_float") + ] , + values = + [ (ComplexType FloatType, \cx -> "(" ++ showRe cx ++ "+" ++ showIm cx ++ "i)") + , (BoolType, \b -> if boolValue b then "true" else "false") + ] , + includes = + [ "\"feldspar_c99.h\"" + , "\"feldspar_array.h\"" + , "\"feldspar_future.h\"" + , "\"ivar.h\"" + , "\"taskpool.h\"" + , "" + , "" + , "" + , "" + , ""], + platformRules = c99Rules ++ traceRules, + isRestrict = NoRestrict +} + +tic64x :: Platform +tic64x = Platform { + name = "tic64x", + types = + [ (NumType Signed S8, "char", "char") + , (NumType Signed S16, "short", "short") + , (NumType Signed S32, "int", "int") + , (NumType Signed S40, "long", "long") + , (NumType Signed S64, "long long","llong") + , (NumType Unsigned S8, "unsigned char", "uchar") + , (NumType Unsigned S16, "unsigned short", "ushort") + , (NumType Unsigned S32, "unsigned", "uint") + , (NumType Unsigned S40, "unsigned long", "ulong") + , (NumType Unsigned S64, "unsigned long long", "ullong") + , (BoolType, "int", "bool") + , (FloatType, "float", "float") + , (ComplexType FloatType, "complexOf_float", "complexOf_float") + ] , + values = + [ (ComplexType FloatType, \cx -> "complex_fun_float(" ++ showRe cx ++ "," ++ showIm cx ++ ")") + , (BoolType, \b -> if boolValue b then "1" else "0") + ] , + includes = ["\"feldspar_tic64x.h\"", "\"feldspar_array.h\"", "", "", ""], + platformRules = tic64xRules ++ c99Rules ++ traceRules, + isRestrict = Restrict +} + +showRe, showIm :: Constant t -> String +showRe = showConstant . realPartComplexValue +showIm = showConstant . imagPartComplexValue + +showConstant :: Constant t -> String +showConstant (IntConst c _ _ _) = show c +showConstant (FloatConst c _ _) = show c ++ "f" + +c99Rules :: [Rule] +c99Rules = [rule copy, rule c99] + where + copy (Call "copy" [Out arg1, In arg2]) + | isArray (typeof arg1) = [replaceWith $ Call "copyArray" [Out arg1,In arg2]] + | otherwise = [replaceWith $ arg1 := arg2] + copy _ = [] + c99 (Fun _ "(!)" [arg1,arg2]) = [replaceWith $ arg1 :!: arg2] + c99 (Fun _ "getFst" [arg]) = [replaceWith $ arg :.: first] + c99 (Fun _ "getSnd" [arg]) = [replaceWith $ arg :.: second] + c99 (Fun t "(==)" [arg1, arg2]) = [replaceWith $ Binop t "==" [arg1, arg2]] + c99 (Fun t "(/=)" [arg1, arg2]) = [replaceWith $ Binop t "!=" [arg1, arg2]] + c99 (Fun t "(<)" [arg1, arg2]) = [replaceWith $ Binop t "<" [arg1, arg2]] + c99 (Fun t "(>)" [arg1, arg2]) = [replaceWith $ Binop t ">" [arg1, arg2]] + c99 (Fun t "(<=)" [arg1, arg2]) = [replaceWith $ Binop t "<=" [arg1, arg2]] + c99 (Fun t "(>=)" [arg1, arg2]) = [replaceWith $ Binop t ">=" [arg1, arg2]] + c99 (Fun t "not" [arg]) = [replaceWith $ Fun t "!" [arg]] + c99 (Fun t "(&&)" [arg1, arg2]) = [replaceWith $ Binop t "&&" [arg1, arg2]] + c99 (Fun t "(||)" [arg1, arg2]) = [replaceWith $ Binop t "||" [arg1, arg2]] + c99 (Fun t "quot" [arg1, arg2]) = [replaceWith $ Binop t "/" [arg1, arg2]] + c99 (Fun t "rem" [arg1, arg2]) = [replaceWith $ Binop t "%" [arg1, arg2]] + c99 (Fun t "(^)" [arg1, arg2]) = [replaceWith $ Fun t (extend "pow" t) [arg1, arg2]] + c99 (Fun t "abs" [arg]) = [replaceWith $ Fun t (extend "abs" t) [arg]] + c99 (Fun t "signum" [arg]) = [replaceWith $ Fun t (extend "signum" t) [arg]] + c99 (Fun t "(+)" [arg1, arg2]) = [replaceWith $ Binop t "+" [arg1, arg2]] + c99 (Fun t "(-)" [LitI _ 0, arg2]) = [replaceWith $ Fun t "-" [arg2]] + c99 (Fun t "(-)" [LitF 0, arg2]) = [replaceWith $ Fun t "-" [arg2]] + c99 (Fun t "(-)" [arg1, arg2]) = [replaceWith $ Binop t "-" [arg1, arg2]] + c99 (Fun t "(*)" [LitI _ (log2 -> Just n), arg2]) = [replaceWith $ Binop t "<<" [arg2, LitI I32 n]] + c99 (Fun t "(*)" [arg1, LitI _ (log2 -> Just n)]) = [replaceWith $ Binop t "<<" [arg1, LitI I32 n]] + c99 (Fun t "(*)" [arg1, arg2]) = [replaceWith $ Binop t "*" [arg1, arg2]] + c99 (Fun t "(/)" [arg1, arg2]) = [replaceWith $ Binop t "/" [arg1, arg2]] + c99 (Fun t@(Complex _) "exp" [arg]) = [replaceWith $ Fun t "cexpf" [arg]] + c99 (Fun t "exp" [arg]) = [replaceWith $ Fun t "expf" [arg]] + c99 (Fun t@(Complex _) "sqrt" [arg]) = [replaceWith $ Fun t "csqrtf" [arg]] + c99 (Fun t "sqrt" [arg]) = [replaceWith $ Fun t "sqrtf" [arg]] + c99 (Fun t@(Complex _) "log" [arg]) = [replaceWith $ Fun t "clogf" [arg]] + c99 (Fun t "log" [arg]) = [replaceWith $ Fun t "logf" [arg]] + c99 (Fun t@(Complex _) "(**)" [arg1, arg2]) = [replaceWith $ Fun t "cpowf" [arg1,arg2]] + c99 (Fun t "(**)" [arg1, arg2]) = [replaceWith $ Fun t "powf" [arg1,arg2]] + c99 (Fun t "logBase" [arg1, arg2]) = [replaceWith $ Fun t (extend "logBase" t) [arg1,arg2]] + c99 (Fun t@(Complex _) "sin" [arg]) = [replaceWith $ Fun t "csinf" [arg]] + c99 (Fun t "sin" [arg]) = [replaceWith $ Fun t "sinf" [arg]] + c99 (Fun t@(Complex _) "tan" [arg]) = [replaceWith $ Fun t "ctanf" [arg]] + c99 (Fun t "tan" [arg]) = [replaceWith $ Fun t "tanf" [arg]] + c99 (Fun t@(Complex _) "cos" [arg]) = [replaceWith $ Fun t "ccosf" [arg]] + c99 (Fun t "cos" [arg]) = [replaceWith $ Fun t "cosf" [arg]] + c99 (Fun t@(Complex _) "asin" [arg]) = [replaceWith $ Fun t "casinf" [arg]] + c99 (Fun t "asin" [arg]) = [replaceWith $ Fun t "asinf" [arg]] + c99 (Fun t@(Complex _) "atan" [arg]) = [replaceWith $ Fun t "catanf" [arg]] + c99 (Fun t "atan" [arg]) = [replaceWith $ Fun t "atanf" [arg]] + c99 (Fun t@(Complex _) "acos" [arg]) = [replaceWith $ Fun t "cacosf" [arg]] + c99 (Fun t "acos" [arg]) = [replaceWith $ Fun t "acosf" [arg]] + c99 (Fun t@(Complex _) "sinh" [arg]) = [replaceWith $ Fun t "csinhf" [arg]] + c99 (Fun t "sinh" [arg]) = [replaceWith $ Fun t "sinhf" [arg]] + c99 (Fun t@(Complex _) "tanh" [arg]) = [replaceWith $ Fun t "ctanhf" [arg]] + c99 (Fun t "tanh" [arg]) = [replaceWith $ Fun t "tanhf" [arg]] + c99 (Fun t@(Complex _) "cosh" [arg]) = [replaceWith $ Fun t "ccoshf" [arg]] + c99 (Fun t "cosh" [arg]) = [replaceWith $ Fun t "coshf" [arg]] + c99 (Fun t@(Complex _) "asinh" [arg]) = [replaceWith $ Fun t "casinhf" [arg]] + c99 (Fun t "asinh" [arg]) = [replaceWith $ Fun t "asinhf" [arg]] + c99 (Fun t@(Complex _) "atanh" [arg]) = [replaceWith $ Fun t "catanhf" [arg]] + c99 (Fun t "atanh" [arg]) = [replaceWith $ Fun t "atanhf" [arg]] + c99 (Fun t@(Complex _) "acosh" [arg]) = [replaceWith $ Fun t "cacoshf" [arg]] + c99 (Fun t "acosh" [arg]) = [replaceWith $ Fun t "acoshf" [arg]] + c99 (Fun t "(.&.)" [arg1, arg2]) = [replaceWith $ Binop t "&" [arg1, arg2]] + c99 (Fun t "(.|.)" [arg1, arg2]) = [replaceWith $ Binop t "|" [arg1, arg2]] + c99 (Fun t "xor" [arg1, arg2]) = [replaceWith $ Binop t "^" [arg1, arg2]] + c99 (Fun t "complement" [arg]) = [replaceWith $ Fun t "~" [arg]] + c99 (Fun t "bit" [arg]) = [replaceWith $ Binop t "<<" [LitI t 1, arg]] + c99 (Fun t "setBit" [arg1, arg2]) = [replaceWith $ Fun t (extend "setBit" t) [arg1, arg2]] + c99 (Fun t "clearBit" [arg1, arg2]) = [replaceWith $ Fun t (extend "clearBit" t) [arg1, arg2]] + c99 (Fun t "complementBit" [arg1, arg2]) = [replaceWith $ Fun t (extend "complementBit" t) [arg1, arg2]] + c99 (Fun t "testBit" [arg1, arg2]) = [replaceWith $ Fun t (extend "testBit" $ typeof arg1) [arg1, arg2]] + c99 (Fun t "shiftL" [arg1, arg2]) = [replaceWith $ Binop t "<<" [arg1, arg2]] + c99 (Fun t "shiftR" [arg1, arg2]) = [replaceWith $ Binop t ">>" [arg1, arg2]] + c99 (Fun t "rotateL" [arg1, arg2]) = [replaceWith $ Fun t (extend "rotateL" t) [arg1, arg2]] + c99 (Fun t "rotateR" [arg1, arg2]) = [replaceWith $ Fun t (extend "rotateR" t) [arg1, arg2]] + c99 (Fun t "reverseBits" [arg]) = [replaceWith $ Fun t (extend "reverseBits" t) [arg]] + c99 (Fun t "bitScan" [arg]) = [replaceWith $ Fun t (extend "bitScan" $ typeof arg) [arg]] + c99 (Fun t "bitCount" [arg]) = [replaceWith $ Fun t (extend "bitCount" $ typeof arg) [arg]] + c99 (Fun _ "bitSize" [intWidth . typeof -> Just n]) = [replaceWith $ LitI U32 n] + c99 (Fun _ "isSigned" [intSigned . typeof -> Just b]) = [replaceWith $ litB b] + c99 (Fun t "complex" [arg1, arg2]) = [replaceWith $ Fun t (extend "complex" $ typeof arg1) [arg1,arg2]] + c99 (Fun t "creal" [arg]) = [replaceWith $ Fun t "crealf" [arg]] + c99 (Fun t "cimag" [arg]) = [replaceWith $ Fun t "cimagf" [arg]] + c99 (Fun t "conjugate" [arg]) = [replaceWith $ Fun t "conjf" [arg]] + c99 (Fun t "magnitude" [arg]) = [replaceWith $ Fun t "cabsf" [arg]] + c99 (Fun t "phase" [arg]) = [replaceWith $ Fun t "cargf" [arg]] + c99 (Fun t "mkPolar" [arg1, arg2]) = [replaceWith $ Fun t (extend "mkPolar" $ typeof arg1) [arg1, arg2]] + c99 (Fun t "cis" [arg]) = [replaceWith $ Fun t (extend "cis" $ typeof arg) [arg]] + c99 (Fun t "f2i" [arg]) = [replaceWith $ Cast t $ Fun Floating "truncf" [arg]] + c99 (Fun (Complex t) "i2n" [arg]) = [replaceWith $ Fun (Complex t) (extend "complex" t) [Cast t arg, LitF 0]] + c99 (Fun t "i2n" [arg]) = [replaceWith $ Cast t arg] + c99 (Fun t "b2i" [arg]) = [replaceWith $ Cast t arg] + c99 (Fun t "round" [arg]) = [replaceWith $ Cast t $ Fun Floating "roundf" [arg]] + c99 (Fun t "ceiling" [arg]) = [replaceWith $ Cast t $ Fun Floating "ceilf" [arg]] + c99 (Fun t "floor" [arg]) = [replaceWith $ Cast t $ Fun Floating "floorf" [arg]] + c99 _ = [] + +tic64xRules :: [Rule] +tic64xRules = [rule tic64x] + where + tic64x (Fun t "(==)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "equal" $ typeof arg1) [arg1, arg2]] + tic64x (Fun t "(/=)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t "!" [Fun t (extend "equal" $ typeof arg1) [arg1, arg2]]] + tic64x (Fun t "abs" [arg@(typeof -> Floating)]) = [replaceWith $ Fun t "_fabs" [arg]] + tic64x (Fun t "abs" [arg@(typeof -> I32)]) = [replaceWith $ Fun t "_abs" [arg]] + tic64x (Fun t "(+)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "add" $ typeof arg1) [arg1, arg2]] + tic64x (Fun t "(-)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "sub" $ typeof arg1) [arg1, arg2]] + tic64x (Fun t "(*)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "mult" $ typeof arg1) [arg1, arg2]] + tic64x (Fun t "(/)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "div" $ typeof arg1) [arg1, arg2]] + tic64x (Fun t "exp" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "exp" $ typeof arg1) [arg1, arg2]] + tic64x (Fun t "sqrt" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "sqrt" $ typeof arg1) [arg1, arg2]] + tic64x (Fun t "log" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "log" $ typeof arg1) [arg1, arg2]] + tic64x (Fun t "(**)" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "cpow" $ typeof arg1) [arg1, arg2]] + tic64x (Fun t "logBase" [arg1@(typeof -> Complex _), arg2]) = [replaceWith $ Fun t (extend "logBase" $ typeof arg1) [arg1, arg2]] + tic64x (Fun t fn [arg@(typeof -> Complex _)]) + | fn `elem` ["sin","tan","cos","asin","atan","acos","sinh","tanh","cosh","asinh","atanh","acosh","creal","cimag","conjugate","magnitude","phase"] + = [replaceWith $ Fun t (extend fn $ typeof arg) [arg]] + tic64x (Fun t "rotateL" [arg1@(typeof -> U32), arg2]) = [replaceWith $ Fun t "_rotl" [arg1, arg2]] + tic64x (Fun t "reverseBits" [arg@(typeof -> U32)]) = [replaceWith $ Fun t "_bitr" [arg]] + tic64x (Fun t "bitCount" [arg@(typeof -> U32)]) = [replaceWith $ Fun t "_dotpu4" [Fun t "_bitc4" [arg], LitI U32 0x01010101]] + tic64x (Fun t _ [arg@(typeof -> Complex _)]) = [replaceWith $ Fun t (extend "creal" $ typeof arg) [arg]] + tic64x _ = [] + +traceRules :: [Rule] +traceRules = [rule trace] + where + trace (Fun t "trace" [lab, val]) = [WithId acts] + where + acts i = [replaceWith trcVar, propagate decl, propagate trc, propagate frame] + where + trcVar = Var t trcVarName + trcVarName = "trc" ++ show i + defTrcVar = Def t trcVarName + decl (Bl defs prg) = [replaceWith $ Bl (defs ++ [defTrcVar]) prg] + trc :: Prog -> [Action (Repr Prog)] + trc instr = [replaceWith $ Seq [trcVar := val,trcCall,instr]] + trcCall = Call (extend' "trace" t) [In trcVar, In lab] + frame (ProcDf pname ins outs prg) = [replaceWith $ ProcDf pname ins outs prg'] + where + prg' = case prg of + Seq (Call "traceStart" [] : _) -> prg + Block _ (Seq (Call "traceStart" [] : _)) -> prg + _ -> Seq [Call "traceStart" [], prg, Call "traceEnd" []] + trace _ = [] + +extend :: String -> Type -> String +extend s t = s ++ "_fun_" ++ show t + +extend' :: String -> Type -> String +extend' s t = s ++ "_" ++ show t + +log2 :: Integer -> Maybe Integer +log2 n + | n == 2 Prelude.^ l = Just l + | otherwise = Nothing + where + l = toInteger $ length $ takeWhile (<=n) $ map (2 Prelude.^) [1..] + +first, second :: String +first = "member1" +second = "member2" diff --git a/lib/Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs b/lib/Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs @@ -0,0 +1,78 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Backend.C.Plugin.BlockProgramHandler where + +import Feldspar.Transformation + +-- =========================================================================== +-- == Type definition generator plugin +-- =========================================================================== + +data BlockProgramHandler = BlockProgramHandler + +instance Default [Declaration ()] where + def = [] + +instance Combine [Declaration ()] where + combine a b = a ++ b + +instance Transformation BlockProgramHandler where + type From BlockProgramHandler = () + type To BlockProgramHandler = () + type Down BlockProgramHandler = () + type Up BlockProgramHandler = [Declaration ()] + type State BlockProgramHandler = () + +instance Transformable BlockProgramHandler Block where + transform t s d b = tr + { result = (result tr) + { locals = locals (result tr) ++ up tr + } + , up = [] + } + where + tr = defaultTransform t s d b + +instance Transformable BlockProgramHandler Program where + transform t s d p = + case result tr of + BlockProgram b _ -> Result (blockBody b) () (locals b ++ up tr) + _ -> tr + where + tr = defaultTransform t s d p + + +instance Plugin BlockProgramHandler where + type ExternalInfo BlockProgramHandler = () + executePlugin BlockProgramHandler _ procedure = + result $ transform BlockProgramHandler ({-state-}) () procedure diff --git a/lib/Feldspar/Compiler/Backend/C/Plugin/Locator.hs b/lib/Feldspar/Compiler/Backend/C/Plugin/Locator.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Backend/C/Plugin/Locator.hs @@ -0,0 +1,232 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Backend.C.Plugin.Locator where + +import Feldspar.Transformation +import Feldspar.Compiler.Backend.C.CodeGeneration +import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint + + +-- =========================================================================== +-- == GetPrg plugin +-- =========================================================================== + + +instance Default Bool where + def = False + +instance Default (Program DebugToCSemanticInfo) where + def = Empty ((0,0),(0,0)) ((0,0),(0,0)) + +instance Combine Bool where + combine l1 l2 = l1 || l2 + +instance Combine (Program DebugToCSemanticInfo) where + combine Empty{} p2 = p2 + combine p1 _ = p1 + +----------------------------------------------------- +--- GetPrg plugin for ParLoop +----------------------------------------------------- + +data GetPrgParLoop = GetPrgParLoop + +instance Transformation GetPrgParLoop where + type From GetPrgParLoop = DebugToCSemanticInfo + type To GetPrgParLoop = DebugToCSemanticInfo + type Down GetPrgParLoop = (Int, Int) + type Up GetPrgParLoop = (Bool, Program DebugToCSemanticInfo) + type State GetPrgParLoop = () + + +instance Plugin GetPrgParLoop where + type ExternalInfo GetPrgParLoop = (Int, Int) + executePlugin GetPrgParLoop (line, col) procedure = + result $ transform GetPrgParLoop () (line, col) procedure + +getPrgParLoop :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo) +getPrgParLoop (line, col) procedure = up res where + res = transform GetPrgParLoop () (line, col) procedure + +instance Transformable GetPrgParLoop Program where + transform t () (line, col) pl@(ParLoop _ _ _ prog inf1 _) = Result pl () info where + info = case contains (line, col) inf1 of + True -> infoCr where + res = transform t () (line, col) prog + infoCr = if fst $ up res then up res else (True, pl) + _ -> def + transform t () (line, col) pr = defaultTransform t () (line, col) pr + +----------------------------------------------------- +--- GetPrg plugin for Assign +----------------------------------------------------- + +data GetPrgAssign = GetPrgAssign + +instance Transformation GetPrgAssign where + type From GetPrgAssign = DebugToCSemanticInfo + type To GetPrgAssign = DebugToCSemanticInfo + type Down GetPrgAssign = (Int, Int) + type Up GetPrgAssign = (Bool, Program DebugToCSemanticInfo) + type State GetPrgAssign = () + + +instance Plugin GetPrgAssign where + type ExternalInfo GetPrgAssign = (Int, Int) + executePlugin GetPrgAssign (line, col) procedure = + result $ transform GetPrgAssign () (line, col) procedure + +getPrgAssign :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo) +getPrgAssign (line, col) procedure = up res where + res = transform GetPrgAssign () (line, col) procedure + +instance Transformable GetPrgAssign Program where + transform _ () (line, col) assign@(Assign _ _ inf1 _) = Result assign () info where + info = if contains (line, col) inf1 then (True, assign) else def + transform t () (line, col) pr = defaultTransform t () (line, col) pr + + +----------------------------------------------------- +--- GetPrg plugin for Branch +----------------------------------------------------- + +data GetPrgBranch = GetPrgBranch + +instance Transformation GetPrgBranch where + type From GetPrgBranch = DebugToCSemanticInfo + type To GetPrgBranch = DebugToCSemanticInfo + type Down GetPrgBranch = (Int, Int) + type Up GetPrgBranch = (Bool, Program DebugToCSemanticInfo) + type State GetPrgBranch = () + + +instance Plugin GetPrgBranch where + type ExternalInfo GetPrgBranch = (Int, Int) + executePlugin GetPrgBranch (line, col) procedure = + result $ transform GetPrgBranch () (line, col) procedure + +getPrgBranch :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo) +getPrgBranch (line, col) procedure = up res where + res = transform GetPrgBranch () (line, col) procedure + +instance Transformable GetPrgBranch Program where + transform t () (line, col) br@(Branch _ prog1 prog2 inf1 _) = Result br () info where + info = case contains (line, col) inf1 of + True -> infoCr where + res1 = transform t () (line, col) prog1 + res2 = transform t () (line, col) prog2 + res = combine (up res1) (up res2) + infoCr = if fst res then res else (True,br) + _ -> def + + transform t () (line, col) pr = defaultTransform t () (line, col) pr + +----------------------------------------------------- +--- GetPrg plugin for ProcedureCall +----------------------------------------------------- + +data GetPrgProcCall = GetPrgProcCall + +instance Transformation GetPrgProcCall where + type From GetPrgProcCall = DebugToCSemanticInfo + type To GetPrgProcCall = DebugToCSemanticInfo + type Down GetPrgProcCall = (Int, Int) + type Up GetPrgProcCall = (Bool, Program DebugToCSemanticInfo) + type State GetPrgProcCall = () + + +instance Plugin GetPrgProcCall where + type ExternalInfo GetPrgProcCall = (Int, Int) + executePlugin GetPrgProcCall (line, col) procedure = + result $ transform GetPrgProcCall () (line, col) procedure + +getPrgProcCall :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo) +getPrgProcCall (line, col) procedure = up res where + res = transform GetPrgProcCall () (line, col) procedure + +instance Transformable GetPrgProcCall Program where + transform _ () (line, col) pc@(ProcedureCall _ _ inf1 _) = Result pc () info where + info = if contains (line,col) inf1 then (True,pc) else def + transform t () (line, col) pr = defaultTransform t () (line, col) pr + +----------------------------------------------------- +--- GetPrg plugin for SeqLoop +----------------------------------------------------- + +data GetPrgSeqLoop = GetPrgSeqLoop + +instance Transformation GetPrgSeqLoop where + type From GetPrgSeqLoop = DebugToCSemanticInfo + type To GetPrgSeqLoop = DebugToCSemanticInfo + type Down GetPrgSeqLoop = (Int, Int) + type Up GetPrgSeqLoop = (Bool, Program DebugToCSemanticInfo) + type State GetPrgSeqLoop = () + + +instance Plugin GetPrgSeqLoop where + type ExternalInfo GetPrgSeqLoop = (Int, Int) + executePlugin GetPrgSeqLoop (line, col) procedure = + result $ transform GetPrgSeqLoop () (line, col) procedure + +getPrgSeqLoop :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo) +getPrgSeqLoop (line, col) procedure = up res where + res = transform GetPrgSeqLoop () (line, col) procedure + +instance Transformable GetPrgSeqLoop Program where + transform t () (line, col) sl@(SeqLoop _ _ prog inf1 _) = Result sl () info where + info = case contains (line, col) inf1 of + True -> infoCr where + res = transform t () (line, col) prog + infoCr = if fst $ up res then up res else (True, sl) + _ -> def + transform t () (line, col) pr = defaultTransform t () (line, col) pr + + +------------------------------------------------- +------ Helper functions +------------------------------------------------- + +contains :: (Ord a, Ord b) => (a,b) -> ((a,b),(a,b)) -> Bool +contains (line, col) ((bl, bc), (el, ec)) = (line == bl && bc <= col) || (bl < line && line < el) || (line == el && col <= ec) + +myShow :: Program DebugToCSemanticInfo -> String +myShow (Assign l r inf1 _) = "Assign \n" ++ ind show l ++ "\n=\n" ++ ind show r ++ "\n" ++ show inf1 ++ "\n" +myShow (Sequence progs inf1 _) = "Sequence\n" ++ ind (listprint myShow "\n") progs ++ "\n" ++ show inf1 ++ "\n" +myShow (Branch _ tb eb inf1 _) = "Branch\n" ++ ind myShowB tb ++ "\nelse\n" ++ ind myShowB eb ++ "\n" ++ show inf1 ++ "\n" +myShow (ParLoop count bound step block inf1 _) + = "ParLoop\n count: " ++ show count ++ "\n bound: " ++ show bound ++ "\n step: " ++ show step ++ "\n" ++ ind myShowB block ++ "\n" ++ show inf1 ++ "\n" +myShow x = show x + +myShowB :: Block DebugToCSemanticInfo -> String +myShowB (Block ls prg inf) = "Block\n" ++ ind show ls ++"\n" ++ ind myShow prg ++ show inf + diff --git a/lib/Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs b/lib/Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs @@ -0,0 +1,714 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Backend.C.Plugin.PrettyPrint where + +import Feldspar.Transformation +import Feldspar.Compiler.Backend.C.CodeGeneration +import Feldspar.Compiler.Backend.C.Options + +import qualified Data.List as List (find, intercalate) +import qualified Control.Monad.State as StateMonad (get, put, runState) + +-- =========================================================================== +-- == DebugToC plugin +-- =========================================================================== + +data DebugToC = DebugToC + +data DebugToCSemanticInfo + +instance Annotation DebugToCSemanticInfo Module where + type Label DebugToCSemanticInfo Module = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Entity where + type Label DebugToCSemanticInfo Entity = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Struct where + type Label DebugToCSemanticInfo Struct = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo ProcDef where + type Label DebugToCSemanticInfo ProcDef = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo ProcDecl where + type Label DebugToCSemanticInfo ProcDecl = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo StructMember where + type Label DebugToCSemanticInfo StructMember = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Block where + type Label DebugToCSemanticInfo Block = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Program where + type Label DebugToCSemanticInfo Program = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Empty where + type Label DebugToCSemanticInfo Empty = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Assign where + type Label DebugToCSemanticInfo Assign = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo ProcedureCall where + type Label DebugToCSemanticInfo ProcedureCall = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Spawn where + type Label DebugToCSemanticInfo Spawn = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Run where + type Label DebugToCSemanticInfo Run = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Sequence where + type Label DebugToCSemanticInfo Sequence = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Branch where + type Label DebugToCSemanticInfo Branch = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo SeqLoop where + type Label DebugToCSemanticInfo SeqLoop = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo ParLoop where + type Label DebugToCSemanticInfo ParLoop = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo ActualParameter where + type Label DebugToCSemanticInfo ActualParameter = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Declaration where + type Label DebugToCSemanticInfo Declaration = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Expression where + type Label DebugToCSemanticInfo Expression = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo FunctionCall where + type Label DebugToCSemanticInfo FunctionCall = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo SizeOf where + type Label DebugToCSemanticInfo SizeOf = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo ArrayElem where + type Label DebugToCSemanticInfo ArrayElem = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo StructField where + type Label DebugToCSemanticInfo StructField = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Constant where + type Label DebugToCSemanticInfo Constant = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo IntConst where + type Label DebugToCSemanticInfo IntConst = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo FloatConst where + type Label DebugToCSemanticInfo FloatConst = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo BoolConst where + type Label DebugToCSemanticInfo BoolConst = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo ArrayConst where + type Label DebugToCSemanticInfo ArrayConst = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo ComplexConst where + type Label DebugToCSemanticInfo ComplexConst = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Variable where + type Label DebugToCSemanticInfo Variable = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Cast where + type Label DebugToCSemanticInfo Cast = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Comment where + type Label DebugToCSemanticInfo Comment = ((Int, Int), (Int, Int)) + + +instance Transformation DebugToC where + type From DebugToC = () + type To DebugToC = DebugToCSemanticInfo + type Down DebugToC = (Options, Place, Int) -- Platform, Place and Indentation + type Up DebugToC = String + type State DebugToC = (Int, Int) + +instance Plugin DebugToC where + type ExternalInfo DebugToC = ((Options, Place), Int) + executePlugin DebugToC ((options, place), line) procedure = + result $ transform DebugToC (line, 0) (options, place, 0) procedure + +compToC :: ((Options, Place), Int) -> Module () -> (String, (Int, Int)) +compToC ((options, place), line) procedure = (up res, state res) where + res = transform DebugToC (line, 0) (options, place, 0) procedure + +compToCWithInfos :: ((Options, Place), Int) -> Module () -> (Module DebugToCSemanticInfo, (String, (Int, Int))) +compToCWithInfos ((options, place), line) procedure = (result res, (up res, state res)) where + res = transform DebugToC (line, 0) (options, place, 0) procedure + +instance Transformable DebugToC Variable where + transform _ (line, col) (options, place, _) x@(Variable vname typ role _) = Result (Variable vname typ role newInf) (snd newInf) cRep + where + (newInf, (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + code $ toC options place x + (_, nl, nc) <- StateMonad.get + return ((line, col), (nl, nc)) + +instance Transformable1 DebugToC [] Constant where + transform1 t pos down l = transform1' t pos down l ", " 0 + +instance Transformable DebugToC Constant where + transform t pos down cnst@(IntConst c _ _ _) = transformConst t pos down cnst (show c) + + transform t pos down cnst@(FloatConst c _ _) = transformConst t pos down cnst (show c ++ "f") + + transform t pos down cnst@(BoolConst False _ _) = transformConst t pos down cnst "0" + + transform t pos down cnst@(BoolConst True _ _) = transformConst t pos down cnst "1" + + transform t (line, col) (options, place, indent) cnst@(ComplexConst real im _ _) + = case List.find (\(t',_) -> t' == typeof cnst) $ values $ platform options of + Just (_,f) -> + Result (ComplexConst (result newReal) (result newIm) newInf newInf) (snd newInf) cRep + where + ((newReal, newIm, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + nr <- complexTransform t (options, place, indent) real + ni <- complexTransform t (options, place, indent) im + code $ f cnst + (_, nl, nc) <- StateMonad.get + return (nr, ni, ((line,col),(nl,nc))) + Nothing -> + Result (ComplexConst (result newReal) (result newIm) newInf newInf) (snd newInf) cRep + where + ((newReal, newIm, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + code "complex(" + nr <- monadicTransform' t (options, place, indent) real + code "," + ni <- monadicTransform' t (options, place, indent) im + code ")" + (_, nl, nc) <- StateMonad.get + return (nr, ni, ((line,col),(nl,nc))) + +instance Transformable DebugToC ActualParameter where + transform t pos down act@(In (VarExpr (Variable _ StructType{} _ _) _) _) = + transformActParam t pos down act AddressNeed_pl + transform t pos down act@(In (VarExpr (Variable _ ArrayType{} _ _) _) _) = + transformActParam t pos down act AddressNeed_pl + transform t pos down act@In{} = transformActParam t pos down act FunctionCallIn_pl + transform t pos down act@Out{} = transformActParam t pos down act AddressNeed_pl + transform t pos down act@TypeParameter{} = transformActParam t pos down act MainParameter_pl + transform t pos down act@FunParameter{} = transformActParam t pos down act FunctionCallIn_pl + +instance Transformable1 DebugToC [] Expression where + transform1 t pos down l = transform1' t pos down l ", " 0 + +instance Transformable DebugToC Expression where + transform t (line, col) (options, place, indent) (VarExpr val _) = Result (VarExpr (result newVal) newInf) (snd newInf) cRep + where + ((newVal, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + nv <- monadicTransform' t (options, place, indent) val + (_, nl, nc) <- StateMonad.get + return (nv, ((line,col),(nl,nc))) + + transform t (line, col) (options, place, indent) e@(ArrayElem n index _ _) = Result (ArrayElem (result newName) (result newIndex) newInf newInf) (snd newInf) cRep + where + ((newName, newIndex, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + let prefix = case (place, typeof e) of + (AddressNeed_pl, _) -> "&" + (_, ArrayType _ _) -> "&" -- TODO the call site should set the place to AddressNeed_pl for Arrays + _ -> "" + code $ prefix ++ "at(" ++ showType options Value Declaration_pl (typeof e) NoRestrict ++ "," + nn <- monadicTransform' t (options, AddressNeed_pl, indent) n + code "," + ni <- monadicTransform' t (options, ValueNeed_pl, indent) index + code ")" + (_, nl, nc) <- StateMonad.get + return (nn, ni, ((line,col),(nl,nc))) + + transform t pos down expr@(StructField _ field _ _) = transformExpr pos down ('.' : field) ValueNeed_pl + where + transformExpr (line, col) (options, place, indent) str paramType = Result (newExpr expr) (snd newInf) cRep + where + newExpr (StructField _ s _ _ ) = StructField (result newTarget) s newInf newInf + getExpr (StructField e _ _ _ ) = e + prefix = case (place, typeof expr) of + (AddressNeed_pl, _) -> "&" + (_, ArrayType _ _) -> "&" + _ -> "" + ((newTarget, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + code prefix + nt <- monadicTransform' t (options, paramType, indent) (getExpr expr) + code str + (_, nl, nc) <- StateMonad.get + return (nt, ((line,col),(nl,nc))) + + + transform t (line, col) (options, place, indent) (ConstExpr val _) = Result (ConstExpr (result newVal) newInf) (snd newInf) cRep + where + ((newVal, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + nv <- monadicTransform' t (options, place, indent) val + (_, nl, nc) <- StateMonad.get + return (nv, ((line,col),(nl,nc))) + + transform t pos down fc@(FunctionCall f [_,_] _ _) + | funName f == "!" = transformFuncCall t pos down fc "at(" "," ")" + + transform t pos down fc@(FunctionCall f [_,_] _ _) + | funMode f == Infix = transformFuncCall t pos down fc "(" (" " ++ funName f ++ " ") ")" + + transform t (line, col) (options, _, indent) (FunctionCall f paramlist _ _) = + Result (FunctionCall f (result1 newParamlist) newInf newInf) (snd newInf) cRep + where + ((newParamlist, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + code $ funName f ++ "(" + npl <- monadicListTransform' t (options, FunctionCallIn_pl, indent) paramlist + code ")" + (_, nl, nc) <- StateMonad.get + return (npl, ((line,col),(nl,nc))) + + transform t (line, col) (options, place, indent) (Cast typ e _ _) = Result (Cast typ (result newExp) newInf newInf) (snd newInf) cRep + where + ((newExp, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + code $ concat ["((", toC options place typ, ")("] + ne <- monadicTransform' t (options, place, indent) e + code "))" + (_, nl, nc) <- StateMonad.get + return (ne, ((line,col),(nl,nc))) + + transform _ (line, col) (options, place, _) (SizeOf (Left typ) _ _) = Result (SizeOf (Left typ) newInf newInf) (snd newInf) cRep + where + (newInf, (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + code ("sizeof(" ++ toC options place typ ++ ")") + (_, nl, nc) <- StateMonad.get + return ((line, col), (nl, nc)) + + transform t (line, col) (options, place, indent) (SizeOf (Right e) _ _) = Result (SizeOf (Right (result newExp)) newInf newInf) (newLine, newCol) cRep + where + ((newExp, newInf), (cRep, newLine, newCol)) = flip StateMonad.runState (defaultState line col) $ do + code "sizeof" + ne <- monadicTransform' t (options, place, indent) e + code ")" + (_, nl, nc) <- StateMonad.get + return (ne, ((line,col),(nl,nc))) + +instance Transformable1 DebugToC [] Entity where + transform1 t pos down l = transform1' t pos down l "" 0 + +instance Transformable DebugToC Module where + transform t (line, col) (options, place, indent) (Module defList _) = Result (Module (result1 newDefList) newInf) (snd newInf) cRep + where + ((newDefList, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + ndl <- monadicListTransform' t (options, place, indent) defList + (_, nl, nc) <- StateMonad.get + return (ndl, ((line,col),(nl,nc))) + +instance Transformable1 DebugToC [] Variable where + transform1 t pos down l = transform1' t pos down l ", " 0 + +instance Transformable1 DebugToC [] StructMember where + transform1 _ (line, col) _ [] = Result1 [] (line, col) "" + transform1 t (line, col) (options, place, indent) (x:xs) = Result1 (result newX : result1 newXs) (state1 newXs) cRep where + ((newX, newXs), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + indenter indent + nx <- monadicTransform' t (options, place, indent) x + nxs <- monadicListTransform' t (options, place, indent) xs + return (nx, nxs) + + +instance Transformable DebugToC Entity where + transform t (line, col) (options, place, indent) (StructDef n members _ _) = Result (StructDef n (result1 newMembers) newInf newInf) (snd newInf) cRep + where + ((newMembers, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + code $ n ++ " {\n" + (crep, cl, cc) <- StateMonad.get + StateMonad.put (crep, cl, cc + addIndent indent) + nms <- monadicListTransform' t (options, place, addIndent indent) members + indenter indent + code "};\n" + (crep, cl, _) <- StateMonad.get + StateMonad.put (crep, cl, indent) + return (nms, ((line,col),(cl,indent))) + + transform _ (line, col) (options, place, indent) (TypeDef typ n _) = Result (TypeDef typ n newInf) (snd newInf) cRep + where + (newInf, (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + code $ unwords [ "typedef" + , showType options Value place typ NoRestrict + , n + ] + code ";\n" + (crep, cl, _) <- StateMonad.get + StateMonad.put (crep, cl, indent) + return ((line, col), (cl, indent)) + + transform t (line, col) (options, place, indent) (ProcDef n inp outp body _ _) = + Result (ProcDef n (result1 newInParam) (result1 newOutParam) (result newBody) newInf newInf) (snd newInf) cRep + where + ((newInParam, newOutParam, newBody, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + indenter indent + code $ "void " ++ n ++ "(" + ninp <- monadicListTransform' t (options, MainParameter_pl, indent) inp + let str + | null inp || null outp = "" + | otherwise = ", " + code str + noutp <- monadicListTransform' t (options, MainParameter_pl, indent) outp + code ")\n" + indenter indent + code "{\n" + (crep, al, _) <- StateMonad.get + StateMonad.put (crep, al, addIndent indent) + nb <- monadicTransform' t (options, Declaration_pl, addIndent indent) body + indenter indent + code "}\n" + (_, nl, _) <- StateMonad.get + return (ninp, noutp, nb, ((line,col),(nl,indent))) + + transform t (line, col) (options, _, indent) (ProcDecl n inp outp _ _) = + Result (ProcDecl n (result1 newInParam) (result1 newOutParam) newInf newInf) (snd newInf) cRep + where + ((newInParam, newOutParam, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + indenter indent + code $ "void " ++ n ++ "(" + ninp <- monadicListTransform' t (options, MainParameter_pl, indent) inp + let str + | null inp || null outp = "" + | otherwise = ", " + code str + noutp <- monadicListTransform' t (options, MainParameter_pl, indent) outp + code ");\n" + (_, nl, _) <- StateMonad.get + return (ninp, noutp, ((line,col),(nl,indent))) + +displayComment :: Int -> [String] -> String +displayComment indent = unlines . map (putIndent indent ++) . (["/*"] ++) . (++ [" */"]) . map (" * " ++) + +displayMemInfo :: String -> [Type] -> String +displayMemInfo n [] = n ++ ": none" +displayMemInfo n info = n ++ ": " ++ List.intercalate ", " (map displayType info) + +displayType :: Type -> String +displayType (Alias t _) = displayType t +displayType (ArrayType (LiteralLen n) (ArrayType (LiteralLen m) t)) = + unwords [displayType t, concat ["array(", show n, "x", show m, ")"]] +displayType (ArrayType (LiteralLen n) t) = unwords [displayType t, concat ["array(", show n, ")"]] +displayType (ArrayType UndefinedLen t) = unwords [displayType t, "array"] +displayType (IVarType t) = unwords ["ivar(", displayType t, ")"] +displayType VoidType = "void" +displayType BoolType = "Boolean" +displayType BitType = "bit" +displayType FloatType = "float" +displayType (NumType signed size) = unwords [sg signed, sz size ++ "-bit", "integer"] + where + sg Signed = "signed" + sg Unsigned = "unsigned" + sz S8 = "8" + sz S16 = "16" + sz S32 = "32" + sz S40 = "40" + sz S64 = "64" +displayType (ComplexType t) = unwords ["complex", displayType t] +displayType (UserType s) = s +displayType (StructType _) = "struct" + +instance Transformable DebugToC StructMember where + transform _ (line, col) (options, place, _) dsm@(StructMember str typ _) = Result (StructMember str typ newInf) (snd newInf) cRep + where + (newInf, (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + let t = case structMemberType dsm of + ArrayType{} -> showVariable options place Value (structMemberType dsm) (structMemberName dsm) ++ ";" + _ -> toC options place (structMemberType dsm) ++ " " ++ structMemberName dsm ++ ";" + code $ t ++ "\n" + (_, nl, nc) <- StateMonad.get + return ((line, col), (nl, nc)) + +instance Transformable1 DebugToC [] Declaration where + transform1 _ (line, col) _ [] = Result1 [] (line, col) "" + transform1 t (line, col) (options, place, indent) (x:xs) = Result1 (result newX : result1 newXs) (state1 newXs) ((putIndent indent ++ up newX ++ ";\n" ) ++ up1 newXs) where + newX = transform t (line, col) (options, place, indent) x + (line2, _) = state newX + newSt = (line2 + 1, indent) + newXs = transform1 t newSt (options, place, indent) xs + +instance Transformable DebugToC Block where + transform t (line, col) (options, place, indent) (Block locs body _) = Result (Block (result1 newLocs) (result newBody) newInf) (snd newInf) cRep + where + ((newLocs, newBody, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + nlocs <- monadicListTransform' t (options, Declaration_pl, indent) locs + let str = case up1 newLocs of + "" -> "" + _ -> "\n" + code str + nbody <- monadicTransform' t (options, place, indent) body + (_, nl, _) <- StateMonad.get + return (nlocs, nbody, ((line,col),(nl,indent))) + +instance Transformable DebugToC Declaration where + transform t (line, col) (options, _, indent) (Declaration dv Nothing _) = Result (Declaration (result newDeclVar) Nothing newInf) (snd newInf) cRep + where + ((newDeclVar, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + ndv <- monadicTransform' t (options, Declaration_pl, indent) dv + case varType dv of + (ArrayType _ _) -> code " = {0}" + _ -> code "" + (_, nl, nc) <- StateMonad.get + return (ndv, ((line,col),(nl,nc))) + + transform t (line, col) (options, _, indent) (Declaration dv (Just e) _) = Result (Declaration (result newDeclVar) (Just (result newExpr)) newInf) (snd newInf) cRep + where + ((newDeclVar, newExpr, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + ndv <- monadicTransform' t (options, Declaration_pl, indent) dv + code " = " + ne <- monadicTransform' t (options, ValueNeed_pl, indent) e + (_, nl, nc) <- StateMonad.get + return (ndv, ne, ((line,col),(nl,nc))) + +instance Transformable1 DebugToC [] ActualParameter where + transform1 t pos down l = transform1' t pos down l ", " 0 + +instance Transformable1 DebugToC [] Program where + transform1 t pos down l = transform1' t pos down l "" 0 + + +instance Transformable DebugToC Program where + transform _ (line, col) _ (Empty _ _) = Result (Empty newInf newInf) newSt cRep where + newSt = (line, col) + newInf = ((line, col), newSt) + cRep = "" + + transform _ (line, col) (_, _, indent) (Comment True comment _ _) = Result (Comment True comment newInf newInf) (snd newInf) cRep + where + (newInf, (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + indenter indent + code $ "/* " ++ comment ++ " */\n" + (_, nl, nc) <- StateMonad.get + return ((line, col), (nl, nc)) + + transform _ (line, col) (_, _, indent) (Comment False comment _ _) = Result (Comment False comment newInf newInf) (snd newInf) cRep + where + (newInf, (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + indenter indent + code $ "// " ++ comment ++ "\n" + (_, nl, nc) <- StateMonad.get + return ((line, col), (nl, nc)) + + transform t (line, col) (options, _, indent) (Assign lh rh _ _) = Result (Assign (result newLhs) (result newRhs) newInf newInf) (snd newInf) cRep + where + ((newLhs, newRhs, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + indenter indent + nlhs <- monadicTransform' t (options, ValueNeed_pl, indent) lh + code " = " + nrhs <- monadicTransform' t (options, ValueNeed_pl, indent) rh + code ";\n" + (_, nl, _) <- StateMonad.get + return (nlhs, nrhs, ((line,col),(nl,indent))) + + transform t (line, col) (options, place, indent) (ProcedureCall n param _ _) = Result (ProcedureCall n (result1 newParam) newInf newInf) (snd newInf) cRep + where + ((newParam, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + indenter indent + code $ n ++ "(" + np <- monadicListTransform' t (options, place, indent) param + code ");\n" + (_, nl, _) <- StateMonad.get + return (np, ((line,col),(nl,indent))) + + transform t (line, col) (options, place, indent) (Sequence prog _ _) = Result (Sequence (result1 newProg) newInf newInf) (snd newInf) cRep + where + ((newProg, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + np <- monadicListTransform' t (options, place, indent) prog + return (np, ((line,col),state1 newProg)) + + transform t (line, col) (options, place, indent) (Branch con tPrg ePrg _ _) = Result (Branch (result newCon) (result newTPrg) (result newEPrg) newInf newInf) (snd newInf) cRep + where + ((newCon, newTPrg, newEPrg, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + indenter indent + code "if(" + ncon <- monadicTransform' t (options, ValueNeed_pl, indent) con + code ")\n" + indenter indent + code "{\n" + ntPrg <- monadicTransform' t (options, place, addIndent indent) tPrg + indenter indent + code "}\n" + indenter indent + code "else\n" + indenter indent + code "{\n" + nePrg <- monadicTransform' t (options, place, addIndent indent) ePrg + indenter indent + code "}\n" + (_, nl, nc) <- StateMonad.get + return (ncon, ntPrg, nePrg, ((line,col),(nl,nc))) + + transform t (line, col) (options, place, indent) (SeqLoop con conPrg blockPrg _ _) = Result (SeqLoop (result newCon) (result newConPrg) (result newBlockPrg) newInf newInf) (snd newInf) cRep + where + ((newCon, newConPrg, newBlockPrg, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + indenter indent + code "{\n" + ncp <- monadicTransform' t (options, place, addIndent indent) conPrg + indenter $ addIndent indent + code "while(" + ncon <- monadicTransform' t (options, ValueNeed_pl, addIndent indent) con + code ")\n" + indenter $ addIndent indent + code "{\n" + nbp <- monadicTransform' t (options, place, addIndent $ addIndent indent) blockPrg + monadicTransform' t (options, place, addIndent $ addIndent indent) (blockBody conPrg) + indenter $ addIndent indent + code "}\n" + indenter indent + code "}\n" + (_, nl, nc) <- StateMonad.get + return (ncon, ncp, nbp, ((line,col),(nl,nc))) + + transform t (line, col) (options, place, indent) (ParLoop count bound step prog _ _) = Result (ParLoop (result newCount) (result newBound) step (result newProg) newInf newInf) (snd newInf) cRep + where + ((newCount, newBound, newProg, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + indenter indent + code "for(" + _ <- monadicTransform' t (options, Declaration_pl, addIndent indent) count + code " = 0; " + loopVariable <- monadicTransform' t (options, ValueNeed_pl, addIndent indent) count + code " < " + nb <- monadicTransform' t (options, ValueNeed_pl, addIndent indent) bound + code $ "; " ++ up loopVariable ++ " += " ++ show step ++ ")\n" + indenter indent + code "{\n" + np <- monadicTransform' t (options, place, addIndent indent) prog + indenter indent + code "}\n" + (_, nl, nc) <- StateMonad.get + return (loopVariable, nb, np, ((line,col),(nl,nc))) + + transform t (line, col) (options, place, indent) (BlockProgram prog _) = Result (BlockProgram (result newProg) newInf) (snd newInf) cRep + where + ((newProg, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + indenter indent + code "{\n" + np <- monadicTransform' t (options, place, addIndent indent) prog + indenter indent + code "}\n" + (_, nl, nc) <- StateMonad.get + return (np, ((line,col),(nl,nc))) + +putIndent :: Int -> String +putIndent = concat . flip replicate " " + +addIndent :: Int -> Int +addIndent indent = indent + 4 + +transform1' _ (line, col) _ [] _ _ = Result1 [] (line, col) "" +transform1' t (line, col) (options, place, indent) (x:[]) _ _ = Result1 [result newX] (state newX) (up newX) where + newX = transform t (line, col) (options, place, indent) x +transform1' t (line, col) (options, place, indent) (x:xs) str num = Result1 (result newX : result1 newXs) (state1 newXs) (up newX ++ str ++ up1 newXs) where + newX = transform t (line, col) (options, place, indent) x + (line2, col2) = state newX + newSt = (line2 + num, col2 + length str) + newXs = transform1 t newSt (options, place, indent) xs + +transformConst _ (line, col) (options, _, _) (cnst :: Constant ()) str = Result (newConst cnst) (line, newCol) cRep + where + newConst (IntConst c t _ _) = IntConst c t newInf newInf + newConst (FloatConst c _ _) = FloatConst c newInf newInf + newConst (BoolConst c _ _) = BoolConst c newInf newInf + newInf = ((line, col), (line, newCol)) + (cRep, _, newCol) = snd $ flip StateMonad.runState (defaultState line col) $ do + let s = case List.find (\(t',_) -> t' == typeof cnst) $ values $ platform options of + Just (_,f) -> f cnst + Nothing -> str + code s + +transformActParam _ (line, col) (options, _, _) (TypeParameter typ mode _) _ = Result newParam (snd newInf) cRep + where + newParam = TypeParameter typ mode newInf + place Auto = MainParameter_pl + place Scalar = Declaration_pl + (newInf, (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + code $ showType options Value (place mode) typ NoRestrict + (_, nl, nc) <- StateMonad.get + return ((line,col),(nl,nc)) + +transformActParam _ (line, col) _ (FunParameter n addr _) _ = Result newParam (snd newInf) cRep + where + newParam = FunParameter n addr newInf + (newInf, (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + let addrOp + | addr = "&" + | otherwise = "" + code $ addrOp ++ n + (_, nl, nc) <- StateMonad.get + return ((line, col), (nl, nc)) + +transformActParam t (line, col) (options, _, indent) act paramType = Result (newActParam act) (snd newInf) cRep + where + newActParam Out{} = Out (result newParam) newInf + newActParam In{} = In (result newParam) newInf + getParam (In param _) = param + getParam (Out param _) = param + ((newParam, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + np <- monadicTransform' t (options, paramType, indent) (getParam act) + (_, nl, nc) <- StateMonad.get + return (np, ((line,col),(nl,nc))) + +transformFuncCall t (line, col) (options, place, indent) + (FunctionCall f [a, b] _ _) str1 str2 str3 = + Result (FunctionCall f [result newA, result newB] newInf newInf) (snd newInf) cRep + where + ((newA, newB, newInf), (cRep, _, _)) = flip StateMonad.runState (defaultState line col) $ do + code str1 + na <- monadicTransform' t (options, place, indent) a + code str2 + nb <- monadicTransform' t (options, place, indent) b + code str3 + (_, nl, nc) <- StateMonad.get + return (na, nb, ((line,col),(nl,nc))) + +code s = do + (str, line, col) <- StateMonad.get + let numEOF = length (filter (=='\n') s) + StateMonad.put (str++s,line + numEOF, (if numEOF == 0 then col else 0) + length (takeWhile (/='\n') $ reverse s)) + +indenter n = do + (str, line, col) <- StateMonad.get + StateMonad.put (str ++ concat (replicate n " "), line, col) + +monadicTransform' t down d = do + (_, line, col) <- StateMonad.get + let res = transform t (line, col) down d + code $ up res + return res + +complexTransform t down d = do + (_, line, col) <- StateMonad.get + return $ transform t (line, col) down d + +monadicListTransform' t down l = do + (_, line, col) <- StateMonad.get + let resList = transform1 t (line, col) down l + code $ up1 resList + return resList + +defaultState :: Int -> Int -> (String, Int, Int) +defaultState line col = ("", line, col) diff --git a/lib/Feldspar/Compiler/Backend/C/Plugin/Rule.hs b/lib/Feldspar/Compiler/Backend/C/Plugin/Rule.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Backend/C/Plugin/Rule.hs @@ -0,0 +1,85 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Backend.C.Plugin.Rule + ( RulePlugin(..) + ) where + +import Data.Typeable + +import Feldspar.Transformation +import Feldspar.Compiler.Backend.C.Options + +data RulePlugin = RulePlugin + +instance Transformation RulePlugin + where + type From RulePlugin = () + type To RulePlugin = () + type Down RulePlugin = Options + type Up RulePlugin = [Rule] + type State RulePlugin = Int + +instance Plugin RulePlugin + where + type ExternalInfo RulePlugin = Options + executePlugin _ externalInfo = result . transform RulePlugin 0 externalInfo + +instance (DefaultTransformable RulePlugin t, Typeable1 t) => Transformable RulePlugin t where + transform t s d orig = recurse { result = x'', up = pr1 ++ pr2 ++ pr3, state = newID2 } + where + recurse = defaultTransform t s d orig + applyRule :: t () -> Int -> [Rule] -> (t (), [Rule], [Rule], Int) + applyRule c x = foldl applyRuleFun (c,[],[],x) + where + applyRuleFun :: (t (), [Rule], [Rule], Int) -> Rule -> (t (), [Rule], [Rule], Int) + applyRuleFun (cc,incomp,prop,currentID) (Rule r) = case cast r of + Nothing -> (cc,incomp ++ [Rule r],prop, currentID) + Just r' -> (cc',incomp,prop ++ prop', newID) + where + (cc',prop', newID) = applyAction cc currentID (r' cc) + applyAction :: t () -> Int -> [Action (t ())] -> (t (), [Rule], Int) + applyAction ccc cid = foldl applyActionFun (ccc,[],cid) + where + applyActionFun :: (t (), [Rule], Int) -> Action (t ()) -> (t (), [Rule], Int) + applyActionFun (_ , prop'', i) (Replace newConstr) = (newConstr, prop'' , i) + applyActionFun (ccc' , prop'', i) (Propagate pr) = (ccc' , prop'' ++ [pr], i) + applyActionFun (constr, _ , i) (WithId f) = applyAction constr (i + 1) (f i) + applyActionFun (constr, _ , i) (WithOptions f) = applyAction constr i (f d) + (x',_,pr1,newID1) = applyRule (result recurse) (state recurse) (rules d) + (x'',pr3,pr2,newID2) = applyRule x' newID1 (up recurse) + + +instance Combine [Rule] where + combine = (++) diff --git a/lib/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs b/lib/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs @@ -0,0 +1,199 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Backend.C.Plugin.TypeCorrector where + +import qualified Data.Map as Map +import Feldspar.Transformation +import Feldspar.Compiler.Backend.C.CodeGeneration +import Feldspar.Compiler.Error + +-- =========================================================================== +-- == Type corrector plugin +-- =========================================================================== +-- TODO: IS THIS STILL NEEDED? + +typeCorrectorError :: String -> a +typeCorrectorError = handleError "PluginArch/TypeCorrector" InternalError + +type TypeCatalog = Map.Map String Type + +instance Default TypeCatalog where + def = Map.empty + +-- first collect types of global variables +data GlobalCollector = GlobalCollector +instance Transformation GlobalCollector where + type From GlobalCollector = () + type To GlobalCollector = () + type Down GlobalCollector = Bool -- variable is global + type Up GlobalCollector = () + type State GlobalCollector = TypeCatalog + + +instance Transformable GlobalCollector Entity where + transform t s _ = defaultTransform t s False + +instance Transformable GlobalCollector Variable where + transform _ s d v@(Variable name typ _ ()) = Result v s' () where + s' + | d = Map.insert name typ s + | otherwise = s + +data TypeCheckDown = TypeCheckDown + { globals :: TypeCatalog + , inDeclaration :: Bool + } + +inDecl :: TypeCheckDown -> Bool -> TypeCheckDown +inDecl d b = d {inDeclaration = b} + +instance Default [String] where + def = [] +instance Combine [String] where + combine = (++) + +-- get globals as state collect types of variables in a procedure, then corrert types +data TypeCheck = TypeCheck +instance Transformation TypeCheck where + type From TypeCheck = () + type To TypeCheck = () + type Down TypeCheck = TypeCheckDown -- globals variable's type, in a declaration + type Up TypeCheck = [String] -- errors + type State TypeCheck = TypeCatalog -- local variable's types + +instance Transformable TypeCheck Entity where + transform t _ d p@ProcDef{} = defaultTransform t s' d' p where + s' = def -- start with an empty local variable type catalog + d' = inDecl d True --input parameters are declarations (block will correct where it isn't good) + transform _ s _ p = Result p s def -- just definitions, not implementation, not need check/correct + +instance Transformable TypeCheck Block where + transform t s d b = tr + { result = (result tr) + { blockBody = mkSeq (err (up tr)) $ blockBody $ result tr + } + , state = s -- forget locals + , up = [] + } + where + tr = defaultTransform t s (inDecl d False) b -- we are'n in declaration (correct the procedure's change) + mkSeq (Empty _ _) x = x + mkSeq p (Sequence ps _ _) = Sequence (p:ps) () () + mkSeq p p2 = Sequence [p, p2] () () + err [] = Empty () () + err x = Comment True (listprint id "\n " $ uniq x) () () + uniq [] = [] + uniq (x:xs) = x : uniq (filter (/= x) xs) + +instance Transformable TypeCheck Declaration where + transform t s d (Declaration v i inf) = Result (Declaration (result tr1) (result1 tr2) $ convert inf) (state1 tr2) (combine (up tr1) (up1 tr2)) where + tr1 = transform t s (inDecl d True) v + tr2 = transform1 t (state tr1) d i + +instance Transformable TypeCheck Program where + transform t s d (ParLoop v b i p inf1 inf2) = Result (ParLoop (result tr1) (result tr2) i (result tr3) (convert inf1) $ convert inf2) s' (foldl combine (up tr1) [up tr2, up tr3]) where + tr1 = transform t s (inDecl d True) v -- loop variable is an undeclared local + tr2 = transform t (state tr1) d b + tr3 = transform t (state tr2) d p + s' = s -- forget loop variable (no other new var can be here, other news deleted at block) + transform t s d p = defaultTransform t s d p + +instance Transformable TypeCheck Variable where + transform _ s d v@(Variable name typ _ ()) + | inDeclaration d = Result v (Map.insert name typ s) def + | otherwise = Result v s u' where + u' = case Map.lookup name allVar of + Just typ2 + | typ == typ2 -> [] + | otherwise -> ["Inconsistent types: " ++ name ++ " (actual type: " ++show typ ++ ", declared type: " ++ show typ2 ++ ")"] + Nothing -> ["Undeclared variable: " ++ name] + allVar :: TypeCatalog + allVar = Map.unionWith const (globals d) s + +data TypeCorrector = TypeCorrector +instance Transformation TypeCorrector where + type From TypeCorrector = () + type To TypeCorrector = () + type Down TypeCorrector = TypeCatalog -- global variable's type, in a declaration + type Up TypeCorrector = () + type State TypeCorrector = TypeCatalog -- local variable's types + +instance Transformable TypeCorrector Entity where + transform t _ d p@ProcDef{} = defaultTransform t (state tr) d p where + tr = defaultTransform t def d p -- start with an empty local variable type catalog + transform _ s _ p = Result p s def -- just definitions, not implementation, not need check/correct + +instance Transformable TypeCorrector Variable where + transform _ ls gs v@(Variable name typ _ ()) = Result v' (Map.insert name typ' ls) def where + v' = v {varType = typ'} + typ' = case Map.lookup name allVar of + Just typ2 + | typ == typ2 -> typ2 + | otherwise -> select typ typ2 + Nothing -> typ + allVar = Map.unionWith const gs ls + +select :: Type -> Type -> Type +select act decl + | ok = typ + | otherwise = decl + where + (ok,typ) = select' act decl + select' (ComplexType t1) (ComplexType t2) = (o, ComplexType t) where + (o,t) = select' t1 t2 + select' (ArrayType l1 t1) (ArrayType l2 t2) = (o && o2, ArrayType l t) where + (o,t) = select' t1 t2 + (o2,l) = select'' l1 l2 + select'' UndefinedLen x = (True, x) + select'' x UndefinedLen = (True, x) + select'' (LiteralLen a) (LiteralLen b) = (a==b, LiteralLen b) + select' (StructType t1) (StructType t2) = (o, StructType t) where + (o,t) = select'' t1 t2 + select'' [] [] = (True, []) + select'' [] _ = (False, undefined) + select'' _ [] = (False, undefined) + select'' ((a,st1):ts1) ((b,st2):ts2) = ( a==b && oo && ooo, (a,tt):tts) where + (oo,tt) = select' st1 st2 + (ooo,tts) = select'' ts1 ts2 + select' t1 t2 + | t1 == t2 = (True, t1) + | otherwise = (False, undefined) + +instance Plugin TypeCorrector where + type ExternalInfo TypeCorrector = Bool + executePlugin TypeCorrector showErr procedure = + result $ transform TypeCorrector def gs x where + gs = state $ transform GlobalCollector def False procedure + x + | showErr = result $ transform TypeCheck def (TypeCheckDown gs False) procedure + | otherwise = procedure diff --git a/lib/Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs b/lib/Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs @@ -0,0 +1,87 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Backend.C.Plugin.TypeDefinitionGenerator where + +import Data.List +import Feldspar.Transformation +import Feldspar.Compiler.Backend.C.CodeGeneration +import Feldspar.Compiler.Backend.C.Options +import Feldspar.Compiler.Error + +-- =========================================================================== +-- == Type definition generator plugin +-- =========================================================================== + +typeDefGenError :: ErrorClass -> String -> a +typeDefGenError = handleError "PluginArch/TypeDefinitionGenerator" + +data TypeDefinitionGenerator = TypeDefinitionGenerator + +getTypes :: Options -> Type -> [Entity ()] +getTypes options typ = {-trace ("DEBUG: "show typ) $-} case typ of + StructType members -> concatMap (\(_,t) -> getTypes options t) members + ++ [StructDef { + structName = toC options Declaration_pl (StructType members), + structMembers = map (\(n,t) -> StructMember n t ()) members, + structLabel = (), + definitionLabel = () + }] + ArrayType _ baseType -> getTypes options baseType + _ -> [] + -- XXX complexType? + +instance Transformation TypeDefinitionGenerator where + type From TypeDefinitionGenerator = () + type To TypeDefinitionGenerator = () + type Down TypeDefinitionGenerator = Options + type Up TypeDefinitionGenerator = () + type State TypeDefinitionGenerator = [Entity ()] + +instance Transformable TypeDefinitionGenerator Module where + transform selfpointer origState fromAbove origModule = defaultTransformationResult { + result = (result defaultTransformationResult) { + entities = nub (state defaultTransformationResult) + ++ entities (result defaultTransformationResult) + } + } where + defaultTransformationResult = defaultTransform selfpointer origState fromAbove origModule + +instance Transformable TypeDefinitionGenerator Variable where + transform selfpointer origState fromAbove origVariable = defaultTransformationResult { + state = state defaultTransformationResult ++ getTypes fromAbove (varType origVariable) + } where + defaultTransformationResult = defaultTransform selfpointer origState fromAbove origVariable + +instance Plugin TypeDefinitionGenerator where + type ExternalInfo TypeDefinitionGenerator = Options + executePlugin TypeDefinitionGenerator externalInfo procedure = result + $ transform TypeDefinitionGenerator [{-state-}] externalInfo procedure diff --git a/lib/Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs b/lib/Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs @@ -0,0 +1,76 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Backend.C.Plugin.VariableRoleAssigner where + +import Feldspar.Transformation + +data VariableRoleAssigner = VariableRoleAssigner + +data Parameters = Parameters + { inParametersVRA :: [String] + , outParametersVRA :: [String] + } + +instance Transformation VariableRoleAssigner where + type From VariableRoleAssigner = () + type To VariableRoleAssigner = () + type Down VariableRoleAssigner = Parameters + type Up VariableRoleAssigner = () + type State VariableRoleAssigner = () + +instance Transformable VariableRoleAssigner Variable where + transform _ _ d v = Result v' () () where + v' = v { varRole = if (varName v `elem` outParametersVRA d) || + (isComposite v && (varName v `elem` inParametersVRA d)) + then Pointer else Value + , varLabel = () + } + +instance Transformable VariableRoleAssigner Entity where + transform t s _ p@(ProcDef _ i o _ _ _) = defaultTransform t s d' p where + d' = Parameters + { inParametersVRA = map varName i + , outParametersVRA = map varName o + } + transform t s d p = defaultTransform t s d p + +instance Plugin VariableRoleAssigner where + type ExternalInfo VariableRoleAssigner = () + executePlugin self@VariableRoleAssigner _ procedure = + result $ transform self ({-state-}) (Parameters [] []) procedure + +isComposite :: Variable () -> Bool +isComposite v = case varType v of + ArrayType{} -> True + StructType{} -> True + _ -> False + diff --git a/lib/Feldspar/Compiler/Compiler.hs b/lib/Feldspar/Compiler/Compiler.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Compiler.hs @@ -0,0 +1,248 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Feldspar.Compiler.Compiler where + +import System.FilePath +import Data.Typeable as DT +import Control.Arrow +import Control.Applicative + +import Feldspar.Transformation +import qualified Feldspar.NameExtractor as NameExtractor +import Feldspar.Compiler.Backend.C.Library +import Feldspar.Compiler.Backend.C.Options +import Feldspar.Compiler.Backend.C.Platforms +import Feldspar.Compiler.Backend.C.Plugin.Rule +import Feldspar.Compiler.Backend.C.Plugin.TypeDefinitionGenerator +import Feldspar.Compiler.Backend.C.Plugin.VariableRoleAssigner +import Feldspar.Compiler.Backend.C.Plugin.BlockProgramHandler +import Feldspar.Compiler.Backend.C.Plugin.TypeCorrector +import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint +import Feldspar.Compiler.Imperative.FromCore +import Feldspar.Compiler.Imperative.Plugin.ConstantFolding +import Feldspar.Compiler.Imperative.Plugin.Free +import Feldspar.Compiler.Imperative.Plugin.IVars +import Feldspar.Compiler.Imperative.Plugin.Naming +import Feldspar.Compiler.Imperative.Plugin.Unroll + +data SomeCompilable = forall a internal . Compilable a internal => SomeCompilable a + deriving (DT.Typeable) + +type Position = (Int, Int) + +data SplitModuleDescriptor = SplitModuleDescriptor { + smdSource :: Module (), + smdHeader :: Module () +} + +data CompToCCoreResult = CompToCCoreResult { + sourceCode :: String, + endPosition :: Position, + debugModule :: Module DebugToCSemanticInfo +} + +data SplitCompToCCoreResult = SplitCompToCCoreResult { + sctccrSource :: CompToCCoreResult, + sctccrHeader :: CompToCCoreResult +} + +data IncludesNeeded = IncludesNeeded | NoIncludesNeeded { incneedLineNum :: Int } + +moduleSplitter :: Module () -> SplitModuleDescriptor +moduleSplitter m = SplitModuleDescriptor { + smdHeader = Module (filter belongsToHeader (entities m) ++ createProcDecls (entities m)) (moduleLabel m), + smdSource = Module (filter (not . belongsToHeader) $ entities m) (moduleLabel m) +} where + belongsToHeader :: Entity () -> Bool + belongsToHeader StructDef{} = True + belongsToHeader ProcDecl{} = True + belongsToHeader _ = False + createProcDecls :: [Entity ()] -> [Entity ()] + createProcDecls = foldr ((++) . convertProcDefToProcDecl) [] + convertProcDefToProcDecl :: Entity () -> [Entity ()] + convertProcDefToProcDecl e = case e of + ProcDef n inparams outparams _ label1 label2 -> [ProcDecl n inparams outparams label1 label2] + _ -> [] + +separateAndCompileToCCore :: (Compilable t internal) + => (Module () + -> [Module ()]) + -> CompilationMode -> t -> IncludesNeeded + -> NameExtractor.OriginalFunctionSignature -> Options + -> [(CompToCCoreResult, Module ())] +separateAndCompileToCCore + moduleSeparator + compMode prg needed + functionSignature coreOptions = + pack <$> separatedModules + where + pack = compToCWithInfo &&& id + + separatedModules = + moduleSeparator $ + executePluginChain' compMode prg functionSignature coreOptions + + compToCWithInfo = moduleToCCore needed coreOptions + +moduleToCCore + :: IncludesNeeded -> Options -> Module () + -> CompToCCoreResult +moduleToCCore needed opts mdl = + CompToCCoreResult { + sourceCode = incls ++ moduleSrc + , endPosition = endPos + , debugModule = dbgModule + } + where + (incls, lineNum) = genInclude needed + + (dbgModule, (moduleSrc, endPos)) = + compToCWithInfos ((opts,Declaration_pl), lineNum) mdl + + genInclude IncludesNeeded = genIncludeLines opts Nothing + genInclude (NoIncludesNeeded ln) = ("", ln) + +-- | Compiler core +-- This functionality should not be duplicated. Instead, everything should call this and only do a trivial interface adaptation. +compileToCCore + :: (Compilable t internal) => CompilationMode -> t -> Maybe String -> IncludesNeeded + -> NameExtractor.OriginalFunctionSignature -> Options + -> SplitCompToCCoreResult +compileToCCore compMode prg _ includesNeeded + funSig coreOptions = + createSplit $ fst <$> separateAndCompileToCCore headerAndSource + compMode prg includesNeeded funSig coreOptions + where + headerAndSource modules = [header, source] + where (SplitModuleDescriptor header source) = moduleSplitter modules + + createSplit [header, source] = SplitCompToCCoreResult header source + +genIncludeLinesCore :: [String] -> (String, Int) +genIncludeLinesCore [] = ("", 1) +genIncludeLinesCore (x:xs) = ("#include " ++ x ++ "\n" ++ str, linenum + 1) where + (str, linenum) = genIncludeLinesCore xs + +genIncludeLines :: Options -> Maybe String -> (String, Int) +genIncludeLines coreOptions mainHeader = (str ++ "\n\n", linenum + 2) where + (str, linenum) = genIncludeLinesCore $ includes (platform coreOptions) ++ mainHeaderCore + mainHeaderCore = case mainHeader of + Nothing -> [] + Just filename -> ["\"" ++ takeFileName filename ++ ".h\""] + +-- | Predefined options + +defaultOptions :: Options +defaultOptions + = Options + { platform = c99 + , unroll = NoUnroll + , debug = NoDebug + , memoryInfoVisible = True + , rules = [] + } + +c99PlatformOptions :: Options +c99PlatformOptions = defaultOptions + +tic64xPlatformOptions :: Options +tic64xPlatformOptions = defaultOptions { platform = tic64x } + +unrollOptions :: Options +unrollOptions = defaultOptions { unroll = Unroll 8 } + +noPrimitiveInstructionHandling :: Options +noPrimitiveInstructionHandling = defaultOptions { debug = NoPrimitiveInstructionHandling } + +noMemoryInformation :: Options +noMemoryInformation = defaultOptions { memoryInfoVisible = False } + +-- | Plugin system + +pluginChain :: ExternalInfoCollection -> Module () -> Module () +pluginChain externalInfo + = executePlugin RulePlugin (ruleExternalInfo externalInfo) + . executePlugin TypeDefinitionGenerator (typeDefinitionGeneratorExternalInfo externalInfo) + . executePlugin ConstantFolding () + . executePlugin UnrollPlugin (unrollExternalInfo externalInfo) + . executePlugin Precompilation (precompilationExternalInfo externalInfo) + . executePlugin RulePlugin (primitivesExternalInfo externalInfo) + . executePlugin Free () + . executePlugin IVarPlugin () + . executePlugin VariableRoleAssigner (variableRoleAssignerExternalInfo externalInfo) + . executePlugin TypeCorrector (typeCorrectorExternalInfo externalInfo) + . executePlugin BlockProgramHandler () + +data ExternalInfoCollection = ExternalInfoCollection { + precompilationExternalInfo :: ExternalInfo Precompilation + , unrollExternalInfo :: ExternalInfo UnrollPlugin + , primitivesExternalInfo :: ExternalInfo RulePlugin + , ruleExternalInfo :: ExternalInfo RulePlugin + , typeDefinitionGeneratorExternalInfo :: ExternalInfo TypeDefinitionGenerator + , variableRoleAssignerExternalInfo :: ExternalInfo VariableRoleAssigner + , typeCorrectorExternalInfo :: ExternalInfo TypeCorrector +} + +executePluginChain' :: (Compilable c internal) + => CompilationMode -> c -> NameExtractor.OriginalFunctionSignature + -> Options -> Module () +executePluginChain' compMode prg originalFunctionSignatureParam opt = + pluginChain ExternalInfoCollection { + precompilationExternalInfo = PrecompilationExternalInfo { + originalFunctionSignature = fixedOriginalFunctionSignature + , inputParametersDescriptor = buildInParamDescriptor prg + , numberOfFunctionArguments = numArgs prg + , compilationMode = compMode + } + , unrollExternalInfo = unroll opt + , primitivesExternalInfo = opt{ rules = platformRules $ platform opt } + , ruleExternalInfo = opt + , typeDefinitionGeneratorExternalInfo = opt + , variableRoleAssignerExternalInfo = () + , typeCorrectorExternalInfo = False + } $ fromCore "PLACEHOLDER" prg + where + ofn = NameExtractor.originalFunctionName + fixedOriginalFunctionSignature = originalFunctionSignatureParam { + NameExtractor.originalFunctionName = + fixFunctionName $ ofn originalFunctionSignatureParam + } + +executePluginChain :: (Compilable c internal) + => CompilationMode + -> c + -> NameExtractor.OriginalFunctionSignature + -> Options + -> SplitModuleDescriptor +executePluginChain cm f sig opts = + moduleSplitter $ executePluginChain' cm f sig opts + diff --git a/lib/Feldspar/Compiler/Error.hs b/lib/Feldspar/Compiler/Error.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Error.hs @@ -0,0 +1,35 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +module Feldspar.Compiler.Error where + +data ErrorClass = InvariantViolation | InternalError | Warning + deriving (Show, Eq) + +handleError :: String -> ErrorClass -> String -> a +handleError place errorClass message = error $ "[" ++ show errorClass ++ " @ " ++ place ++ "]: " ++ message diff --git a/lib/Feldspar/Compiler/Frontend/Interactive/Interface.hs b/lib/Feldspar/Compiler/Frontend/Interactive/Interface.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Frontend/Interactive/Interface.hs @@ -0,0 +1,102 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +module Feldspar.Compiler.Frontend.Interactive.Interface where + +import Feldspar.Compiler.Compiler +import Feldspar.Compiler.Imperative.FromCore +import Feldspar.Compiler.Backend.C.Options +import qualified Feldspar.NameExtractor as NameExtractor +import Feldspar.Compiler.Backend.C.Library +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint +import Feldspar.Compiler.Backend.C.Plugin.Locator + +import Data.Char + +-- ================================================================================================ +-- == Interactive compilation +-- ================================================================================================ + +data PrgType = ForType | AssignType | IfType + +forPrg = ForType +ifPrg = IfType +assignPrg = AssignType + +getProgram :: (Int, Int) -> PrgType -> Module DebugToCSemanticInfo -> IO () +getProgram (line, col) prgtype prg = res where + res = if find then putStrLn $ myShow code + else putStrLn "Not found appropriate code part!" + (find, code) = case prgtype of + ForType -> getPrgParLoop (line, col) prg + AssignType -> getPrgAssign (line, col) prg + IfType -> getPrgBranch (line, col) prg + + +compile :: (Compilable t internal) => t -> FilePath -> String -> Options -> IO () +compile prg fileName functionName opts = do + writeFile cfile $ unlines [ "#include \"" ++ hfile ++ "\"" + , sourceCode $ sctccrSource compilationResult + ] + writeFile hfile $ withIncludeGuard $ sourceCode $ sctccrHeader compilationResult + where + hfile = makeHFileName fileName + cfile = makeCFileName fileName + compilationResult = compileToCCore Interactive prg (Just fileName) IncludesNeeded + (NameExtractor.OriginalFunctionSignature functionName []) opts + + withIncludeGuard code = unlines [ "#ifndef " ++ guardName + , "#define " ++ guardName + , "" + , code + , "" + , "#endif // " ++ guardName + ] + + guardName = map ((\c -> if c `elem` toBeChanged then '_' else c) . toUpper) hfile + where + toBeChanged = "./\\" + + +icompile :: (Compilable t internal) => t -> IO () +icompile prg = icompile' prg "test" defaultOptions + +icompile' :: (Compilable t internal) => t -> String -> Options -> IO () +icompile' prg functionName opts = do + putStrLn "=============== Header ================" + putStrLn $ sourceCode $ sctccrHeader compilationResult + putStrLn "=============== Source ================" + putStrLn $ sourceCode $ sctccrSource compilationResult + where + compilationResult = compileToCCore Interactive prg Nothing IncludesNeeded + (NameExtractor.OriginalFunctionSignature functionName []) opts + +icompileWithInfos :: (Compilable t internal) => t -> String -> Options -> SplitCompToCCoreResult +icompileWithInfos prg functionName = compileToCCore Interactive prg Nothing IncludesNeeded + (NameExtractor.OriginalFunctionSignature functionName []) diff --git a/lib/Feldspar/Compiler/Imperative/FromCore.hs b/lib/Feldspar/Compiler/Imperative/FromCore.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE ConstraintKinds #-} + +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +module Feldspar.Compiler.Imperative.FromCore where + + +import Control.Monad.RWS + +import Language.Syntactic +import Language.Syntactic.Constructs.Binding +import Language.Syntactic.Constructs.Binding.HigherOrder + +import Feldspar.Core.Types +import Feldspar.Core.Interpretation +import Feldspar.Core.Constructs +import Feldspar.Core.Constructs.Binding +import Feldspar.Core.Frontend + +import Feldspar.Compiler.Imperative.Representation (Module) +import Feldspar.Compiler.Imperative.Frontend hiding (Type) +import Feldspar.Compiler.Imperative.FromCore.Interpretation +import Feldspar.Compiler.Imperative.FromCore.Array () +import Feldspar.Compiler.Imperative.FromCore.Binding () +import Feldspar.Compiler.Imperative.FromCore.Condition () +import Feldspar.Compiler.Imperative.FromCore.ConditionM () +import Feldspar.Compiler.Imperative.FromCore.Error () +import Feldspar.Compiler.Imperative.FromCore.FFI () +import Feldspar.Compiler.Imperative.FromCore.Future () +import Feldspar.Compiler.Imperative.FromCore.Literal () +import Feldspar.Compiler.Imperative.FromCore.Loop () +import Feldspar.Compiler.Imperative.FromCore.Mutable () +import Feldspar.Compiler.Imperative.FromCore.MutableToPure () +import Feldspar.Compiler.Imperative.FromCore.NoInline () +import Feldspar.Compiler.Imperative.FromCore.Par () +import Feldspar.Compiler.Imperative.FromCore.Primitive () +import Feldspar.Compiler.Imperative.FromCore.Save () +import Feldspar.Compiler.Imperative.FromCore.SizeProp () +import Feldspar.Compiler.Imperative.FromCore.SourceInfo () +import Feldspar.Compiler.Imperative.FromCore.Tuple () + +instance Compile FeldDomain FeldDomain + where + compileProgSym (C' a) = compileProgSym a + compileExprSym (C' a) = compileExprSym a + +instance Compile Empty FeldDomain + where + compileProgSym _ = error "Can't compile Empty" + compileExprSym _ = error "Can't compile Empty" + +compileProgTop :: (Compile dom dom, Project (CLambda Type) dom) => + String -> [Var] -> ASTF (Decor Info dom) a -> Mod +compileProgTop funname args (lam :$ body) + | Just (SubConstr2 (Lambda v)) <- prjLambda lam + = let ta = argType $ infoType $ getInfo lam + sa = defaultSize ta + var = mkVariable (compileTypeRep ta sa) v + in compileProgTop funname (var:args) body +compileProgTop funname args a = Mod defs + where + ins = reverse args + info = getInfo a + outType = compileTypeRep (infoType info) (infoSize info) + outParam = Pointer outType "out" + outLoc = Ptr outType "out" + results = snd $ evalRWS (compileProg outLoc a) initReader initState + Bl ds p = block results + defs = def results ++ [ProcDf funname ins [outParam] (Block ds p)] + +class SyntacticFeld a => Compilable a internal | a -> internal +instance SyntacticFeld a => Compilable a () + -- TODO This class should be replaced by (Syntactic a FeldDomainAll) (or a + -- similar alias) everywhere. The second parameter is not needed. + +fromCore :: SyntacticFeld a => String -> a -> Module () +fromCore funname + = fromInterface + . compileProgTop funname [] + . reifyFeld N32 + +-- | Create a list where each element represents the number of variables needed +-- to as arguments +buildInParamDescriptor :: SyntacticFeld a => a -> [Int] +buildInParamDescriptor = go . reifyFeld N32 + where + go :: (Project (CLambda Type) dom) => ASTF (Decor info dom) a -> [Int] + go (lam :$ body) + | Just (SubConstr2 (Lambda _)) <- prjLambda lam + = 1 : go body + -- TODO the 1 above is valid as long as we represent tuples as structs + -- When we convert a struct to a set of variables the 1 has to replaced + -- with an implementation that calculates the apropriate value. + go _ = [] + +numArgs :: SyntacticFeld a => a -> Int +numArgs = length . buildInParamDescriptor + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Array.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Array.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Array.hs @@ -0,0 +1,133 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Array where + + + +import Language.Syntactic +import Language.Syntactic.Constructs.Binding +import Language.Syntactic.Constructs.Binding.HigherOrder + +import Feldspar.Core.Types as Core +import Feldspar.Core.Interpretation +import Feldspar.Core.Constructs.Array +import Feldspar.Core.Constructs.Binding +import Feldspar.Core.Constructs.Literal + +import Feldspar.Compiler.Imperative.Frontend hiding (Type) +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +instance ( Compile dom dom + , Project (CLambda Type) dom + , Project (Literal :|| Type) dom + , Project (Variable :|| Type) dom + ) + => Compile (Array :|| Type) dom + where + compileProgSym (C' Parallel) _ loc (len :* (lam :$ ixf) :* Nil) + | Just (SubConstr2 (Lambda v)) <- prjLambda lam + = do + let ta = argType $ infoType $ getInfo lam + let sa = defaultSize ta + let ix@(Var _ name) = mkVar (compileTypeRep ta sa) v + len' <- mkLength len + (_, Bl ds body) <- confiscateBlock $ compileProg (loc :!: ix) ixf + tellProg [initArray loc len'] + tellProg [For name len' 1 (Block ds body)] + + + compileProgSym (C' Sequential) _ loc (len :* st :* (lam1 :$ (lam2 :$ step)) :* Nil) + | Just (SubConstr2 (Lambda v)) <- prjLambda lam1 + , Just (SubConstr2 (Lambda s)) <- prjLambda lam2 + = do + let t = argType $ infoType $ getInfo lam1 + let sz = defaultSize t + let ta' = argType $ infoType $ getInfo lam2 + let sa' = defaultSize ta' + let tr' = resType $ infoType $ getInfo lam2 + let sr' = defaultSize tr' + let ix@(Var _ name) = mkVar (compileTypeRep t sz) v + let stv = mkVar (compileTypeRep ta' sa') s + len' <- mkLength len + tmp <- freshVar "seq" tr' sr' + initSt <- compileExpr st + (_, Bl ds (Seq body)) <- confiscateBlock $ compileProg tmp step + tellProg [initArray loc len'] + tellProg [Block (ds ++ [toIni stv initSt]) $ + For name len' 1 $ + Seq (body ++ + [assignProg (loc :!: ix) (tmp :.: "member1") + ,assignProg stv (tmp :.: "member2") + ])] + where toIni (Var ty str) = Init ty str + + compileProgSym (C' Append) _ loc (a :* b :* Nil) = do + a' <- compileExpr a + b' <- compileExpr b + let aLen = arrayLength a' + let bLen = arrayLength b' + tellProg [initArray loc $ Binop U32 "+" [aLen, bLen]] + tellProg [copyProg loc a'] + tellProg [copyProgPos loc aLen b'] + -- TODO: Optimize by writing to directly to 'loc' instead of 'a'' and 'b''! + -- But take care of array initialization: + -- compiling 'a' and 'b' might do initialization itself... + + compileProgSym (C' SetIx) _ loc (arr :* i :* a :* Nil) = do + compileProg loc arr + i' <- compileExpr i + compileProg (loc :!: i') a + + compileProgSym (C' SetLength) _ loc (len :* arr :* Nil) = do + len' <- compileExpr len + tellProg [setLength loc len'] + compileProg loc arr + -- TODO Optimize by using copyProgLen (compare to 0.4) + + compileProgSym a info loc args = compileExprLoc a info loc args + + compileExprSym (C' GetLength) info (a :* Nil) = do + aExpr <- compileExpr a + return $ Fun (compileTypeRep (infoType info) (infoSize info)) "getLength" [aExpr] + + compileExprSym (C' GetIx) _ (arr :* i :* Nil) = do + a' <- compileExpr arr + i' <- compileExpr i + return $ a' :!: i' + + compileExprSym a info args = compileProgFresh a info args + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Binding.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Binding.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Binding.hs @@ -0,0 +1,83 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Binding where + +import Control.Monad.RWS + +import Language.Syntactic +import Language.Syntactic.Constructs.Binding.HigherOrder + +import Feldspar.Core.Types as Core +import Feldspar.Core.Interpretation +import Feldspar.Core.Constructs.Binding +import qualified Feldspar.Core.Constructs.Binding as Core + +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +instance Compile (Core.Variable :|| Type) dom + where + compileExprSym (C' (Core.Variable v)) info Nil = do + env <- ask + case lookup v (alias env) of + Nothing -> return $ mkVar (compileTypeRep (infoType info) (infoSize info)) v + Just e -> return e + +instance Compile (CLambda Type) dom + where + compileProgSym = error "Can only compile top-level Lambda" + +instance (Compile dom dom, Project (CLambda Type) dom) => Compile (Let :|| Type) dom + where + compileProgSym (C' Let) _ loc (a :* (lam :$ body) :* Nil) + | Just (SubConstr2 (Lambda v)) <- prjLambda lam + = compileLet a (getInfo lam) v >> compileProg loc body + + compileExprSym (C' Let) _ (a :* (lam :$ body) :* Nil) + | Just (SubConstr2 (Lambda v)) <- prjLambda lam + = compileLet a (getInfo lam) v >> compileExpr body + +compileLet :: Compile dom dom + => ASTF (Decor Info dom) a -> Info (a -> b) -> VarId -> CodeWriter () +compileLet a info v + = do + let ta = argType $ infoType info + sa = defaultSize ta + var = mkVar (compileTypeRep ta sa) v + declare var + compileProg var a + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Condition.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Condition.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Condition.hs @@ -0,0 +1,55 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Condition where + + +import Language.Syntactic + +import Feldspar.Core.Types as Core +import Feldspar.Core.Constructs.Condition + +import Feldspar.Compiler.Imperative.Frontend +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +instance Compile dom dom => Compile (Condition :|| Core.Type) dom + where + compileProgSym (C' Condition) _ loc (cond :* tHEN :* eLSE :* Nil) = do + condExpr <- compileExpr cond + (_, Bl tds thenProg) <- confiscateBlock $ compileProg loc tHEN + (_, Bl eds elseProg) <- confiscateBlock $ compileProg loc eLSE + tellProg [If condExpr (Block tds thenProg) (Block eds elseProg)] + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/ConditionM.hs b/lib/Feldspar/Compiler/Imperative/FromCore/ConditionM.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/ConditionM.hs @@ -0,0 +1,54 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.ConditionM where + + +import Language.Syntactic + +import Feldspar.Core.Constructs.ConditionM + +import Feldspar.Compiler.Imperative.Frontend +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +instance Compile dom dom => Compile (ConditionM m) dom + where + compileProgSym ConditionM _ loc (cond :* tHEN :* eLSE :* Nil) = do + condExpr <- compileExpr cond + (_, Bl tds thenProg) <- confiscateBlock $ compileProg loc tHEN + (_, Bl eds elseProg) <- confiscateBlock $ compileProg loc eLSE + tellProg [If condExpr (Block tds thenProg) (Block eds elseProg)] + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Error.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Error.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Error.hs @@ -0,0 +1,70 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Error where + + + +import Control.Monad.RWS + +import Language.Syntactic + +import Feldspar.Core.Types (Type) +import Feldspar.Core.Interpretation +import Feldspar.Core.Constructs.Error + +import Feldspar.Compiler.Imperative.Frontend hiding (Type) +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +instance (Compile dom dom) => Compile (Error :|| Type) dom + where + compileProgSym (C' Undefined) _ _ Nil = return () + compileProgSym (C' (Assert msg)) _ loc (cond :* a :* Nil) = do + compileAssert cond msg + compileProg loc a + + compileExprSym (C' (Assert msg)) _ (cond :* a :* Nil) = do + compileAssert cond msg + compileExpr a + compileExprSym a info args = compileProgFresh a info args + +compileAssert :: (Compile dom dom) + => ASTF (Decor Info dom) a -> String -> CodeWriter () +compileAssert cond msg = do + condExpr <- compileExpr cond + tellProg [Call "assert" [In condExpr]] + when (length msg > 0) $ tellProg [Comment $ "{" ++ msg ++ "}"] + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/FFI.hs b/lib/Feldspar/Compiler/Imperative/FromCore/FFI.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/FFI.hs @@ -0,0 +1,51 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.FFI where + +import Language.Syntactic + +import Feldspar.Core.Types (Type) +import Feldspar.Core.Interpretation +import Feldspar.Core.Constructs.FFI + +import Feldspar.Compiler.Imperative.Frontend hiding (Type) +import Feldspar.Compiler.Imperative.FromCore.Interpretation + +instance (Compile dom dom) => Compile (FFI :|| Type) dom + where + compileExprSym (C' (ForeignImport name _)) info args = do + argExprs <- sequence $ listArgs compileExpr args + return $ Fun (compileTypeRep (infoType info) (infoSize info)) name argExprs + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Future.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Future.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Future.hs @@ -0,0 +1,75 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Future where + +import Language.Syntactic + +import Feldspar.Core.Types (Type) +import Feldspar.Core.Constructs.Future + +import Feldspar.Compiler.Imperative.Frontend hiding (Type) +import qualified Feldspar.Compiler.Imperative.Frontend as Front +import Feldspar.Compiler.Imperative.FromCore.Interpretation +import Feldspar.Compiler.Imperative.Plugin.CollectFreeVars +import Feldspar.Transformation (transform, Result(..)) + +import Data.Map (elems) + +instance Compile dom dom => Compile (FUTURE :|| Type) dom + where + compileExprSym = compileProgFresh + + compileProgSym (C' MkFuture) _ loc (p :* Nil) = do + -- Task core: + (_, Bl ds t) <- confiscateBlock $ do + p' <- compileExprVar p + tellProg [iVarPut loc p'] + let b = Block ds t + let vs = elems $ up $ transform Collect () () $ Front.fromInterface b + funId <- freshId + let coreName = "task_core" ++ show funId + tellDef [ProcDf coreName vs [] b] + -- Task: + let taskName = "task" ++ show funId + let runTask = run coreName vs + tellDef [ProcDf taskName [] [Front.Variable Void "params"] runTask] + -- Spawn: + tellProg [iVarInit loc] + tellProg [spawn taskName vs] + + compileProgSym (C' Await) _ loc (a :* Nil) = do + fut <- compileExprVar a -- compileExpr a + tellProg [iVarGet loc fut] + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Interpretation.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Interpretation.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Interpretation.hs @@ -0,0 +1,342 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Interpretation where + + +import Control.Arrow +import Control.Monad.RWS + +import Language.Syntactic.Syntax hiding (result) +import Language.Syntactic.Traversal +import Language.Syntactic.Constraint +import Language.Syntactic.Constructs.Binding (VarId) + +import Feldspar.Range +import Feldspar.Core.Types hiding (Type) +import Feldspar.Core.Interpretation +import qualified Feldspar.Core.Types as Core +import qualified Feldspar.Core.Constructs.Binding as Core +import qualified Feldspar.Core.Constructs.Literal as Core + +import Feldspar.Compiler.Imperative.Frontend +import Feldspar.Compiler.Imperative.Representation (typeof) + +-- | Code generation monad +type CodeWriter = RWS Readers Writers States + +data Readers = Readers { alias :: [(VarId, Expr)] -- ^ variable aliasing + , sourceInfo :: SourceInfo -- ^ Surrounding source info + } + +initReader :: Readers +initReader = Readers [] "" + +data Writers = Writers { block :: Block -- ^ collects code within one block + , def :: [Ent] -- ^ collects top level definitions + } + +instance Monoid Writers + where + mempty = Writers { block = mempty + , def = mempty + } + mappend a b = Writers { block = mappend (block a) (block b) + , def = mappend (def a) (def b) + } + +type Task = [Prog] + +data States = States { fresh :: Integer -- ^ The first fresh variable id + } + +initState :: States +initState = States 0 + +-- | Where to place the program result +type Location = Expr + +-- | A minimal complete instance has to define either 'compileProgSym' or +-- 'compileExprSym'. +class Compile sub dom + where + compileProgSym + :: sub a + -> Info (DenResult a) + -> Location + -> Args (AST (Decor Info dom)) a + -> CodeWriter () + compileProgSym = compileExprLoc + + compileExprSym + :: sub a + -> Info (DenResult a) + -> Args (AST (Decor Info dom)) a + -> CodeWriter Expr + compileExprSym = compileProgFresh + +instance (Compile sub1 dom, Compile sub2 dom) => + Compile (sub1 :+: sub2) dom + where + compileProgSym (InjL a) = compileProgSym a + compileProgSym (InjR a) = compileProgSym a + + compileExprSym (InjL a) = compileExprSym a + compileExprSym (InjR a) = compileExprSym a + + + +-- | Implementation of 'compileExprSym' that assigns an expression to the given +-- location. +compileExprLoc :: Compile sub dom + => sub a + -> Info (DenResult a) + -> Location + -> Args (AST (Decor Info dom)) a + -> CodeWriter () +compileExprLoc a info loc args = do + expr <- compileExprSym a info args + assign loc expr + +-- | Implementation of 'compileProgSym' that generates code into a fresh +-- variable. +compileProgFresh :: Compile sub dom + => sub a + -> Info (DenResult a) + -> Args (AST (Decor Info dom)) a + -> CodeWriter Expr +compileProgFresh a info args = do + loc <- freshVar "e" (infoType info) (infoSize info) + compileProgSym a info loc args + return loc + +compileProgDecor :: Compile dom dom + => Location + -> Decor Info dom a + -> Args (AST (Decor Info dom)) a + -> CodeWriter () +compileProgDecor result (Decor info a) args = do + let src = infoSource info + aboveSrc <- asks sourceInfo + unless (null src || src==aboveSrc) $ tellProg [BComment src] + local (\env -> env {sourceInfo = src}) $ compileProgSym a info result args + +compileExprDecor :: Compile dom dom + => Decor Info dom a + -> Args (AST (Decor Info dom)) a + -> CodeWriter Expr +compileExprDecor (Decor info a) args = do + let src = infoSource info + aboveSrc <- asks sourceInfo + unless (null src || src==aboveSrc) $ tellProg [BComment src] + local (\env -> env {sourceInfo = src}) $ compileExprSym a info args + +compileProg :: Compile dom dom => + Location -> ASTF (Decor Info dom) a -> CodeWriter () +compileProg result = simpleMatch (compileProgDecor result) + +compileExpr :: Compile dom dom => ASTF (Decor Info dom) a -> CodeWriter Expr +compileExpr = simpleMatch compileExprDecor + +-- Compile an expression and make sure that the result is stored in a variable +compileExprVar :: Compile dom dom => ASTF (Decor Info dom) a -> CodeWriter Expr +compileExprVar e = do + e' <- compileExpr e + case e' of + Var _ _ -> return e' + Ptr _ _ -> return e' + _ -> do + varId <- freshId + let loc = Var (typeof e') ('e' : show varId) + declare loc + assign loc e' + return loc + +-------------------------------------------------------------------------------- +-- * Utility functions +-------------------------------------------------------------------------------- + +compileNumType :: Signedness a -> BitWidth n -> Type +compileNumType U N8 = U8 +compileNumType S N8 = I8 +compileNumType U N16 = U16 +compileNumType S N16 = I16 +compileNumType U N32 = U32 +compileNumType S N32 = I32 +compileNumType U N64 = U64 +compileNumType S N64 = I64 +compileNumType U NNative = U32 -- TODO +compileNumType S NNative = I32 -- TODO + +compileTypeRep :: TypeRep a -> Size a -> Type +compileTypeRep UnitType _ = Void +compileTypeRep BoolType _ = Boolean +compileTypeRep (IntType s n) _ = compileNumType s n +compileTypeRep FloatType _ = Floating +compileTypeRep (ComplexType t) _ = Complex (compileTypeRep t (defaultSize t)) +compileTypeRep (Tup2Type a b) (sa,sb) = Struct + [ ("member1", compileTypeRep a sa) + , ("member2", compileTypeRep b sb) + ] +compileTypeRep (Tup3Type a b c) (sa,sb,sc) = Struct + [ ("member1", compileTypeRep a sa) + , ("member2", compileTypeRep b sb) + , ("member3", compileTypeRep c sc) + ] +compileTypeRep (Tup4Type a b c d) (sa,sb,sc,sd) = Struct + [ ("member1", compileTypeRep a sa) + , ("member2", compileTypeRep b sb) + , ("member3", compileTypeRep c sc) + , ("member4", compileTypeRep d sd) + ] +compileTypeRep (Tup5Type a b c d e) (sa,sb,sc,sd,se) = Struct + [ ("member1", compileTypeRep a sa) + , ("member2", compileTypeRep b sb) + , ("member3", compileTypeRep c sc) + , ("member4", compileTypeRep d sd) + , ("member5", compileTypeRep e se) + ] +compileTypeRep (Tup6Type a b c d e f) (sa,sb,sc,sd,se,sf) = Struct + [ ("member1", compileTypeRep a sa) + , ("member2", compileTypeRep b sb) + , ("member3", compileTypeRep c sc) + , ("member4", compileTypeRep d sd) + , ("member5", compileTypeRep e se) + , ("member6", compileTypeRep f sf) + ] +compileTypeRep (Tup7Type a b c d e f g) (sa,sb,sc,sd,se,sf,sg) = Struct + [ ("member1", compileTypeRep a sa) + , ("member2", compileTypeRep b sb) + , ("member3", compileTypeRep c sc) + , ("member4", compileTypeRep d sd) + , ("member5", compileTypeRep e se) + , ("member6", compileTypeRep f sf) + , ("member7", compileTypeRep g sg) + ] +compileTypeRep (MutType a) _ = compileTypeRep a (defaultSize a) +compileTypeRep (RefType a) _ = compileTypeRep a (defaultSize a) +compileTypeRep (ArrayType a) (rs :> es) = if unboundedLength + then Array $ compileTypeRep a es + else SizedArray (fromEnum $ upperBound rs) $ compileTypeRep a es + where + unboundedLength + = upperBound rs > fromIntegral (maxBound :: Int) + -- This ensures that `fromEnum` succeeds + || upperBound rs == maxBound + -- This `maxBound` might be smaller than `maxBound :: Int` +compileTypeRep (MArrType a) _ = Array (compileTypeRep a (defaultSize a)) +compileTypeRep (ParType a) _ = compileTypeRep a (defaultSize a) +compileTypeRep (IVarType a) _ = IVar $ compileTypeRep a $ defaultSize a +compileTypeRep (FunType _ b) sz = compileTypeRep b sz +compileTypeRep (FValType a) sz = IVar $ compileTypeRep a sz +compileTypeRep typ _ = error $ "compileTypeRep: missing " ++ show typ -- TODO + +mkVarName :: VarId -> String +mkVarName v = 'v' : show v + +mkVar :: Type -> VarId -> Expr +mkVar t = Var t . mkVarName + +mkVariable :: Type -> VarId -> Var +mkVariable t = Variable t . mkVarName + +freshId :: CodeWriter Integer +freshId = do + s <- get + let v = fresh s + put (s {fresh = v + 1}) + return v + +freshVar :: String -> TypeRep a -> Size a -> CodeWriter Expr -- TODO take just info instead of TypeRep and Size? +freshVar base t size = do + v <- freshId + let var =Var (compileTypeRep t size) $ base ++ show v + declare var + return var + +declare :: Expr -> CodeWriter () +declare (Var t n) = tellDecl [Def t n] +declare (Ptr t n) = tellDecl [Def t n] +declare expr = error $ "declare: cannot declare expression: " ++ show expr + +tellDef :: [Ent] -> CodeWriter () +tellDef es = tell $ mempty {def = es} + +tellProg :: [Prog] -> CodeWriter () +tellProg ps = tell $ mempty {block = Bl [] $ Seq ps} + +tellDecl :: [Def] -> CodeWriter () +tellDecl ds = tell $ mempty {block = Bl ds $ Seq []} + +assign :: Location -> Expr -> CodeWriter () +assign lhs rhs = if isArray $ typeof lhs + then + tellProg [ initArray lhs $ arrayLength rhs + , copyProg lhs rhs] + else + tellProg [copyProg lhs rhs] + +-- | Like 'listen', but also prevents the program from being written in the +-- monad. +confiscateBlock :: CodeWriter a -> CodeWriter (a, Block) +confiscateBlock m + = liftM (second block) + $ censor (\rec -> rec {block = mempty}) + $ listen m + +withAlias :: VarId -> Expr -> CodeWriter a -> CodeWriter a +withAlias v0 expr = + local (\e -> e {alias = (v0,expr) : alias e}) + +isVariableOrLiteral :: ( Project (Core.Variable :|| Core.Type) dom + , Project (Core.Literal :|| Core.Type) dom) + => AST (Decor info dom) a -> Bool +isVariableOrLiteral (prjF -> Just (C' (Core.Literal _))) = True +isVariableOrLiteral (prjF -> Just (C' (Core.Variable _))) = True +isVariableOrLiteral _ = False + +mkLength :: ( Project (Core.Literal :|| Core.Type) dom + , Project (Core.Variable :|| Core.Type) dom + , Compile dom dom + ) + => ASTF (Decor Info dom) a -> CodeWriter Expr +mkLength a | isVariableOrLiteral a = compileExpr a + | otherwise = do + let lentyp = IntType U N32 + lenvar <- freshVar "len" lentyp (defaultSize lentyp) + compileProg lenvar a + return lenvar + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Literal.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Literal.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Literal.hs @@ -0,0 +1,151 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Literal where + + + +import Control.Monad.RWS +import Data.Complex +import GHC.Float (float2Double) + +import Language.Syntactic + +import Feldspar.Core.Types as Core +import Feldspar.Core.Interpretation +import Feldspar.Core.Constructs.Literal + +import Feldspar.Range (upperBound) + +import Feldspar.Compiler.Imperative.Frontend +import Feldspar.Compiler.Imperative.FromCore.Interpretation + +instance Compile (Literal :|| Core.Type) dom + where + compileExprSym (C' (Literal a)) info Nil = literal (infoType info) (infoSize info) a + + compileProgSym (C' (Literal a)) info loc Nil = literalLoc loc (infoType info) (infoSize info) a + +literal :: TypeRep a -> Size a -> a -> CodeWriter Expr +literal UnitType _ () = return $ LitI I32 0 +literal BoolType _ a = return $ boolToExpr a +literal trep@IntType{} sz a = return $ LitI (compileTypeRep trep sz) (toInteger a) +literal FloatType _ a = return $ LitF $ float2Double a +literal (ComplexType t) _ (r:+i) = do re <- literal t (defaultSize t) r + ie <- literal t (defaultSize t) i + return $ LitC re ie +literal t s a = do loc <- freshVar "x" t s + literalLoc loc t s a + return loc + +literalLoc :: Location -> TypeRep a -> Size a -> a -> CodeWriter () +literalLoc loc (ArrayType t) (rs :> es) e + = do + tellProg [initArray loc $ LitI I32 $ toInteger $ upperBound rs] + zipWithM_ (writeElement t es) (map (LitI I32) [0..]) e + where writeElement :: TypeRep a -> Size a -> Expr -> a -> CodeWriter () + writeElement ty sz ix x = do + expr <- literal ty sz x + assign (loc :!: ix) expr + +literalLoc loc (Tup2Type ta tb) (sa,sb) (a,b) = + do aExpr <- literal ta sa a + bExpr <- literal tb sb b + assign (loc :.: "member1") aExpr + assign (loc :.: "member2") bExpr + +literalLoc loc (Tup3Type ta tb tc) (sa,sb,sc) (a,b,c) = + do aExpr <- literal ta sa a + bExpr <- literal tb sb b + cExpr <- literal tc sc c + assign (loc :.: "member1") aExpr + assign (loc :.: "member2") bExpr + assign (loc :.: "member3") cExpr + +literalLoc loc (Tup4Type ta tb tc td) (sa,sb,sc,sd) (a,b,c,d) = + do aExpr <- literal ta sa a + bExpr <- literal tb sb b + cExpr <- literal tc sc c + dExpr <- literal td sd d + assign (loc :.: "member1") aExpr + assign (loc :.: "member2") bExpr + assign (loc :.: "member3") cExpr + assign (loc :.: "member4") dExpr + +literalLoc loc (Tup5Type ta tb tc td te) (sa,sb,sc,sd,se) (a,b,c,d,e) = + do aExpr <- literal ta sa a + bExpr <- literal tb sb b + cExpr <- literal tc sc c + dExpr <- literal td sd d + eExpr <- literal te se e + assign (loc :.: "member1") aExpr + assign (loc :.: "member2") bExpr + assign (loc :.: "member3") cExpr + assign (loc :.: "member4") dExpr + assign (loc :.: "member5") eExpr + +literalLoc loc (Tup6Type ta tb tc td te tf) (sa,sb,sc,sd,se,sf) (a,b,c,d,e,f) = + do aExpr <- literal ta sa a + bExpr <- literal tb sb b + cExpr <- literal tc sc c + dExpr <- literal td sd d + eExpr <- literal te se e + fExpr <- literal tf sf f + assign (loc :.: "member1") aExpr + assign (loc :.: "member2") bExpr + assign (loc :.: "member3") cExpr + assign (loc :.: "member4") dExpr + assign (loc :.: "member5") eExpr + assign (loc :.: "member6") fExpr + +literalLoc loc (Tup7Type ta tb tc td te tf tg) (sa,sb,sc,sd,se,sf,sg) (a,b,c,d,e,f,g) = + do aExpr <- literal ta sa a + bExpr <- literal tb sb b + cExpr <- literal tc sc c + dExpr <- literal td sd d + eExpr <- literal te se e + fExpr <- literal tf sf f + gExpr <- literal tg sg g + assign (loc :.: "member1") aExpr + assign (loc :.: "member2") bExpr + assign (loc :.: "member3") cExpr + assign (loc :.: "member4") dExpr + assign (loc :.: "member5") eExpr + assign (loc :.: "member6") fExpr + assign (loc :.: "member7") gExpr + +literalLoc loc t sz a = + do rhs <- literal t sz a + assign loc rhs + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Loop.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Loop.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Loop.hs @@ -0,0 +1,110 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Loop where + + +import Prelude hiding (init) + +import Language.Syntactic +import Language.Syntactic.Constructs.Binding +import Language.Syntactic.Constructs.Binding.HigherOrder + +import Feldspar.Core.Types +import Feldspar.Core.Interpretation +import Feldspar.Core.Constructs.Binding +import Feldspar.Core.Constructs.Loop hiding (For, While) +import Feldspar.Core.Constructs.Literal +import qualified Feldspar.Core.Constructs.Loop as Core + +import Feldspar.Compiler.Imperative.Frontend hiding (Type) +import Feldspar.Compiler.Imperative.FromCore.Interpretation + +instance ( Compile dom dom + , Project (CLambda Type) dom + , Project (Literal :|| Type) dom + , Project (Variable :|| Type) dom + ) + => Compile (Loop :|| Type) dom + where + compileProgSym (C' ForLoop) _ loc (len :* init :* (lam1 :$ (lam2 :$ ixf)) :* Nil) + | Just (SubConstr2 (Lambda ix)) <- prjLambda lam1 + , Just (SubConstr2 (Lambda st)) <- prjLambda lam2 + = do + let info1 = getInfo lam1 + info2 = getInfo lam2 + let (Var _ name) = mkVar (compileTypeRep (infoType info1) (infoSize info1)) ix + let stvar = mkVar (compileTypeRep (infoType info2) (infoSize info2)) st + len' <- mkLength len + compileProg loc init + (_, Bl ds body) <- withAlias st loc $ confiscateBlock $ compileProg stvar ixf >> assign loc stvar + declare stvar + tellProg [For name len' 1 (Block ds body)] + + compileProgSym (C' WhileLoop) _ loc (init :* (lam1 :$ cond) :* (lam2 :$ body) :* Nil) + | Just (SubConstr2 (Lambda cv)) <- prjLambda lam1 + , Just (SubConstr2 (Lambda cb)) <- prjLambda lam2 + = do + let info2 = getInfo lam2 + let stvar = mkVar (compileTypeRep (infoType info2) (infoSize info2)) cb + compileProg loc init + cond' <- withAlias cv loc $ compileExpr cond + (_, Bl ds body') <- withAlias cb loc $ confiscateBlock $ compileProg stvar body >> assign loc stvar + declare stvar + tellProg [While Skip cond' (Block ds body')] + +instance ( Compile dom dom + , Project (CLambda Type) dom + , Project (Literal :|| Type) dom + , Project (Variable :|| Type) dom + ) + => Compile (LoopM Mut) dom + where + compileProgSym Core.For _ loc (len :* (lam :$ ixf) :* Nil) + | Just (SubConstr2 (Lambda v)) <- prjLambda lam + = do + let ta = argType $ infoType $ getInfo lam + let sa = defaultSize ta + let (Var _ name) = mkVar (compileTypeRep ta sa) v + len' <- mkLength len + (_, Bl _ body) <- confiscateBlock $ compileProg loc ixf + tellProg [For name len' 1 body] + +-- TODO Missing While + compileProgSym Core.While _ loc (cond :* step :* Nil) + = do + cond' <- compileExpr cond + (_, Bl _ step') <- confiscateBlock $ compileProg loc step + tellProg [While Skip cond' step'] + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Mutable.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Mutable.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Mutable.hs @@ -0,0 +1,134 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Mutable where + + + +import Language.Syntactic +import Language.Syntactic.Constructs.Binding +import Language.Syntactic.Constructs.Binding.HigherOrder + +import Feldspar.Core.Types +import Feldspar.Core.Interpretation +import Feldspar.Core.Constructs.Binding +import Feldspar.Core.Constructs.Mutable +import Feldspar.Core.Constructs.MutableArray +import Feldspar.Core.Constructs.MutableReference + +import Feldspar.Compiler.Imperative.Frontend hiding (Type) +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +instance (Compile dom dom, Project (CLambda Type) dom) => Compile (MONAD Mut) dom + where + compileProgSym Bind _ loc (ma :* (lam :$ body) :* Nil) + | Just (SubConstr2 (Lambda v)) <- prjLambda lam + = do + e <- compileExpr ma + withAlias v e $ compileProg loc body + +{- TODO reenable this implementation! The case above inlines too much if v is used more than once in the body + compileProgSym Bind _ loc (ma :* (Symbol (Decor info lam) :$ body) :* Nil) + | Just (Lambda v) <- prjCtx typeCtx lam + = do + let var = mkVar (compileTypeRep $ argType $ infoType info) v + withDecl var $ do + compileProg var ma + compileProg loc body +-} + + compileProgSym Then _ loc (ma :* mb :* Nil) = do + compileExpr ma + compileProg loc mb + + compileProgSym Return info loc (a :* Nil) + | MutType UnitType <- infoType info = return () + | otherwise = compileProg loc a + + compileProgSym When _ loc (c :* action :* Nil) = do + c' <- compileExpr c + (_, Bl ds body) <- confiscateBlock $ compileProg loc action + tellProg [If c' (Block ds body) Skip] + +instance (Compile dom dom, Project (CLambda Type) dom) => Compile Mutable dom + where + compileProgSym Run _ loc (ma :* Nil) = compileProg loc ma + + compileExprSym Run _ (ma :* Nil) = compileExpr ma + +instance (Compile dom dom, Project (CLambda Type) dom) => Compile MutableReference dom + where + compileProgSym NewRef _ loc (a :* Nil) = compileProg loc a + compileProgSym GetRef _ loc (r :* Nil) = compileProg loc r + compileProgSym SetRef _ _ (r :* a :* Nil) = do + var <- compileExpr r + compileProg var a + + compileExprSym GetRef _ (r :* Nil) = compileExpr r + compileExprSym feat info args = compileProgFresh feat info args + +instance (Compile dom dom, Project (CLambda Type) dom) => Compile MutableArray dom + where + compileProgSym NewArr_ _ loc (len :* Nil) = do + l <- compileExpr len + tellProg [initArray loc l] + + compileProgSym NewArr _ loc (len :* a :* Nil) = do + let ix = Var U32 "i" + a' <- compileExpr a + l <- compileExpr len + tellProg [initArray loc l] + tellProg [For "i" l 1 (Seq [assignProg (loc :!: ix) a'])] + + compileProgSym GetArr _ loc (arr :* i :* Nil) = do + arr' <- compileExpr arr + i' <- compileExpr i + assign loc (arr' :!: i') + + compileProgSym SetArr _ _ (arr :* i :* a :* Nil) = do + arr' <- compileExpr arr + i' <- compileExpr i + a' <- compileExpr a + assign (arr' :!: i') a' + + compileProgSym a info loc args = compileExprLoc a info loc args + + compileExprSym ArrLength info (arr :* Nil) = do + a' <- compileExpr arr + return $ Fun (compileTypeRep (infoType info) (infoSize info)) "getLength" [a'] + + compileExprSym a info args = compileProgFresh a info args + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/MutableToPure.hs b/lib/Feldspar/Compiler/Imperative/FromCore/MutableToPure.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/MutableToPure.hs @@ -0,0 +1,89 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.MutableToPure where + + + +import Language.Syntactic +import Language.Syntactic.Constructs.Binding +import Language.Syntactic.Constructs.Binding.HigherOrder + +import Feldspar.Core.Types +import Feldspar.Core.Interpretation +import Feldspar.Core.Constructs.Binding +import Feldspar.Core.Constructs.MutableToPure + +import Feldspar.Compiler.Imperative.Frontend hiding (Type,Variable) +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +instance ( Compile dom dom + , Project (CLambda Type) dom + , Project (Variable :|| Type) dom + ) + => Compile MutableToPure dom + where + compileProgSym WithArray _ loc (marr :* (lam :$ body) :* Nil) + | Just (C' (Variable _)) <- prjF marr + , Just (SubConstr2 (Lambda v1)) <- prjLambda lam + = do + e <- compileExpr marr + withAlias v1 e $ do + b <- compileExpr body + tellProg [copyProg loc b] + + compileProgSym WithArray _ loc (marr :* (lam :$ body) :* Nil) + | Just (SubConstr2 (Lambda v)) <- prjLambda lam + = do + let ta = argType $ infoType $ getInfo lam + let sa = defaultSize ta + let var = mkVar (compileTypeRep ta sa) v + declare var + compileProg var marr + e <- compileExpr body + tellProg [copyProg loc e] + + compileProgSym RunMutableArray _ loc (marr :* Nil) = compileProg loc marr + +{- NOTES: + +The trick of doing a copy at the end, i.e. `tellProg [copyProg loc +e]`, when compiling WithArray is important. It allows us to safely +return the pure array that is passed in as input. This is nice because +it allows us to implement `freezeArray` in terms of `withArray`. +In most cases I expect `withArray` to return a scalar as its final +result and then the copyProg is harmless. +-} diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/NoInline.hs b/lib/Feldspar/Compiler/Imperative/FromCore/NoInline.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/NoInline.hs @@ -0,0 +1,65 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.NoInline where + +import Data.Map (elems) +import Data.List (partition) +import Language.Syntactic + +import Feldspar.Core.Types (Type) +import Feldspar.Core.Constructs.NoInline +import Feldspar.Transformation (transform, Result(..)) +import Feldspar.Compiler.Imperative.FromCore.Interpretation +import Feldspar.Compiler.Imperative.Frontend hiding (Type,Variable) +import Feldspar.Compiler.Imperative.Plugin.CollectFreeVars +import qualified Feldspar.Compiler.Imperative.Frontend as Front + +instance Compile dom dom => Compile (NoInline :|| Type) dom + where + compileExprSym = compileProgFresh + + compileProgSym (C' NoInline) _ loc (p :* Nil) = do + (_, Bl ds t) <- confiscateBlock $ compileProg loc p + let b = Block ds t + let vs = elems $ up $ transform Collect () () $ Front.fromInterface b + let isInParam v = Front.vName v /= Front.lName loc + let (ins,outs) = partition isInParam vs + funId <- freshId + let funname = "noinline" ++ show funId + tellDef [ProcDf funname ins outs b] + let ins' = map (\v -> Front.In $ Front.Var (vType v) (Front.vName v)) ins + tellProg [Call funname $ ins' ++ [Out loc]] + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Par.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Par.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Par.hs @@ -0,0 +1,132 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Par where + +import Language.Syntactic +import Language.Syntactic.Constructs.Monad +import Language.Syntactic.Constructs.Binding +import Language.Syntactic.Constructs.Binding.HigherOrder + +import Feldspar.Core.Types +import Feldspar.Core.Interpretation +import Feldspar.Core.Constructs.Binding +import Feldspar.Core.Constructs.Par + +import Feldspar.Compiler.Imperative.Frontend hiding (Type,Variable) +import Feldspar.Compiler.Imperative.FromCore.Interpretation +import Feldspar.Compiler.Imperative.Plugin.CollectFreeVars +import qualified Feldspar.Compiler.Imperative.Frontend as Front +import qualified Feldspar.Compiler.Imperative.Representation as AIR +import Feldspar.Transformation (transform, Result(..)) + +import Data.Map (elems) + +instance ( Compile dom dom + , Project (CLambda Type) dom + , Project ParFeature dom + ) + => Compile (MONAD Par) dom + where + compileProgSym Bind _ loc (ma :* (lam :$ body) :* Nil) + | Just (SubConstr2 (Lambda v)) <- prjLambda lam + , Just ParNew <- prj ma + = do + let info = getInfo ma + let var = mkVar (compileTypeRep (infoType info) (infoSize info)) v + declare var + tellProg [iVarInit var] + compileProg loc body + + compileProgSym Bind _ loc (ma :* (lam :$ body) :* Nil) + | Just (SubConstr2 (Lambda v)) <- prjLambda lam + = do + e <- compileExpr ma + withAlias v e $ compileProg loc body + + compileProgSym Then _ loc (ma :* mb :* Nil) = do + compileExpr ma + compileProg loc mb + + compileProgSym Return info loc (a :* Nil) + | ParType UnitType <- infoType info = return () + | otherwise = compileProg loc a + + compileProgSym When _ loc (c :* action :* Nil) = do + c' <- compileExpr c + (_, Bl ds body) <- confiscateBlock $ compileProg loc action + tellProg [If c' (Block ds body) Skip] + +instance ( Compile dom dom + , Project (Variable :|| Type) dom + ) + => Compile ParFeature dom + where + compileExprSym = compileProgFresh + + compileProgSym ParRun _ loc (p :* Nil) = compileProg loc p + + compileProgSym ParGet _ loc (r :* Nil) = do + iv <- compileExpr r + tellProg [iVarGet loc iv] + + compileProgSym ParPut _ _ (r :* a :* Nil) = do + iv <- compileExpr r + val <- compileExpr a + i <- freshId + let var = Var (AIR.typeof val) $ "msg" ++ show i + declare var + assign var val + tellProg [iVarPut iv var] + + compileProgSym ParFork _ loc (p :* Nil) = do + -- Task core: + (_, Bl ds t) <- confiscateBlock $ compileProg loc p + let b = Block ds t + let vs = elems $ up $ transform Collect () () $ Front.fromInterface b + funId <- freshId + let coreName = "task_core" ++ show funId + tellDef [ProcDf coreName vs [] b] + -- Task: + let taskName = "task" ++ show funId + let runTask = run coreName vs + tellDef [ProcDf taskName [] [Front.Variable Void "params"] runTask] + -- Spawn: + tellProg [spawn taskName vs] + + compileProgSym ParYield _ _ Nil = return () + + compileProgSym ParNew _ _ Nil = return () + + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Primitive.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Primitive.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Primitive.hs @@ -0,0 +1,86 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Primitive where + + + +import Language.Syntactic + +import Feldspar.Core.Types (Type) +import Feldspar.Core.Interpretation +import Feldspar.Core.Constructs.Bits +import Feldspar.Core.Constructs.Complex +import Feldspar.Core.Constructs.Conversion +import Feldspar.Core.Constructs.Eq +import Feldspar.Core.Constructs.Floating +import Feldspar.Core.Constructs.Fractional +import Feldspar.Core.Constructs.Integral +import Feldspar.Core.Constructs.Logic +import Feldspar.Core.Constructs.Num +import Feldspar.Core.Constructs.Ord +import Feldspar.Core.Constructs.Trace + +import Feldspar.Compiler.Imperative.Frontend hiding (Type) +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +-- | Converts symbols to primitive function calls +instance Compile dom dom => Compile Semantics dom + where + compileExprSym (Sem name _) info args = do + argExprs <- sequence $ listArgs compileExpr args + return $ Fun (compileTypeRep (infoType info) (infoSize info)) name argExprs + +-- | Convenient implementation of 'compileExprSym' for primitive functions +compilePrim :: (Semantic expr, Compile dom dom) + => (expr :|| Type) a + -> Info (DenResult a) + -> Args (AST (Decor Info dom)) a + -> CodeWriter Expr +compilePrim (C' s) = compileExprSym $ semantics s + +instance Compile dom dom => Compile (BITS :|| Type) dom where compileExprSym = compilePrim +instance Compile dom dom => Compile (COMPLEX :|| Type) dom where compileExprSym = compilePrim +instance Compile dom dom => Compile (Conversion :|| Type) dom where compileExprSym = compilePrim +instance Compile dom dom => Compile (EQ :|| Type) dom where compileExprSym = compilePrim +instance Compile dom dom => Compile (FLOATING :|| Type) dom where compileExprSym = compilePrim +instance Compile dom dom => Compile (FRACTIONAL :|| Type) dom where compileExprSym = compilePrim +instance Compile dom dom => Compile (INTEGRAL :|| Type) dom where compileExprSym = compilePrim +instance Compile dom dom => Compile (Logic :|| Type) dom where compileExprSym = compilePrim +instance Compile dom dom => Compile (NUM :|| Type) dom where compileExprSym = compilePrim +instance Compile dom dom => Compile (ORD :|| Type) dom where compileExprSym = compilePrim +instance Compile dom dom => Compile (Trace :|| Type) dom where compileExprSym = compilePrim + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Save.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Save.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Save.hs @@ -0,0 +1,51 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Save where + + + +import Language.Syntactic + +import Feldspar.Core.Types (Type) +import Feldspar.Core.Constructs.Save + +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +instance Compile dom dom => Compile (Save :|| Type) dom + where + compileProgSym (C' Save) _ loc (a :* Nil) = compileProg loc a + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/SizeProp.hs b/lib/Feldspar/Compiler/Imperative/FromCore/SizeProp.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/SizeProp.hs @@ -0,0 +1,53 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.SizeProp where + + + +import Language.Syntactic + +import Feldspar.Core.Types (Type) +import Feldspar.Core.Constructs.SizeProp + +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +instance Compile dom dom => Compile (PropSize :|| Type) dom + where + compileProgSym (C' (PropSize _)) _ loc (_ :* b :* Nil) = compileProg loc b + + compileExprSym (C' (PropSize _)) _ (_ :* b :* Nil) = compileExpr b + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/SourceInfo.hs b/lib/Feldspar/Compiler/Imperative/FromCore/SourceInfo.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/SourceInfo.hs @@ -0,0 +1,57 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.SourceInfo where + + + +import Language.Syntactic + +import Feldspar.Core.Types +import Feldspar.Core.Constructs.SourceInfo + +import Feldspar.Compiler.Imperative.Frontend hiding (Type) +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +instance Compile dom dom => Compile ((Decor SourceInfo1 Identity) :|| Type) dom + where + compileProgSym (C' (Decor (SourceInfo1 info) Id)) _ loc (a :* Nil) = do + tellProg [BComment info] + compileProg loc a + compileExprSym (C' (Decor (SourceInfo1 info) Id)) _ (a :* Nil) = do + tellProg [BComment info] + compileExpr a + diff --git a/lib/Feldspar/Compiler/Imperative/FromCore/Tuple.hs b/lib/Feldspar/Compiler/Imperative/FromCore/Tuple.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/FromCore/Tuple.hs @@ -0,0 +1,108 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.FromCore.Tuple where + + + +import Language.Syntactic + +import Feldspar.Core.Types +import Feldspar.Core.Constructs.Tuple + +import Feldspar.Compiler.Imperative.Frontend hiding (Type) +import Feldspar.Compiler.Imperative.FromCore.Interpretation + + + +instance Compile dom dom => Compile (Tuple :|| Type) dom + where + compileProgSym (C' Tup2) _ loc (m1 :* m2 :* Nil) = do + compileExpr m1 >>= assign (loc :.: "member1") + compileExpr m2 >>= assign (loc :.: "member2") + compileProgSym (C' Tup3) _ loc (m1 :* m2 :* m3 :* Nil) = do + compileExpr m1 >>= assign (loc :.: "member1") + compileExpr m2 >>= assign (loc :.: "member2") + compileExpr m3 >>= assign (loc :.: "member3") + compileProgSym (C' Tup4) _ loc (m1 :* m2 :* m3 :* m4 :* Nil) = do + compileExpr m1 >>= assign (loc :.: "member1") + compileExpr m2 >>= assign (loc :.: "member2") + compileExpr m3 >>= assign (loc :.: "member3") + compileExpr m4 >>= assign (loc :.: "member4") + compileProgSym (C' Tup5) _ loc (m1 :* m2 :* m3 :* m4 :* m5 :* Nil) = do + compileExpr m1 >>= assign (loc :.: "member1") + compileExpr m2 >>= assign (loc :.: "member2") + compileExpr m3 >>= assign (loc :.: "member3") + compileExpr m4 >>= assign (loc :.: "member4") + compileExpr m5 >>= assign (loc :.: "member5") + compileProgSym (C' Tup6) _ loc (m1 :* m2 :* m3 :* m4 :* m5 :* m6 :* Nil) = do + compileExpr m1 >>= assign (loc :.: "member1") + compileExpr m2 >>= assign (loc :.: "member2") + compileExpr m3 >>= assign (loc :.: "member3") + compileExpr m4 >>= assign (loc :.: "member4") + compileExpr m5 >>= assign (loc :.: "member5") + compileExpr m6 >>= assign (loc :.: "member6") + compileProgSym (C' Tup7) _ loc (m1 :* m2 :* m3 :* m4 :* m5 :* m6 :* m7 :* Nil) = do + compileExpr m1 >>= assign (loc :.: "member1") + compileExpr m2 >>= assign (loc :.: "member2") + compileExpr m3 >>= assign (loc :.: "member3") + compileExpr m4 >>= assign (loc :.: "member4") + compileExpr m5 >>= assign (loc :.: "member5") + compileExpr m6 >>= assign (loc :.: "member6") + compileExpr m7 >>= assign (loc :.: "member7") + +instance Compile dom dom => Compile (Select :|| Type) dom + where + compileExprSym (C' Sel1) _ (tup :* Nil) = do + tupExpr <- compileExpr tup + return $ tupExpr :.: "member1" + compileExprSym (C' Sel2) _ (tup :* Nil) = do + tupExpr <- compileExpr tup + return $ tupExpr :.: "member2" + compileExprSym (C' Sel3) _ (tup :* Nil) = do + tupExpr <- compileExpr tup + return $ tupExpr :.: "member3" + compileExprSym (C' Sel4) _ (tup :* Nil) = do + tupExpr <- compileExpr tup + return $ tupExpr :.: "member4" + compileExprSym (C' Sel5) _ (tup :* Nil) = do + tupExpr <- compileExpr tup + return $ tupExpr :.: "member5" + compileExprSym (C' Sel6) _ (tup :* Nil) = do + tupExpr <- compileExpr tup + return $ tupExpr :.: "member6" + compileExprSym (C' Sel7) _ (tup :* Nil) = do + tupExpr <- compileExpr tup + return $ tupExpr :.: "member7" + diff --git a/lib/Feldspar/Compiler/Imperative/Frontend.hs b/lib/Feldspar/Compiler/Imperative/Frontend.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/Frontend.hs @@ -0,0 +1,476 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} + +module Feldspar.Compiler.Imperative.Frontend where + +import Data.List +import Data.Monoid +import Control.Arrow (second) + +import Feldspar.Compiler.Imperative.Representation hiding (Type, UserType, Cast, In, Out, Variable, Block, Pointer, Comment, Spawn, Run) +import qualified Feldspar.Compiler.Imperative.Representation as AIR + + +-- * Frontend data types + +data Mod = Mod [Ent] + deriving (Show) + +data Ent + = StructD String [(String, Type)] + | ProcDf String [Var] [Var] Prog + | ProcDcl String [Var] [Var] + deriving (Eq,Show) + +data Type + = Void + | Boolean + | Bit + | Floating + | I8 | I16 | I32 | I40 | I64 + | U8 | U16 | U32 | U40 | U64 + | Complex Type + | UserType String + | Array Type + | SizedArray Int Type + | Struct [(String, Type)] + | IVar Type + deriving Eq + +data Expr + = Var Type String + | Ptr Type String + | Tr + | Fl + | LitI Type Integer + | LitF Double + | LitC Expr Expr + | Expr :!: Expr + | Expr :.: String + | Binop Type String [Expr] + | Fun Type String [Expr] + | Cast Type Expr + | SizeofE Expr + | SizeofT Type + deriving (Eq,Show) + +data Prog + = Skip + | BComment String + | Comment String + | Expr := Expr + | Call String [Param] + | Seq [Prog] + | If Expr Prog Prog + | While Prog Expr Prog + | For String Expr Int Prog + | Block [Def] Prog + deriving (Eq,Show) + +instance Monoid Prog + where + mempty = Skip + mappend Skip p = p + mappend p Skip = p + mappend (Seq pa) (Seq pb) = Seq $ mappend pa pb + mappend pa pb = Seq [mappend pa pb] + +data Param + = In Expr + | Out Expr + | TypAuto Type + | TypScalar Type + | Fn String + | FnAddr String + deriving (Eq,Show) + +data Block = Bl [Def] Prog + deriving (Eq,Show) + +instance Monoid Block + where + mempty = Bl [] Skip + mappend (Bl da pa) (Bl db pb) = Bl (mappend da db) (mappend pa pb) + +data Def + = Init Type String Expr + | Def Type String + deriving (Eq,Show) + +data Var + = Variable Type String + | Pointer Type String + deriving (Eq,Show) + +class Named a where + getName :: a -> String +instance Named Def where + getName (Init _ n _) = n + getName (Def _ n) = n +instance Named Var where + getName (Variable _ n) = n + getName (Pointer _ n) = n + +-- * Conversion between representation and frontend + +class Interface t where + type Repr t + toInterface :: Repr t -> t + fromInterface :: t -> Repr t + +instance Interface Mod where + type Repr Mod = AIR.Module () + toInterface (Module es ()) = Mod $ map toInterface es + fromInterface (Mod es) = AIR.Module (map fromInterface es) () + +instance Interface Ent where + type Repr Ent = AIR.Entity () + toInterface (AIR.StructDef name members () ()) = + StructD name (map (\(StructMember mname mtyp ())->(mname,toInterface mtyp)) members) + toInterface (AIR.ProcDef name inparams outparams body () ()) = + ProcDf name (map toInterface inparams) (map toInterface outparams) (toProg body) + toInterface (AIR.ProcDecl name inparams outparams () ()) = + ProcDcl name (map toInterface inparams) (map toInterface outparams) + toInterface AIR.TypeDef{} = error "TypeDef not handled" + fromInterface (StructD name members) = + AIR.StructDef name (map (\(mname,mtyp)->(StructMember mname (fromInterface mtyp) ())) members) () () + fromInterface (ProcDf name inparams outparams body) = + AIR.ProcDef name (map fromInterface inparams) (map fromInterface outparams) (toBlock body) () () + fromInterface (ProcDcl name inparams outparams) = + AIR.ProcDecl name (map fromInterface inparams) (map fromInterface outparams) () () + +instance Interface Type where + type Repr Type = AIR.Type + toInterface VoidType = Void + toInterface Alias{} = error "Alias not handled" + toInterface AIR.BoolType = Boolean + toInterface BitType = Bit + toInterface AIR.FloatType = Floating + toInterface (NumType Signed S8) = I8 + toInterface (NumType Signed S16) = I16 + toInterface (NumType Signed S32) = I32 + toInterface (NumType Signed S40) = I40 + toInterface (NumType Signed S64) = I64 + toInterface (NumType Unsigned S8) = U8 + toInterface (NumType Unsigned S16) = U16 + toInterface (NumType Unsigned S32) = U32 + toInterface (NumType Unsigned S40) = U40 + toInterface (NumType Unsigned S64) = U64 + toInterface (AIR.ComplexType t) = Complex $ toInterface t + toInterface (AIR.UserType s) = UserType s + toInterface (AIR.ArrayType (LiteralLen l) t) = SizedArray l $ toInterface t + toInterface (AIR.ArrayType _ t) = Array $ toInterface t + toInterface (AIR.StructType fields) = Struct $ map (second toInterface) fields + toInterface (AIR.IVarType t) = IVar $ toInterface t + fromInterface Void = VoidType + fromInterface Boolean = AIR.BoolType + fromInterface Bit = BitType + fromInterface Floating = AIR.FloatType + fromInterface I8 = NumType Signed S8 + fromInterface I16 = NumType Signed S16 + fromInterface I32 = NumType Signed S32 + fromInterface I40 = NumType Signed S40 + fromInterface I64 = NumType Signed S64 + fromInterface U8 = NumType Unsigned S8 + fromInterface U16 = NumType Unsigned S16 + fromInterface U32 = NumType Unsigned S32 + fromInterface U40 = NumType Unsigned S40 + fromInterface U64 = NumType Unsigned S64 + fromInterface (Complex t) = AIR.ComplexType $ fromInterface t + fromInterface (UserType s) = AIR.UserType s + fromInterface (Array t) = AIR.ArrayType UndefinedLen $ fromInterface t + fromInterface (SizedArray l t) = AIR.ArrayType (LiteralLen l) $ fromInterface t + fromInterface (Struct fields) = AIR.StructType $ map (second fromInterface) fields + fromInterface (IVar t) = AIR.IVarType $ fromInterface t + +instance Interface Expr where + type Repr Expr = Expression () + toInterface (VarExpr (AIR.Variable name t Value ()) ()) = Var (toInterface t) name + toInterface (VarExpr (AIR.Variable name t AIR.Pointer ()) ()) = Ptr (toInterface t) name + toInterface (ArrayElem arr idx () ()) = toInterface arr :!: toInterface idx + toInterface (StructField str field () ()) = toInterface str :.: field + toInterface (ConstExpr (BoolConst True () ()) ()) = Tr + toInterface (ConstExpr (BoolConst False () ()) ()) = Fl + toInterface (ConstExpr (IntConst x t () ()) ()) = LitI (toInterface t) x + toInterface (ConstExpr (FloatConst x () ()) ()) = LitF x + toInterface (ConstExpr (ComplexConst r i () ()) ()) = LitC (toInterface $ ConstExpr r ()) (toInterface $ ConstExpr i ()) + toInterface (FunctionCall (Function name t Prefix) ps () ()) = Fun (toInterface t) name $ map toInterface ps + toInterface (FunctionCall (Function name t Infix) ps () ()) = Binop (toInterface t) name $ map toInterface ps + toInterface (AIR.Cast t e () ()) = Cast (toInterface t) (toInterface e) + toInterface (SizeOf (Left t) () ()) = SizeofT $ toInterface t + toInterface (SizeOf (Right e) () ()) = SizeofE $ toInterface e + fromInterface (Var t name) = VarExpr (AIR.Variable name (fromInterface t) Value ()) () + fromInterface (Ptr t name) = VarExpr (AIR.Variable name (fromInterface t) AIR.Pointer ()) () + fromInterface (Tr) = ConstExpr (BoolConst True () ()) () + fromInterface (Fl) = ConstExpr (BoolConst False () ()) () + fromInterface (LitI t x) = ConstExpr (IntConst x (fromInterface t) () ()) () + fromInterface (LitF x) = ConstExpr (FloatConst x () ()) () + fromInterface (LitC (fromInterface -> (ConstExpr r ())) (fromInterface -> (ConstExpr i ()))) = + ConstExpr (ComplexConst r i () ()) () + fromInterface (LitC _ _) = error "Illegal LitC" -- TODO (?) + fromInterface (Binop t name es) = FunctionCall (Function name (fromInterface t) Infix) (map fromInterface es) () () + fromInterface (Fun t name es) = FunctionCall (Function name (fromInterface t) Prefix) (map fromInterface es) () () + fromInterface (Cast t e) = AIR.Cast (fromInterface t) (fromInterface e) () () + fromInterface (SizeofE e) = SizeOf (Right $ fromInterface e) () () + fromInterface (SizeofT t) = SizeOf (Left $ fromInterface t) () () + fromInterface (arr :!: idx) = ArrayElem (fromInterface arr) (fromInterface idx) () () + fromInterface (str :.: field) = StructField (fromInterface str) field () () + +instance Interface Prog where + type Repr Prog = AIR.Program () + toInterface (Empty () ()) = Skip + toInterface (AIR.Comment True s () ()) = BComment s + toInterface (AIR.Comment False s () ()) = Comment s + toInterface Assign{..} = toInterface lhs := toInterface rhs + toInterface (ProcedureCall s ps () ()) = Call s (map toInterface ps) + toInterface (Sequence ps () ()) = Seq (map toInterface ps) + toInterface (Branch e b1 b2 () ()) = If (toInterface e) (toProg b1) (toProg b2) + toInterface (SeqLoop e pe b () ()) = While (toProg pe) (toInterface e) (toProg b) + toInterface (ParLoop v e i b () ()) = For (varName v) (toInterface e) i (toProg b) + toInterface (BlockProgram b ()) = Block (map toInterface $ locals b) (toInterface $ blockBody b) + fromInterface (Skip) = Empty () () + fromInterface (BComment s) = AIR.Comment True s () () + fromInterface (Comment s) = AIR.Comment False s () () + fromInterface (lhs := rhs) = Assign (fromInterface lhs) (fromInterface rhs) () () + fromInterface (Call s ps) = ProcedureCall s (map fromInterface ps) () () + fromInterface (Seq ps) = Sequence (map fromInterface ps) () () + fromInterface (If e p1 p2) = Branch (fromInterface e) (toBlock p1) (toBlock p2) () () + fromInterface (While pe e p) = SeqLoop (fromInterface e) (toBlock pe) (toBlock p) () () + fromInterface (For s e i p) = ParLoop + (AIR.Variable s (NumType Unsigned S32) Value ()) (fromInterface e) i (toBlock p) () () + fromInterface (Block ds p) = BlockProgram (AIR.Block (map fromInterface ds) (fromInterface p) ()) () + +instance Interface Param where + type Repr Param = ActualParameter () + toInterface (AIR.In e ()) = In (toInterface e) + toInterface (AIR.Out e ()) = Out (toInterface e) + toInterface (AIR.TypeParameter e AIR.Auto ()) = TypAuto (toInterface e) + toInterface (AIR.TypeParameter e AIR.Scalar ()) = TypScalar (toInterface e) + toInterface (AIR.FunParameter n False ()) = Fn n + toInterface (AIR.FunParameter n True ()) = FnAddr n + fromInterface (In e) = AIR.In (fromInterface e) () + fromInterface (Out e) = AIR.Out (fromInterface e) () + fromInterface (TypAuto e) = AIR.TypeParameter (fromInterface e) Auto () + fromInterface (TypScalar e) = AIR.TypeParameter (fromInterface e) Scalar () + fromInterface (Fn n) = AIR.FunParameter n False () + fromInterface (FnAddr n) = AIR.FunParameter n True () + +instance Interface Def where + type Repr Def = Declaration () + toInterface (Declaration v (Just e) ()) = Init (toInterface $ varType v) (varName v) (toInterface e) + toInterface (Declaration v Nothing ()) = Def (toInterface $ varType v) (varName v) + fromInterface (Init t s e) = Declaration (AIR.Variable s (fromInterface t) Value ()) (Just $ fromInterface e) () + fromInterface (Def t s) = Declaration (AIR.Variable s (fromInterface t) Value ()) Nothing () + +instance Interface Block where + type Repr Block = AIR.Block () + toInterface (AIR.Block ds p ()) = Bl (map toInterface ds) (toInterface p) + fromInterface (Bl ds p) = AIR.Block (map fromInterface ds) (fromInterface p) () + +instance Interface Var where + type Repr Var = AIR.Variable () + toInterface (AIR.Variable name typ Value ()) = Variable (toInterface typ) name + toInterface (AIR.Variable name typ AIR.Pointer ()) = Pointer (toInterface typ) name + fromInterface (Variable typ name) = AIR.Variable name (fromInterface typ) Value () + fromInterface (Pointer typ name) = AIR.Variable name (fromInterface typ) AIR.Pointer () + +toBlock :: Prog -> AIR.Block () +toBlock (Block ds p) = AIR.Block (map fromInterface ds) (fromInterface p) () +toBlock p = AIR.Block [] (fromInterface p) () + +toProg :: AIR.Block () -> Prog +toProg (AIR.Block [] p ()) = toInterface p +toProg (AIR.Block ds p ()) = Block (map toInterface ds) (toInterface p) + +boolToExpr :: Bool -> Expr +boolToExpr True = Tr +boolToExpr False = Fl + +setLength :: Expr -> Expr -> Prog +setLength arr len = Call "setLength" [Out arr, In len] + +copyProg :: Expr -> Expr -> Prog +copyProg outExp inExp = Call "copy" [Out outExp, In inExp] + +copyProgPos :: Expr -> Expr -> Expr -> Prog +copyProgPos outExp shift inExp = Call "copyArrayPos" [Out outExp, In shift, In inExp] + +copyProgLen :: Expr -> Expr -> Expr -> Prog +copyProgLen outExp inExp len = Call "copyArrayLen" [Out outExp, In inExp, In len] + +initArray :: Expr -> Expr -> Prog +initArray arr len = Call "initArray" [Out arr, In s, In len] + where + s + | isArray t = Binop U32 "-" [LitI U32 0,SizeofT t] + | otherwise = SizeofT t + t = case typeof arr of + Array e -> e + SizedArray _ e -> e + _ -> error $ "Feldspar.Compiler.Imperative.Frontend.initArray: invalid type of array " ++ show arr ++ "::" ++ show (typeof arr) + +assignProg :: Expr -> Expr -> Prog +assignProg lhs rhs + | isArray (typeof lhs) = Seq [ini,cp] + | otherwise = cp + where + ini = initArray lhs $ arrayLength rhs + cp = copyProg lhs rhs + +freeArray :: Var -> Prog +freeArray arr = Call "freeArray" [Out $ varToExpr arr] + +arrayLength :: Expr -> Expr +arrayLength (Var (SizedArray n _) _) = LitI U32 $ fromIntegral n +arrayLength (Ptr (SizedArray n _) _) = LitI U32 $ fromIntegral n +arrayLength arr = Fun U32 "getLength" [arr] + +iVarInit :: Expr -> Prog +iVarInit var = Call "ivar_init" [Out var] + +iVarGet :: Expr -> Expr -> Prog +iVarGet loc ivar + | isArray typ = Call "ivar_get_array" [Out loc, In ivar] + | otherwise = Call "ivar_get" [TypScalar typ, Out loc, In ivar] + where + typ = typeof loc + +iVarPut :: Expr -> Expr -> Prog +iVarPut ivar msg + | isArray typ = Call "ivar_put_array" [In ivar, Out msg] + | otherwise = Call "ivar_put" [TypAuto typ, In ivar, Out msg] + where + typ = typeof msg + +spawn :: String -> [Var] -> Prog +spawn taskName vs = Call spawnName allParams + where + spawnName = "spawn" ++ show (length vs) + taskParam = FnAddr taskName + typeParams = map (TypAuto . vType) vs + varParams = map (\v -> In $ Var (vType v) (vName v)) vs + allParams = taskParam : concat (zipWith (\a b -> [a,b]) typeParams varParams) + +run :: String -> [Var] -> Prog +run taskName vs = Call runName allParams + where + runName = "run" ++ show (length vs) + typeParams = map (TypAuto . vType) vs + taskParam = Fn taskName + allParams = taskParam : typeParams + +instance Show Type + where + show Void = "void" + show Boolean = "bool" + show Bit = "bit" + show Floating = "float" + show I8 = "int8" + show I16 = "int16" + show I32 = "int32" + show I40 = "int40" + show I64 = "int64" + show U8 = "uint8" + show U16 = "uint16" + show U32 = "uint32" + show U40 = "uint40" + show U64 = "uint64" + show (Complex t) = "complexOf_" ++ show t + show (UserType s) = "userType_" ++ s + show (Array t) = "arrayOf_" ++ show t + show (SizedArray i t) = "arrayOfSize_" ++ show i ++ "_" ++ show t + show (Struct fields) = "struct_" ++ intercalate "_" (map (\(s,t) -> s ++ "_" ++ show t) fields) + show (IVar t) = "ivarOf_" ++ show t + +instance HasType Expr + where + type TypeOf Expr = Type + typeof = toInterface . typeof . fromInterface + +instance HasType Var + where + type TypeOf Var = Type + typeof = toInterface . typeof . fromInterface + +intWidth :: Type -> Maybe Integer +intWidth I8 = Just 8 +intWidth I16 = Just 16 +intWidth I32 = Just 32 +intWidth I40 = Just 40 +intWidth I64 = Just 64 +intWidth U8 = Just 8 +intWidth U16 = Just 16 +intWidth U32 = Just 32 +intWidth U40 = Just 40 +intWidth U64 = Just 64 +intWidth _ = Nothing + +intSigned :: Type -> Maybe Bool +intSigned I8 = Just True +intSigned I16 = Just True +intSigned I32 = Just True +intSigned I40 = Just True +intSigned I64 = Just True +intSigned U8 = Just False +intSigned U16 = Just False +intSigned U32 = Just False +intSigned U40 = Just False +intSigned U64 = Just False +intSigned _ = Nothing + +litB :: Bool -> Expr +litB True = Tr +litB False = Fl + +isArray :: Type -> Bool +isArray (Array _) = True +isArray (SizedArray _ _) = True +isArray _ = False + +vType :: Var -> Type +vType (Variable t _) = t +vType (Pointer t _) = t + +vName :: Var -> String +vName (Variable _ s) = s +vName (Pointer _ s) = s + +lName :: Expr -> String +lName (Var _ s) = s +lName (Ptr _ s) = s +lName (e :!: _) = lName e +lName (e :.: _) = lName e +lName e = error $ "Feldspar.Compiler.Imperative.Frontend.lName: invalid location: " ++ show e + +varToExpr :: Var -> Expr +varToExpr (Variable t name) = Var t name +varToExpr (Pointer t name) = Ptr t name diff --git a/lib/Feldspar/Compiler/Imperative/Plugin/CollectFreeVars.hs b/lib/Feldspar/Compiler/Imperative/Plugin/CollectFreeVars.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/Plugin/CollectFreeVars.hs @@ -0,0 +1,82 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.Plugin.CollectFreeVars where + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Feldspar.Compiler.Imperative.Frontend as Front +import Feldspar.Transformation + +data Collect = Collect + +type Collection = Map String Front.Var + +instance Default Collection where + def = Map.empty + +instance Combine Collection where + combine = Map.union + +instance Transformation Collect + where + type From Collect = () + type To Collect = () + type Down Collect = () + type Up Collect = Collection + type State Collect = () + +instance Plugin Collect + where + type ExternalInfo Collect = () + executePlugin _ externalInfo = result . transform Collect () externalInfo + +instance Transformable Collect Variable where + transform _ _ _ v = Result v () $ Map.singleton (varName v) (Front.toInterface v) + +instance Transformable Collect Block where + transform t _ _ bl = Result bl' () diff + where + Result bl' _ m = defaultTransform t () () bl + localNames = map (varName . declVar) $ locals bl' + localMap = Map.fromList $ map (\name -> (name,())) localNames + diff = m `Map.difference` localMap + +instance Transformable Collect Program where + transform t _ _ pr@(ParLoop idxVar _ _ _ _ _) = Result pr' () diff + where + Result pr' _ m = defaultTransform t () () pr + diff = Map.delete (varName idxVar) m + transform t _ _ prog = defaultTransform t () () prog diff --git a/lib/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs b/lib/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs @@ -0,0 +1,69 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.Plugin.ConstantFolding where + +import Feldspar.Transformation + +data ConstantFolding = ConstantFolding + +instance Plugin ConstantFolding where + type ExternalInfo ConstantFolding = () + executePlugin ConstantFolding _ procedure = result $ transform ConstantFolding () () procedure + +instance Transformation ConstantFolding where + type From ConstantFolding = () + type To ConstantFolding = () + type Down ConstantFolding = () + type Up ConstantFolding = () + type State ConstantFolding = () + +instance Transformable ConstantFolding Expression where + transform t s d f@FunctionCall{} = case funMode $ function f' of + Infix -> case funName $ function f' of + "+" -> tr' $ elimParamIf (isConstIntN 0) True $ result tr + "-" -> tr' $ elimParamIf (isConstIntN 0) False $ result tr + "*" -> tr' $ elimParamIf (isConstIntN 1) True $ result tr + _ -> tr + _ -> tr + where + tr = defaultTransform t s d f + tr' x = tr {result = x} + f' = result tr + isConstIntN n (ConstExpr (IntConst i _ _ _) _) = n == i + isConstIntN _ _ = False + + elimParamIf predicate flippable funCall@(FunctionCall (Function _ _ Infix) (x:xs) _ _) + | predicate (head xs) = x + | flippable && predicate x = head xs + | otherwise = funCall + elimParamIf _ _ funCall = funCall + transform t s d e = defaultTransform t s d e diff --git a/lib/Feldspar/Compiler/Imperative/Plugin/Free.hs b/lib/Feldspar/Compiler/Imperative/Plugin/Free.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/Plugin/Free.hs @@ -0,0 +1,61 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.Plugin.Free where + +import Feldspar.Compiler.Imperative.Frontend (toInterface, fromInterface, isArray, freeArray) +import Feldspar.Transformation + +data Free = Free + +instance Transformation Free + where + type From Free = () + type To Free = () + type Down Free = () + type Up Free = () + type State Free = () + +instance Plugin Free + where + type ExternalInfo Free = () + executePlugin _ _ = result . transform Free () () + +instance Transformable Free Block where + transform _ _ _ (Block locs b _) = Result bl' () () + where + arrays = filter (isArray . typeof) $ map (toInterface . declVar) locs + newBody = Sequence (b : map (fromInterface . freeArray) arrays) () () + bl' = Block locs newBody () diff --git a/lib/Feldspar/Compiler/Imperative/Plugin/IVars.hs b/lib/Feldspar/Compiler/Imperative/Plugin/IVars.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/Plugin/IVars.hs @@ -0,0 +1,82 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.Plugin.IVars where + +import Feldspar.Transformation + +import Data.List (isPrefixOf) + +data IVarPlugin = IVarPlugin + +instance Transformation IVarPlugin + where + type From IVarPlugin = () + type To IVarPlugin = () + type Down IVarPlugin = Bool -- True if the code is in a task. + type Up IVarPlugin = () + type State IVarPlugin = () + +instance Plugin IVarPlugin + where + type ExternalInfo IVarPlugin = () + executePlugin _ _ = result . transform IVarPlugin () False + +instance Transformable IVarPlugin Entity where + transform t _ _ p@ProcDef{} = defaultTransform t () (isTask p) p + where + isTask proc = "task" `isPrefixOf` procName proc -- TODO: this is hacky :) + transform t _ d p = defaultTransform t () d p + +instance Transformable IVarPlugin Program where + transform _ _ d (ProcedureCall name ps _ _) + | "ivar_get" `isPrefixOf` name + = Result pc' () () + where + pc' = ProcedureCall name' ps () () + name' | d = name + | otherwise = name ++ "_nontask" + transform t _ d x = defaultTransform t () d x + +instance Transformable IVarPlugin Block where + transform t _ d b = Result b{ blockBody = body' } () () + where + body' = Sequence prg () () + prg = result (transform t () d $ blockBody b) : destrs + iVars = filter isIVar $ map declVar $ locals b + isIVar v = case varType v of + IVarType _ -> True + _ -> False + ivarFun s v = ProcedureCall ("ivar_" ++ s) [p] () () + where + p = Out (VarExpr v ()) () + destrs = map (ivarFun "destroy") iVars diff --git a/lib/Feldspar/Compiler/Imperative/Plugin/Naming.hs b/lib/Feldspar/Compiler/Imperative/Plugin/Naming.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/Plugin/Naming.hs @@ -0,0 +1,194 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.Plugin.Naming where + +import Data.List (isPrefixOf) + +import Feldspar.Transformation + +import qualified Feldspar.NameExtractor as Precompiler +import Feldspar.Compiler.Error +import Feldspar.Compiler.Backend.C.Library + +import System.IO.Unsafe + +-- =========================================================================== +-- == Precompilation plugin +-- =========================================================================== + +data SignatureInformation = SignatureInformation { + originalFunctionName :: String, + generatedImperativeParameterNames :: [String], + originalParameterNames :: Maybe [Maybe String] +} deriving (Show, Eq) + +instance Default SignatureInformation where def = precompilationError InternalError "Default value should not be used" + +precompilationError :: ErrorClass -> String -> a +precompilationError = handleError "PluginArch/Naming" + +data Precompilation = Precompilation + +instance Transformation Precompilation where + type From Precompilation = () + type To Precompilation = () + type Down Precompilation = SignatureInformation + type Up Precompilation = () + type State Precompilation = () + + +instance Transformable Precompilation Entity where + transform t s d x@(ProcDef n i _ _ _ _) + | n == "PLACEHOLDER" = tr { result = (result tr){ procName = n' } } + where + d' = d { generatedImperativeParameterNames = map varName i } + tr = defaultTransform t s d' x + n' = originalFunctionName d + transform t s d x@(ProcDef n _ _ _ _ _) + | any (n `isPrefixOf`) proceduresToPrefix = tr { result = (result tr){ procName = n' } } + where + n' = prefix d n + tr = defaultTransform t s d' x + d' = d{ generatedImperativeParameterNames = [] } + transform t s d x@ProcDef{} = defaultTransform t s d' x + where + d' = d{ generatedImperativeParameterNames = [] } + transform t s d x = defaultTransform t s d x + + +instance Transformable Precompilation Variable where + transform _ s d v = Result newVar s def + where + newVar = v + { varName = maybeStr2Str (getVariableName d $ varName v) ++ varName v + , varLabel = () + } + +instance Transformable Precompilation ActualParameter where + transform _ s d (FunParameter n addr _) + | any (n `isPrefixOf`) proceduresToPrefix + = Result (FunParameter (prefix d n) addr ()) s def + transform t s d x = defaultTransform t s d x + +instance Transformable Precompilation Program where + transform t s d c@(ProcedureCall n _ _ _) + | any (n `isPrefixOf`) proceduresToPrefix = tr { result = (result tr){ procCallName = n' } } + where + tr = defaultTransform t s d c + n' = prefix d n + transform t s d x = defaultTransform t s d x + +proceduresToPrefix :: [String] +proceduresToPrefix = ["noinline", "task"] + +prefix :: SignatureInformation -> String -> String +prefix d n = originalFunctionName d ++ "_" ++ n + +getVariableName :: SignatureInformation -> String -> Maybe String +getVariableName signatureInformation origname = case originalParameterNames signatureInformation of + Just originalParameterNameList -> + if length (generatedImperativeParameterNames signatureInformation) == length originalParameterNameList then + case searchResults of + [] -> Nothing + _ -> snd $ head searchResults + else + Nothing + -- precompilationError InternalError $ "parameter name list length mismatch:" ++ + -- show (generatedImperativeParameterNames signatureInformation) ++ " " ++ show originalParameterNameList + where + searchResults = filter ((origname ==).fst) + (zip (generatedImperativeParameterNames signatureInformation) originalParameterNameList) + Nothing -> Nothing + +maybeStr2Str :: Maybe String -> String +maybeStr2Str (Just s) = s ++ "_" +maybeStr2Str Nothing = "" + +data PrecompilationExternalInfo = PrecompilationExternalInfo { + originalFunctionSignature :: Precompiler.OriginalFunctionSignature, + inputParametersDescriptor :: [Int], + numberOfFunctionArguments :: Int, + compilationMode :: CompilationMode +} + +addPostfixNumberToMaybeString :: (Maybe String, Int) -> Maybe String +addPostfixNumberToMaybeString (ms, num) = ms >>= \s -> return $ s ++ show num + +inflate :: Int -> [Maybe String] -> [Maybe String] +inflate target list | length list < target = inflate target (list++[Nothing]) + | length list == target = list + | otherwise = precompilationError InternalError "Unexpected situation in 'inflate'" + +-- Replicates each element of the [parameter list given by the precompiler] based on the input parameter descriptor +parameterNameListConsolidator :: PrecompilationExternalInfo -> [Maybe String] +parameterNameListConsolidator externalInfo = + if numberOfFunctionArguments externalInfo == length (inputParametersDescriptor externalInfo) + then + concatMap (uncurry replicate) + (zip (inputParametersDescriptor externalInfo) + (Precompiler.originalParameterNames $ originalFunctionSignature externalInfo)) + else + precompilationError InternalError "numArgs should be equal to the length of the input parameters' descriptor" + +instance Plugin Precompilation where + type ExternalInfo Precompilation = PrecompilationExternalInfo + executePlugin Precompilation externalInfo procedure = result + $ transform Precompilation ({-state-}) SignatureInformation{ + originalFunctionName = Precompiler.originalFunctionName $ originalFunctionSignature externalInfo, + generatedImperativeParameterNames = precompilationError InternalError "GIPN should have been overwritten", + originalParameterNames = case compilationMode externalInfo of + Standalone -> + if -- ultimate check, should be enough... + numberOfFunctionArguments externalInfo == + length (Precompiler.originalParameterNames $ originalFunctionSignature externalInfo) + then + Just $ parameterNameListConsolidator externalInfo + else + unsafePerformIO $ do + withColor Yellow $ putStrLn $ unwords [ "[WARNING @ PluginArch/Naming]:" + , " not enough named parameters in function " + , Precompiler.originalFunctionName (originalFunctionSignature externalInfo) + ] + withColor Yellow $ putStrLn $ "numArgs: " ++ show (numberOfFunctionArguments externalInfo) ++ + ", parameter list: " ++ show (Precompiler.originalParameterNames $ + originalFunctionSignature externalInfo) + return $ Just $ parameterNameListConsolidator (externalInfo { + originalFunctionSignature = (originalFunctionSignature externalInfo) { + Precompiler.originalParameterNames = + inflate (numberOfFunctionArguments externalInfo) $ + Precompiler.originalParameterNames $ + originalFunctionSignature externalInfo + } + }) + Interactive -> Nothing -- no parameter name handling in interactive mode + } procedure + diff --git a/lib/Feldspar/Compiler/Imperative/Plugin/Unroll.hs b/lib/Feldspar/Compiler/Imperative/Plugin/Unroll.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/Plugin/Unroll.hs @@ -0,0 +1,285 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.Plugin.Unroll where + +import Feldspar.Compiler.Backend.C.Options +import Feldspar.Transformation + +-- ============================ +-- == Unroll's Semantic info == +-- ============================ + +data SemInfPrg = SemInfPrg + { position :: Int + , varNames :: [String] + , loopVar :: String + } deriving (Eq, Show) + +data UnrollSemInf + +instance Annotation UnrollSemInf Module where + type Label UnrollSemInf Module = () + +instance Annotation UnrollSemInf Entity where + type Label UnrollSemInf Entity = () + +instance Annotation UnrollSemInf Struct where + type Label UnrollSemInf Struct = () + +instance Annotation UnrollSemInf StructMember where + type Label UnrollSemInf StructMember = () + +instance Annotation UnrollSemInf ProcDef where + type Label UnrollSemInf ProcDef = () + +instance Annotation UnrollSemInf ProcDecl where + type Label UnrollSemInf ProcDecl = () + +instance Annotation UnrollSemInf Block where + type Label UnrollSemInf Block = () + +instance Annotation UnrollSemInf Program where + type Label UnrollSemInf Program = Maybe SemInfPrg + +instance Annotation UnrollSemInf Empty where + type Label UnrollSemInf Empty = () + +instance Annotation UnrollSemInf Comment where + type Label UnrollSemInf Comment = () + +instance Annotation UnrollSemInf Assign where + type Label UnrollSemInf Assign = () + +instance Annotation UnrollSemInf ProcedureCall where + type Label UnrollSemInf ProcedureCall = () + +instance Annotation UnrollSemInf Spawn where + type Label UnrollSemInf Spawn = () + +instance Annotation UnrollSemInf Run where + type Label UnrollSemInf Run = () + +instance Annotation UnrollSemInf Sequence where + type Label UnrollSemInf Sequence = () + +instance Annotation UnrollSemInf Branch where + type Label UnrollSemInf Branch = () + +instance Annotation UnrollSemInf SeqLoop where + type Label UnrollSemInf SeqLoop = () + +instance Annotation UnrollSemInf ParLoop where + type Label UnrollSemInf ParLoop = () + +instance Annotation UnrollSemInf ActualParameter where + type Label UnrollSemInf ActualParameter = () + +instance Annotation UnrollSemInf Declaration where + type Label UnrollSemInf Declaration = () + +instance Annotation UnrollSemInf Expression where + type Label UnrollSemInf Expression = () + +instance Annotation UnrollSemInf FunctionCall where + type Label UnrollSemInf FunctionCall = () + +instance Annotation UnrollSemInf Cast where + type Label UnrollSemInf Cast = () + +instance Annotation UnrollSemInf SizeOf where + type Label UnrollSemInf SizeOf = () + +instance Annotation UnrollSemInf ArrayElem where + type Label UnrollSemInf ArrayElem = () + +instance Annotation UnrollSemInf StructField where + type Label UnrollSemInf StructField = () + +instance Annotation UnrollSemInf Constant where + type Label UnrollSemInf Constant = () + +instance Annotation UnrollSemInf IntConst where + type Label UnrollSemInf IntConst = () + +instance Annotation UnrollSemInf FloatConst where + type Label UnrollSemInf FloatConst = () + +instance Annotation UnrollSemInf BoolConst where + type Label UnrollSemInf BoolConst = () + +instance Annotation UnrollSemInf ArrayConst where + type Label UnrollSemInf ArrayConst = () + +instance Annotation UnrollSemInf ComplexConst where + type Label UnrollSemInf ComplexConst = () + +instance Annotation UnrollSemInf Variable where + type Label UnrollSemInf Variable = () + +-- == +-- == Plugin +-- == + +instance Default Bool where + def = False + +instance Combine Bool where + combine = (||) + +instance Default (Maybe SemInfPrg) where def = Nothing + + +instance Plugin UnrollPlugin where + type ExternalInfo UnrollPlugin = UnrollStrategy + executePlugin UnrollPlugin ei p = case ei of + NoUnroll -> p + Unroll unrollCount -> result $ transform Unroll2 () Nothing $ result $ transform Unroll1 () unrollCount p + +data UnrollPlugin = UnrollPlugin +instance Transformation UnrollPlugin where + type From UnrollPlugin = () + type To UnrollPlugin = () + type Down UnrollPlugin = () + type Up UnrollPlugin = () + type State UnrollPlugin = () + +data Unroll1 = Unroll1 +instance Transformation Unroll1 where + type From Unroll1 = () + type To Unroll1 = UnrollSemInf + type Down Unroll1 = Int + type Up Unroll1 = Bool + type State Unroll1 = () + +instance Transformable Unroll1 Program where + transform t s d p@ParLoop{} + | not (up tr) + , unrollPossible = tr' + | otherwise = tr + where + tr = defaultTransform t s d p + tr' = tr + { result = (result tr) + { pLoopStep = d + , pLoopBlock = loopCore + { locals = unrollDecls + , blockBody = Sequence prgs () Nothing + } + } + , up = True + } + prgs = map (\(i,prg) -> prg{ programLabel = Just (SemInfPrg i vns loopCounter) }) $ zip [0,1..] replPrg + replPrg = replicate d $ blockBody loopCore + unrollDecls = concatMap (uncurry renameDecls) $ zip [0..] replDecls + renameDecls (i :: Int) = map (\decl -> renameDeclaration decl (getVarNameDecl decl ++ "_u" ++ show i)) + replDecls = replicate d $ locals loopCore + loopCore = pLoopBlock $ result tr + loopBound = pLoopBound $ result tr + loopCounter = varName $ pLoopCounter $ result tr + vns = map getVarNameDecl $ locals loopCore + unrollPossible = case loopBound of + (ConstExpr (IntConst i _ _ _) _) -> mod i (toInteger d) == 0 + _ -> False + transform t s d p = defaultTransform t s d p + + +data Unroll2 = Unroll2 +instance Transformation Unroll2 where + type From Unroll2 = UnrollSemInf + type To Unroll2 = () + type Down Unroll2 = Maybe SemInfPrg + type Up Unroll2 = () + type State Unroll2 = () + +instance Transformable Unroll2 Program where + transform t s d p = defaultTransform t s d' p where + d' = case programLabel p of + Nothing -> d + x -> x + +instance Transformable Unroll2 Expression where + transform t s d l = case d of + Nothing -> tr + Just x -> case l of + VarExpr n _ + | varName n == loopVar x -> tr + { result = FunctionCall + { function = Function + { funName = "+" + , returnType = NumType Signed S32 + , funMode = Infix + } + , funCallParams = + [ result tr + , ConstExpr (IntConst (toInteger $ position x) (NumType Signed S32) () ()) () + ] + , funCallLabel = () + , exprLabel = () + } + } + | otherwise -> tr + _ -> tr + where + tr = defaultTransform t s d l + + +instance Transformable Unroll2 Variable where + transform t s d v = case d of + Just x + | varName v `elem` varNames x -> tr + { result = (result tr) + { varName = varName v ++ "_u" ++ show (position x) + , varLabel = () + } + } + | otherwise -> tr + Nothing -> tr + where + tr = defaultTransform t s d v + + +-- helper functions : +isJust :: Maybe t -> Bool +isJust (Just _) = True +isJust _ = False + +getVarNameDecl :: Declaration t -> String +getVarNameDecl d = varName $ declVar d + +renameDeclaration :: Declaration t -> String -> Declaration t +renameDeclaration d n = d { declVar = renameVariable (declVar d) n } + +renameVariable :: Variable t -> String -> Variable t +renameVariable v n = v { varName = n } + diff --git a/lib/Feldspar/Compiler/Imperative/Representation.hs b/lib/Feldspar/Compiler/Imperative/Representation.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/Representation.hs @@ -0,0 +1,620 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.Representation where + +import Data.Typeable +import qualified Data.List as List (find) + +import Feldspar.Compiler.Error + +-- =============================================================================================== +-- == Class defining semantic information attached to different nodes in the imperative program == +-- =============================================================================================== + +class Annotation t (s :: * -> *) where + type Label t s + +instance Annotation () s where + type Label () s = () + +-- ================================================= +-- == Data stuctures to store imperative programs == +-- ================================================= + +data Module t = Module + { entities :: [Entity t] + , moduleLabel :: Label t Module + } + deriving Typeable + +deriving instance (ShowLabel t) => Show (Module t) +deriving instance (EqLabel t) => Eq (Module t) + +data Entity t + = StructDef + { structName :: String + , structMembers :: [StructMember t] + , structLabel :: Label t Struct + , definitionLabel :: Label t Entity + } + | TypeDef + { actualType :: Type + , typeName :: String + , definitionLabel :: Label t Entity + } + | ProcDef + { procName :: String + , inParams :: [Variable t] + , outParams :: [Variable t] + , procBody :: Block t + , procDefLabel :: Label t ProcDef + , definitionLabel :: Label t Entity + } + | ProcDecl + { procName :: String + , inParams :: [Variable t] + , outParams :: [Variable t] + , procDeclLabel :: Label t ProcDecl + , definitionLabel :: Label t Entity + } + deriving Typeable + +deriving instance (ShowLabel t) => Show (Entity t) +deriving instance (EqLabel t) => Eq (Entity t) + +data StructMember t = StructMember + { structMemberName :: String + , structMemberType :: Type + , structMemberLabel :: Label t StructMember + } + deriving Typeable + +deriving instance (ShowLabel t) => Show (StructMember t) +deriving instance (EqLabel t) => Eq (StructMember t) + +data Block t = Block + { locals :: [Declaration t] + , blockBody :: Program t + , blockLabel :: Label t Block + } + deriving Typeable + +deriving instance (ShowLabel t) => Show (Block t) +deriving instance (EqLabel t) => Eq (Block t) + +data Program t + = Empty + { emptyLabel :: Label t Empty + , programLabel :: Label t Program + } + | Comment + { isBlockComment :: Bool + , commentValue :: String + , commentLabel :: Label t Comment + , programLabel :: Label t Program + } + | Assign + { lhs :: Expression t + , rhs :: Expression t + , assignLabel :: Label t Assign + , programLabel :: Label t Program + } + | ProcedureCall + { procCallName :: String + , procCallParams :: [ActualParameter t] + , procCallLabel :: Label t ProcedureCall + , programLabel :: Label t Program + } + | Sequence + { sequenceProgs :: [Program t] + , sequenceLabel :: Label t Sequence + , programLabel :: Label t Program + } + | Branch + { branchCond :: Expression t + , thenBlock :: Block t + , elseBlock :: Block t + , branchLabel :: Label t Branch + , programLabel :: Label t Program + } + | SeqLoop + { sLoopCond :: Expression t + , sLoopCondCalc :: Block t + , sLoopBlock :: Block t + , sLoopLabel :: Label t SeqLoop + , programLabel :: Label t Program + } + | ParLoop + { pLoopCounter :: Variable t + , pLoopBound :: Expression t + , pLoopStep :: Int + , pLoopBlock :: Block t + , pLoopLabel :: Label t ParLoop + , programLabel :: Label t Program + } + | BlockProgram + { blockProgram :: Block t + , programLabel :: Label t Program + } + deriving Typeable + +deriving instance (ShowLabel t) => Show (Program t) +deriving instance (EqLabel t) => Eq (Program t) + +data ActualParameter t + = In + { inParam :: Expression t + , actParamLabel :: Label t ActualParameter + } + | Out + { outParam :: Expression t + , actParamLabel :: Label t ActualParameter + } + | TypeParameter + { typeParam :: Type + , typeParamMode :: TypeParameterMode + , actParamLabel :: Label t ActualParameter + } + | FunParameter + { funParamName :: String + , addressNeeded :: Bool + , actParamLabel :: Label t ActualParameter + } + deriving Typeable + +deriving instance (ShowLabel t) => Show (ActualParameter t) +deriving instance (EqLabel t) => Eq (ActualParameter t) + +data Declaration t = Declaration + { declVar :: Variable t + , initVal :: Maybe (Expression t) + , declLabel :: Label t Declaration + } + deriving Typeable + +deriving instance (ShowLabel t) => Show (Declaration t) +deriving instance (EqLabel t) => Eq (Declaration t) + +data Expression t + = VarExpr + { var :: Variable t + , exprLabel :: Label t Expression + } + | ArrayElem + { array :: Expression t + , arrayIndex :: Expression t + , arrayLabel :: Label t ArrayElem + , exprLabel :: Label t Expression + } + | StructField + { struct :: Expression t + , fieldName :: String + , structFieldLabel :: Label t StructField + , exprLabel :: Label t Expression + } + | ConstExpr + { constExpr :: Constant t + , exprLabel :: Label t Expression + } + | FunctionCall + { function :: Function + , funCallParams :: [Expression t] + , funCallLabel :: Label t FunctionCall + , exprLabel :: Label t Expression + } + | Cast + { castType :: Type + , castExpr :: Expression t + , castLabel :: Label t Cast + , exprLabel :: Label t Expression + } + | SizeOf + { sizeOf :: Either Type (Expression t) + , sizeOfLabel :: Label t SizeOf + , exprLabel :: Label t Expression + } + deriving Typeable + +deriving instance (ShowLabel t) => Show (Expression t) +deriving instance (EqLabel t) => Eq (Expression t) + +data Function = Function { + funName :: String + , returnType :: Type + , funMode :: FunctionMode +} deriving (Eq, Show) + +data Constant t + = IntConst + { intValue :: Integer + , intType :: Type + , intConstLabel :: Label t IntConst + , constLabel :: Label t Constant + } + | FloatConst + { floatValue :: Double + , floatConstLabel :: Label t FloatConst + , constLabel :: Label t Constant + } + | BoolConst + { boolValue :: Bool + , boolConstLabel :: Label t BoolConst + , constLabel :: Label t Constant + } + | ComplexConst + { realPartComplexValue :: Constant t + , imagPartComplexValue :: Constant t + , complexConstLabel :: Label t ComplexConst + , constLabel :: Label t Constant + } + deriving Typeable + +deriving instance (ShowLabel t) => Show (Constant t) +deriving instance (EqLabel t) => Eq (Constant t) + +data Variable t = Variable + { varName :: String + , varType :: Type + , varRole :: VariableRole + , varLabel :: Label t Variable + } + deriving Typeable + +deriving instance (ShowLabel t) => Show (Variable t) +deriving instance (EqLabel t) => Eq (Variable t) + +-- ====================== +-- == Basic structures == +-- ====================== + +data Length = + LiteralLen Int + | UndefinedLen + deriving (Eq,Show) + +data Size = S8 | S16 | S32 | S40 | S64 + deriving (Eq,Show) + +data Signedness = Signed | Unsigned + deriving (Eq,Show) + +data Type = + VoidType + | BoolType + | BitType + | FloatType + | NumType Signedness Size + | ComplexType Type + | UserType String + | Alias Type String + | ArrayType Length Type + | StructType [(String, Type)] + | IVarType Type + deriving (Eq,Show) + +data FunctionMode = Prefix | Infix + deriving (Eq,Show) + +data VariableRole = Value | Pointer + deriving (Eq,Show) + +data Place + = Declaration_pl + | MainParameter_pl + | ValueNeed_pl + | AddressNeed_pl + | FunctionCallIn_pl + deriving (Eq,Show) + +data TypeParameterMode = Auto | Scalar + deriving (Eq,Show) + +---------------------- +-- Type inference -- +---------------------- + +class HasType a where + type TypeOf a + typeof :: a -> TypeOf a + +instance HasType (Variable t) where + type TypeOf (Variable t) = Type + typeof Variable{..} = varType + +instance (ShowLabel t) => HasType (Constant t) where + type TypeOf (Constant t) = Type + typeof IntConst{..} = intType + typeof FloatConst{} = FloatType + typeof BoolConst{} = BoolType + typeof ComplexConst{..} = ComplexType $ typeof realPartComplexValue + +instance (ShowLabel t) => HasType (Expression t) where + type TypeOf (Expression t) = Type + typeof VarExpr{..} = typeof var + typeof ArrayElem{..} = decrArrayDepth $ typeof array + where + decrArrayDepth :: Type -> Type + decrArrayDepth (ArrayType _ t) = t + decrArrayDepth t = reprError InternalError $ "Non-array variable is indexed! " ++ show array ++ " :: " ++ show t + typeof StructField{..} = getStructFieldType fieldName $ typeof struct + where + getStructFieldType :: String -> Type -> Type + getStructFieldType f (StructType l) = case List.find (\(a,_) -> a == f) l of + Just (_,t) -> t + Nothing -> structFieldNotFound f + getStructFieldType f (Alias t _) = getStructFieldType f t + getStructFieldType f t = reprError InternalError $ + "Trying to get a struct field from not a struct typed expression\n" ++ "Field: " ++ f ++ "\nType: " ++ show t + structFieldNotFound f = reprError InternalError $ "Not found struct field with this name: " ++ f + typeof ConstExpr{..} = typeof constExpr + typeof FunctionCall{..} = returnType function + typeof Cast{..} = castType + typeof SizeOf{..} = NumType Signed S32 + +instance (ShowLabel t) => HasType (ActualParameter t) where + type TypeOf (ActualParameter t) = Type + typeof In{..} = typeof inParam + typeof Out{..} = typeof outParam + typeof TypeParameter{..} = typeParam + typeof FunParameter{} = VoidType + + +reprError :: forall a. ErrorClass -> String -> a +reprError = handleError "Feldspar.Compiler.Imperative.Representation" + +-- ===================== +-- == Technical types == +-- ===================== + +data Struct t +data ProcDef t +data ProcDecl t +data Empty t +data Comment t +data Assign t +data ProcedureCall t +data Spawn t +data Run t +data Sequence t +data Branch t +data SeqLoop t +data ParLoop t +data FunctionCall t +data Cast t +data SizeOf t +data ArrayElem t +data StructField t +data LeftFunCall t +data IntConst t +data FloatConst t +data BoolConst t +data ArrayConst t +data ComplexConst t + +-- ========================== +-- == Show and Eq instance == +-- ========================== + +class ( Show (Label t Module) + , Show (Label t Entity) + , Show (Label t Struct) + , Show (Label t ProcDef) + , Show (Label t ProcDecl) + , Show (Label t StructMember) + , Show (Label t Block) + , Show (Label t Program) + , Show (Label t Empty) + , Show (Label t Comment) + , Show (Label t Assign) + , Show (Label t ProcedureCall) + , Show (Label t Spawn) + , Show (Label t Run) + , Show (Label t Sequence) + , Show (Label t Branch) + , Show (Label t SeqLoop) + , Show (Label t ParLoop) + , Show (Label t ActualParameter) + , Show (Label t Declaration) + , Show (Label t Expression) + , Show (Label t FunctionCall) + , Show (Label t Cast) + , Show (Label t SizeOf) + , Show (Label t ArrayElem) + , Show (Label t StructField) + , Show (Label t Constant) + , Show (Label t IntConst) + , Show (Label t FloatConst) + , Show (Label t BoolConst) + , Show (Label t ArrayConst) + , Show (Label t ComplexConst) + , Show (Label t Variable) + ) => ShowLabel t + +instance ( Show (Label t Module) + , Show (Label t Entity) + , Show (Label t Struct) + , Show (Label t ProcDef) + , Show (Label t ProcDecl) + , Show (Label t StructMember) + , Show (Label t Block) + , Show (Label t Program) + , Show (Label t Empty) + , Show (Label t Comment) + , Show (Label t Assign) + , Show (Label t ProcedureCall) + , Show (Label t Spawn) + , Show (Label t Run) + , Show (Label t Sequence) + , Show (Label t Branch) + , Show (Label t SeqLoop) + , Show (Label t ParLoop) + , Show (Label t ActualParameter) + , Show (Label t Declaration) + , Show (Label t Expression) + , Show (Label t FunctionCall) + , Show (Label t Cast) + , Show (Label t SizeOf) + , Show (Label t ArrayElem) + , Show (Label t StructField) + , Show (Label t Constant) + , Show (Label t IntConst) + , Show (Label t FloatConst) + , Show (Label t BoolConst) + , Show (Label t ArrayConst) + , Show (Label t ComplexConst) + , Show (Label t Variable) + ) => ShowLabel t + +class ( Eq (Label t Module) + , Eq (Label t Entity) + , Eq (Label t Struct) + , Eq (Label t ProcDef) + , Eq (Label t ProcDecl) + , Eq (Label t StructMember) + , Eq (Label t Block) + , Eq (Label t Program) + , Eq (Label t Empty) + , Eq (Label t Comment) + , Eq (Label t Assign) + , Eq (Label t ProcedureCall) + , Eq (Label t Spawn) + , Eq (Label t Run) + , Eq (Label t Sequence) + , Eq (Label t Branch) + , Eq (Label t SeqLoop) + , Eq (Label t ParLoop) + , Eq (Label t ActualParameter) + , Eq (Label t Declaration) + , Eq (Label t Expression) + , Eq (Label t FunctionCall) + , Eq (Label t Cast) + , Eq (Label t SizeOf) + , Eq (Label t StructField) + , Eq (Label t ArrayElem) + , Eq (Label t Constant) + , Eq (Label t IntConst) + , Eq (Label t FloatConst) + , Eq (Label t BoolConst) + , Eq (Label t ArrayConst) + , Eq (Label t ComplexConst) + , Eq (Label t Variable) + ) => EqLabel t + +instance ( Eq (Label t Module) + , Eq (Label t Entity) + , Eq (Label t Struct) + , Eq (Label t ProcDef) + , Eq (Label t ProcDecl) + , Eq (Label t StructMember) + , Eq (Label t Block) + , Eq (Label t Program) + , Eq (Label t Empty) + , Eq (Label t Comment) + , Eq (Label t Assign) + , Eq (Label t ProcedureCall) + , Eq (Label t Spawn) + , Eq (Label t Run) + , Eq (Label t Sequence) + , Eq (Label t Branch) + , Eq (Label t SeqLoop) + , Eq (Label t ParLoop) + , Eq (Label t ActualParameter) + , Eq (Label t Declaration) + , Eq (Label t Expression) + , Eq (Label t FunctionCall) + , Eq (Label t Cast) + , Eq (Label t SizeOf) + , Eq (Label t StructField) + , Eq (Label t ArrayElem) + , Eq (Label t Constant) + , Eq (Label t IntConst) + , Eq (Label t FloatConst) + , Eq (Label t BoolConst) + , Eq (Label t ArrayConst) + , Eq (Label t ComplexConst) + , Eq (Label t Variable) + ) => EqLabel t + +-- * Set and get labels + +class Labeled c where + label :: c t -> Label t c + setLabel :: c t -> Label t c -> c t + +instance Labeled Module where + label = moduleLabel + setLabel c lab = c{ moduleLabel = lab } + +instance Labeled Entity where + label = definitionLabel + setLabel c lab = c{ definitionLabel = lab } + +instance Labeled Program where + label = programLabel + setLabel c lab = c{ programLabel = lab } + +instance Labeled Declaration where + label = declLabel + setLabel c lab = c{ declLabel = lab } + +instance Labeled Constant where + label = constLabel + setLabel c lab = c{ constLabel = lab } + +instance Labeled StructMember where + label = structMemberLabel + setLabel c lab = c{ structMemberLabel = lab } + +instance Labeled Variable where + label = varLabel + setLabel c lab = c{ varLabel = lab } + +instance Labeled Expression where + label = exprLabel + setLabel c lab = c{ exprLabel = lab } + +instance Labeled ActualParameter where + label = actParamLabel + setLabel c lab = c{ actParamLabel = lab } + +instance Labeled Block where + label = blockLabel + setLabel c lab = c{ blockLabel = lab } diff --git a/lib/Feldspar/Compiler/Imperative/TransformationInstance.hs b/lib/Feldspar/Compiler/Imperative/TransformationInstance.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Compiler/Imperative/TransformationInstance.hs @@ -0,0 +1,180 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Compiler.Imperative.TransformationInstance where + + +import Feldspar.Transformation.Framework +import Feldspar.Compiler.Imperative.Representation + +-- ========================================= +-- == Classes for the plugin architecture == +-- ========================================= + +-- class to simplify contexts +class (Transformation t, Convert (Label (From t) s) (Label (To t) s), Default (Label (To t) s)) => Conversion t s + +instance (Transformation t, Convert (Label (From t) s) (Label (To t) s), Default (Label (To t) s)) => Conversion t s + +-- ==================== +-- == Transformation == +-- ==================== + +instance (Transformable1 t [] Entity, Conversion t Module) + => DefaultTransformable t Module where + defaultTransform t s d (Module m inf) = Result (Module (result1 tr) $ convert inf) (state1 tr) (up1 tr) where + tr = transform1 t s d m + +instance (Transformable1 t [] StructMember, Transformable1 t [] Variable, Transformable t Block, Transformable t Declaration, Conversion t Entity, Conversion t Struct, Conversion t ProcDef, Conversion t ProcDecl) + => DefaultTransformable t Entity where + defaultTransform t s d (StructDef n m inf1 inf2) = + Result (StructDef n (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where + tr = transform1 t s d m + defaultTransform _ s _ (TypeDef typ n inf) = + Result (TypeDef typ n (convert inf)) s def + defaultTransform t s d (ProcDef n i o p inf1 inf2) = + Result (ProcDef n (result1 tr1) (result1 tr2) (result tr3) (convert inf1) $ convert inf2) + (state tr3) (foldl combine (up1 tr1) [up1 tr2, up tr3]) where + tr1 = transform1 t s d i + tr2 = transform1 t (state1 tr1) d o + tr3 = transform t (state1 tr2) d p + defaultTransform t s d (ProcDecl name inp outp inf1 inf2) = + Result (ProcDecl name (result1 tr1) (result1 tr2) (convert inf1) (convert inf2)) + (state1 tr2) (foldl1 combine [up1 tr1, up1 tr2]) where + tr1 = transform1 t s d inp + tr2 = transform1 t (state1 tr1) d outp + +instance (Conversion t StructMember, Default (Up t)) + => DefaultTransformable t StructMember where + defaultTransform _ s _ (StructMember n typ inf) = Result (StructMember n typ $ convert inf) s def + +instance (Transformable1 t [] Declaration, Transformable t Program, Conversion t Block) + => DefaultTransformable t Block where + defaultTransform t s d (Block l b inf) = Result (Block (result1 tr1) (result tr2) $ convert inf) (state tr2) (combine (up1 tr1) (up tr2)) where + tr1 = transform1 t s d l + tr2 = transform t (state1 tr1) d b + +instance (Transformable1 t [] Program, Transformable t Expression, Transformable1 t [] ActualParameter, Transformable t Block, Transformable t Variable, Conversion t Program, Conversion t Empty, Conversion t Comment, Conversion t Assign, Conversion t ProcedureCall, Conversion t Spawn, Conversion t Run, Conversion t Sequence, Conversion t Branch, Conversion t SeqLoop, Conversion t ParLoop, Default (Up t)) + => DefaultTransformable t Program where + defaultTransform _ s _ (Empty inf1 inf2) = Result (Empty (convert inf1) $ convert inf2) s def + defaultTransform _ s _ (Comment b c inf1 inf2) = Result (Comment b c (convert inf1) $ convert inf2) s def + defaultTransform t s d (Assign l r inf1 inf2) = Result (Assign (result tr1) (result tr2) (convert inf1) $ convert inf2) (state tr2) (combine (up tr1) (up tr2)) where + tr1 = transform t s d l + tr2 = transform t (state tr1) d r + defaultTransform t s d (ProcedureCall f par inf1 inf2) = Result (ProcedureCall f (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where + tr = transform1 t s d par + defaultTransform t s d (Sequence p inf1 inf2) = Result (Sequence (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where + tr = transform1 t s d p + defaultTransform t s d (Branch e p1 p2 inf1 inf2) = Result (Branch (result tr1) (result tr2) (result tr3) (convert inf1) $ convert inf2) (state tr3) (foldl combine (up tr1) [up tr2, up tr3]) where + tr1 = transform t s d e + tr2 = transform t (state tr1) d p1 + tr3 = transform t (state tr2) d p2 + defaultTransform t s d (SeqLoop v c p inf1 inf2) = Result (SeqLoop (result tr1) (result tr2) (result tr3) (convert inf1) $ convert inf2) (state tr3) (foldl combine (up tr1) [up tr2, up tr3]) where + tr1 = transform t s d v + tr2 = transform t (state tr1) d c + tr3 = transform t (state tr2) d p + defaultTransform t s d (ParLoop v b i p inf1 inf2) = Result (ParLoop (result tr1) (result tr2) i (result tr3) (convert inf1) $ convert inf2) (state tr3) (foldl combine (up tr1) [up tr2, up tr3]) where + tr1 = transform t s d v + tr2 = transform t (state tr1) d b + tr3 = transform t (state tr2) d p + defaultTransform t s d (BlockProgram b inf) = Result (BlockProgram (result tr) $ convert inf) (state tr) (up tr) where + tr = transform t s d b + +instance (Transformable t Expression, Conversion t ActualParameter) + => DefaultTransformable t ActualParameter where + defaultTransform t s d (In p inf) = Result (In (result tr) $ convert inf) (state tr) (up tr) where + tr = transform t s d p + defaultTransform t s d (Out p inf) = Result (Out (result tr) $ convert inf) (state tr) (up tr) where + tr = transform t s d p + defaultTransform _ s _ (TypeParameter p r inf) = Result (TypeParameter p r $ convert inf) s def + defaultTransform _ s _ (FunParameter n b inf) = Result (FunParameter n b $ convert inf) s def + +instance (Transformable t Variable, Transformable1 t Maybe Expression, Conversion t Declaration) + => DefaultTransformable t Declaration where + defaultTransform t s d (Declaration v i inf) = Result (Declaration (result tr1) (result1 tr2) $ convert inf) (state1 tr2) (combine (up tr1) (up1 tr2)) where + tr1 = transform t s d v + tr2 = transform1 t (state tr1) d i + +instance (Transformable t Expression, Transformable t Variable, Transformable t Constant, Transformable1 t [] Expression, Conversion t Expression, Conversion t FunctionCall, Conversion t ArrayElem, Conversion t StructField, Conversion t SizeOf, Conversion t Cast, Default (Up t)) + => DefaultTransformable t Expression where + defaultTransform t s d (VarExpr v inf) = Result (VarExpr (result tr) $ convert inf) (state tr) (up tr) where + tr = transform t s d v + defaultTransform t s d (ArrayElem a i inf1 inf2) = Result (ArrayElem (result tr1) (result tr2) (convert inf1) (convert inf2)) (state tr2) (combine (up tr1) (up tr2)) where + tr1 = transform t s d a + tr2 = transform t (state tr1) d i + defaultTransform t s d (StructField l n inf1 inf2) = Result (StructField (result tr) n (convert inf1) $ convert inf2) (state tr) (up tr) where + tr = transform t s d l + defaultTransform t s d (ConstExpr c inf) = Result (ConstExpr (result tr) $ convert inf) (state tr) (up tr) where + tr = transform t s d c + defaultTransform t s d (FunctionCall f par inf1 inf2) = + Result (FunctionCall f (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where + tr = transform1 t s d par + defaultTransform t s d (Cast typ ex inf1 inf2) = Result (Cast typ (result tr) (convert inf1) $ convert inf2) (state tr) (up tr) where + tr = transform t s d ex + defaultTransform t s d (SizeOf par inf1 inf2) = case par of + Left typ -> Result (SizeOf (Left typ) (convert inf1) $ convert inf2) s def + Right ex -> Result (SizeOf (Right $ result tr) (convert inf1) $ convert inf2) (state tr) (up tr) where + tr = transform t s d ex + +instance (Transformable t Constant, Transformable1 t [] Constant, Conversion t Constant, Conversion t IntConst, Conversion t FloatConst, Conversion t BoolConst, Conversion t ArrayConst, Conversion t ComplexConst, Default (Up t)) + => DefaultTransformable t Constant where + defaultTransform _ s _ (IntConst c typ inf1 inf2) = Result (IntConst c typ (convert inf1) $ convert inf2) s def + defaultTransform _ s _ (FloatConst c inf1 inf2) = Result (FloatConst c (convert inf1) $ convert inf2) s def + defaultTransform _ s _ (BoolConst c inf1 inf2) = Result (BoolConst c (convert inf1) $ convert inf2) s def + -- defaultTransform t s d (ArrayConst c inf1 inf2) = Result (ArrayConst (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where + -- tr = transform1 t s d c + defaultTransform t s d (ComplexConst re im inf1 inf2) = Result (ComplexConst (result tr1) (result tr2) (convert inf1) $ convert inf2) (state tr2) (combine (up tr1) $ up tr2) where + tr1 = transform t s d re + tr2 = transform t (state tr1) d im + +instance (Conversion t Variable, Default (Up t)) + => DefaultTransformable t Variable where + defaultTransform _ s _ (Variable name typ role inf) = Result (Variable name typ role $ convert inf) s def + + +instance (Transformable t a, Default (Up t), Combine (Up t), Transformation t) + => DefaultTransformable1 t [] a where + defaultTransform1 _ s _ [] = Result1 [] s def + defaultTransform1 t s d [x] = Result1 [result tr] (state tr) (up tr) where + tr = transform t s d x + defaultTransform1 t s d (x:xs) = Result1 (result tr1 : result1 tr2) (state1 tr2) (combine (up tr1) (up1 tr2)) where + tr1 = transform t s d x + tr2 = transform1 t (state tr1) d xs + +instance (Transformable t a, Default (Up t), Transformation t) + => DefaultTransformable1 t Maybe a where + defaultTransform1 _ s _ Nothing = Result1 Nothing s def + defaultTransform1 t s d (Just x) = Result1 (Just $ result tr) (state tr) (up tr) where + tr = transform t s d x diff --git a/lib/Feldspar/NameExtractor.hs b/lib/Feldspar/NameExtractor.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/NameExtractor.hs @@ -0,0 +1,159 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +module Feldspar.NameExtractor where + +import System.IO +import System.IO.Unsafe +import Language.Haskell.Exts +import Feldspar.Compiler.Error +import Feldspar.Compiler.Backend.C.Library + +data OriginalFunctionSignature = OriginalFunctionSignature { + originalFunctionName :: String, + originalParameterNames :: [Maybe String] +} deriving (Show, Eq) + +nameExtractorError :: ErrorClass -> String -> a +nameExtractorError = handleError "NameExtractor" + +neutralName :: String +neutralName = "\\"++ r 4 ++"/\\"++ r 7 ++"\n ) ( ')"++ r 6 ++"\n( / )"++ r 7 ++"\n \\(__)|" + where r n = replicate n ' ' + +ignore :: OriginalFunctionSignature +ignore = OriginalFunctionSignature neutralName [] + +warning :: String -> a -> a +warning msg retval = unsafePerformIO $ do + withColor Yellow $ putStrLn $ "Warning: " ++ msg + return retval + +-- Module SrcLoc ModuleName [OptionPragma] (Maybe WarningText) (Maybe [ExportSpec]) [ImportDecl] [Decl] +stripModule :: Module -> [Decl] +stripModule x = case x of + Module _ _ _ _ _ _ g -> g + +stripFunBind :: Decl -> OriginalFunctionSignature +stripFunBind x = case x of + FunBind [Match _ b c _ _ _] -> + OriginalFunctionSignature (stripName b) (map stripPattern c) -- going for name and parameter list + -- "Match SrcLoc Name [Pat] (Maybe Type) Rhs Binds" + FunBind l@(Match _ b _ _ _ _ : _) | length l > 1 -> warning + ("Ignoring function " ++ stripName b ++ + ": multi-pattern function definitions are not compilable as Feldspar functions.") ignore + PatBind _ b _ _ _ -> case stripPattern b of + Just functionName -> OriginalFunctionSignature functionName [] -- parameterless declarations (?) + Nothing -> nameExtractorError InternalError ("Unsupported pattern binding: " ++ show b) + TypeSig{} -> ignore --head b -- we don't need the type signature (yet) + DataDecl{} -> ignore + InstDecl{} -> ignore + -- TypeDecl SrcLoc Name [TyVarBind] Type + TypeDecl{} -> ignore + unknown -> nameExtractorError InternalError ("Unexpected language element [SFB/1]: " ++ show unknown + ++ "\nPlease file a feature request with an example attached.") + +stripPattern :: Pat -> Maybe String +stripPattern (PVar x) = Just $ stripName x +stripPattern PWildCard = Nothing +stripPattern (PAsPat x _) = Just $ stripName x +stripPattern (PParen pattern) = stripPattern pattern +stripPattern _ = Nothing + +stripName :: Name -> String +stripName (Ident a) = a +stripName (Symbol a) = a + +stripModule2 :: Module -> ModuleName +stripModule2 (Module _ b _ _ _ _ _) = b + +stripModuleName :: ModuleName -> String +stripModuleName (ModuleName x) = x + +getModuleName :: FilePath -> String -> String -- filename, filecontents -> modulename +getModuleName fileName = stripModuleName . stripModule2 . fromParseResult . customizedParse fileName + +usedExtensions :: [Extension] +usedExtensions = glasgowExts ++ [ExplicitForAll] + +-- Ultimate debug function +getParseOutput :: FilePath -> IO (ParseResult Module) +getParseOutput = parseFileWithMode (defaultParseMode { extensions = usedExtensions }) + +customizedParse :: FilePath -> FilePath -> ParseResult Module +customizedParse fileName = parseFileContentsWithMode + (defaultParseMode + { extensions = usedExtensions + , parseFilename = fileName + }) + +getFullDeclarationListWithParameterList :: FilePath -> String -> [OriginalFunctionSignature] +getFullDeclarationListWithParameterList fileName fileContents = + map stripFunBind (stripModule $ fromParseResult $ customizedParse fileName fileContents ) + +functionNameNeeded :: String -> Bool +functionNameNeeded functionName = functionName /= neutralName + +stripUnnecessary :: [String] -> [String] +stripUnnecessary = filter functionNameNeeded + +printDeclarationList :: FilePath -> IO (String -> [String]) +printDeclarationList fileName = do + handle <- openFile fileName ReadMode + fileContents <- hGetContents handle + return $ getDeclarationList fileContents + +printDeclarationListWithParameterList :: FilePath -> IO () +printDeclarationListWithParameterList fileName = do + handle <- openFile fileName ReadMode + fileContents <- hGetContents handle + print $ filter (functionNameNeeded . originalFunctionName) (getFullDeclarationListWithParameterList fileName fileContents) + +printParameterListOfFunction :: FilePath -> String -> IO [Maybe String] +printParameterListOfFunction = getParameterList + +-- The interface +getDeclarationList :: FilePath -> String -> [String] -- filename, filecontents -> Stringlist +getDeclarationList fileName = stripUnnecessary . map originalFunctionName . getFullDeclarationListWithParameterList fileName + +getExtendedDeclarationList :: FilePath -> String -> [OriginalFunctionSignature] -- filename, filecontents -> ExtDeclList +getExtendedDeclarationList fileName fileContents = + filter (functionNameNeeded . originalFunctionName) + (getFullDeclarationListWithParameterList fileName fileContents) + +getParameterListOld :: FilePath -> String -> String -> [Maybe String] +getParameterListOld fileName fileContents funName = originalParameterNames $ head $ + filter ((==funName) . originalFunctionName) + (getExtendedDeclarationList fileName fileContents) + +getParameterList :: FilePath -> String -> IO [Maybe String] +getParameterList fileName funName = do + handle <- openFile fileName ReadMode + fileContents <- hGetContents handle + return $ originalParameterNames $ head $ + filter ((==funName) . originalFunctionName) (getExtendedDeclarationList fileName fileContents) diff --git a/lib/Feldspar/Transformation.hs b/lib/Feldspar/Transformation.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Transformation.hs @@ -0,0 +1,47 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE TypeFamilies, FlexibleContexts, Rank2Types #-} + +module Feldspar.Transformation + ( module Feldspar.Transformation + , module X + ) where + +import Feldspar.Transformation.Framework as X +import Feldspar.Compiler.Imperative.TransformationInstance as X +import Feldspar.Compiler.Imperative.Representation as X + +-- ================================================================================================ +-- == Plugin class +-- ================================================================================================ + + +class (Transformable t Module) => Plugin t where + type ExternalInfo t + executePlugin :: t -> ExternalInfo t -> Module (From t) -> Module (To t) diff --git a/lib/Feldspar/Transformation/Framework.hs b/lib/Feldspar/Transformation/Framework.hs new file mode 100644 --- /dev/null +++ b/lib/Feldspar/Transformation/Framework.hs @@ -0,0 +1,151 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Feldspar.Transformation.Framework where + +import Feldspar.Compiler.Error + +transformationError :: String -> a +transformationError = handleError "PluginArch/TransformationFramework" InternalError + +-- =========== +-- == Utils == +-- =========== + +class Default t where + def :: t + def = transformationError "Default value requested." + +class Combine t where + combine :: t -> t -> t + combine = transformationError "Default combination function used." + +class Convert a b where + convert :: a -> b + +instance Default () where + def = () + +instance Default [a] where + def = [] + +instance Default Int where + def = 0 + +instance (Default a, Default b) => Default (a,b) where + def = (def, def) + +instance (Default a, Default b, Default c) => Default (a,b,c) where + def = (def, def, def) + +instance Combine () where + combine _ _ = () + +instance Combine String where + combine s1 s2 = s1 ++ s2 + +instance Combine Int where + combine i1 i2 = i1 + i2 + +instance (Combine a, Combine b) + => Combine (a,b) where + combine (x,y) (v,w) = (combine x v, combine y w) + +instance Default b => Convert a b where + convert _ = def + +-- ============================= +-- == TransformationFramework == +-- ============================= + +class (Default (Up t), Combine (Up t)) + => Transformation t where + type From t + type To t + + type State t + type Down t + type Up t + +data Result t s + = Result + { result :: s (To t) + , state :: State t + , up :: Up t + } + +deriving instance (Transformation t, Show (s (To t)), Show (State t), Show (Up t)) => Show (Result t s) + +data Result1 t s a + = Result1 + { result1 :: s (a (To t)) + , state1 :: State t + , up1 :: Up t + } + +deriving instance (Transformation t, Show (s (b (To t))), Show (State t), Show (Up t)) => Show (Result1 t s b) + +-- The following classes used to have `Transformation t` as super-class, but +-- this resulted in looping dictionaries (at run time) after switching to +-- GHC-7.4. This may or may not be related to the following (unconfirmed) bug: +-- +-- http://hackage.haskell.org/trac/ghc/ticket/5913 +-- +-- The constraint `Transformation t` has currently been moved to the relevant +-- instances. + +class Transformable t s where + transform :: t -> State t -> Down t -> s (From t) -> Result t s + +class Transformable1 t s a where + transform1 :: t -> State t -> Down t -> s (a (From t)) -> Result1 t s a + +class DefaultTransformable t s where + defaultTransform :: t -> State t -> Down t -> s (From t) -> Result t s + +class DefaultTransformable1 t s a where + defaultTransform1 :: t -> State t -> Down t -> s (a (From t)) -> Result1 t s a + +instance (DefaultTransformable t s) + => Transformable t s where + transform = defaultTransform + +instance (DefaultTransformable1 t s a) + => Transformable1 t s a where + transform1 = defaultTransform1 + diff --git a/src/Feldspar/Compiler/Frontend/CommandLine/API.hs b/src/Feldspar/Compiler/Frontend/CommandLine/API.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Compiler/Frontend/CommandLine/API.hs @@ -0,0 +1,155 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE CPP #-} +module Feldspar.Compiler.Frontend.CommandLine.API where + +import qualified Feldspar.NameExtractor as NameExtractor +import Feldspar.Compiler.Backend.C.Options +import Feldspar.Compiler.Compiler +import Feldspar.Compiler.Imperative.FromCore +import Feldspar.Compiler.Frontend.CommandLine.API.Library +import Feldspar.Compiler.Backend.C.Library +import Language.Haskell.Interpreter +import Language.Haskell.Interpreter.Unsafe +import qualified Data.Typeable as T +import Control.Monad + +-- ====================================== System imports ================================== +import System.Directory +import System.FilePath +import System.IO +import System.Exit +import System.Environment +import System.Console.GetOpt + +import Control.Exception (catch, IOException) + +data CompilationResult + = CompilationSuccess + | CompilationFailure + deriving (Eq, Show, T.Typeable) + +#ifdef RELEASE +releaseMode = True +#else +releaseMode = False +#endif + + -- A general interpreter body for interpreting an expression +generalInterpreterBody :: forall a . (T.Typeable (IO a)) + => String -- the expression to interpret + -> Interpreter (IO a) +generalInterpreterBody expression = interpret expression (as::IO a) + +-- A high-level interface for calling the interpreter +highLevelInterpreter :: T.Typeable (IO a) + => String -- the module name (for example My.Module) + -> String -- the input file name (for example "My/Module.hs") + -> [String] -- globalImportList + -> Bool -- need to import global modules qualified? + -> Interpreter (IO a) -- ^ an interpreter body + -> IO CompilationResult +highLevelInterpreter moduleName inputFileName importList needQualify interpreterBody = do + actionToExecute <- runInterpreter $ do + set [ languageExtensions := [GADTs, ScopedTypeVariables, TypeSynonymInstances, StandaloneDeriving, + DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + FunctionalDependencies, ExistentialQuantification, Rank2Types, TypeOperators, + EmptyDataDecls, GeneralizedNewtypeDeriving, TypeFamilies, ViewPatterns, + UnknownExtension "ImplicitPrelude" ] + ] + unsafeSetGhcOption "-fcontext-stack=100" + -- in relesae mode, globalImportList modules are package modules and shouldn't be loaded, only imported + -- in normal mode, we need to load them before importing them + loadModules $ inputFileName : if not releaseMode then importList else [] + setTopLevelModules [moduleName] + -- Import modules qualified to prevent name collisions with user defined entities + if needQualify + then setImportsQ $ zip importList $ map Just importList + else setImports importList + interpreterBody + case actionToExecute of + Left err -> do + printInterpreterError err + return CompilationFailure + Right action -> do + action + return CompilationSuccess + -- either printInterpreterError id actionToExecute + +printInterpreterError :: InterpreterError -> IO () +printInterpreterError (WontCompile []) = return () +printInterpreterError (WontCompile (x:xs)) = do + printGhcError x + printInterpreterError (WontCompile xs) + where + printGhcError (GhcError {errMsg=s}) = hPutStrLn stderr s +printInterpreterError e = hPutStrLn stderr $ "Code generation failed: " ++ show e + +handleOptions :: [OptDescr (a -> IO a)] -> a -> String -> IO (a, String) +handleOptions descriptors startOptions helpHeader = do + args <- getArgs + + when (null args) (do + putStrLn $ usageInfo helpHeader descriptors + exitSuccess) + + -- Parse options, getting a list of option actions + let (actions, nonOptions, errors) = getOpt Permute descriptors args + + when (length errors > 0) (do + putStrLn $ concat errors + putStrLn $ usageInfo helpHeader descriptors + exitWith (ExitFailure 1)) + + -- Here we thread startOptions through all supplied option actions + opts <- foldl (>>=) (return startOptions) actions + + when (length nonOptions /= 1) (do + putStrLn "ERROR: Exactly one input file expected." + exitWith (ExitFailure 1)) + + let inputFileName = replace (head nonOptions) "\\" "/" -- change it for multi-file operation + + return (opts, inputFileName) + +removeFileIfPossible :: String -> IO () +removeFileIfPossible filename = removeFile filename `Control.Exception.catch` (\(e :: IOException) -> return ()) + +prepareInputFile :: String -> IO () +prepareInputFile inputFileName = do + removeFileIfPossible $ replaceExtension inputFileName ".hi" + removeFileIfPossible $ replaceExtension inputFileName ".o" + +standaloneCompile :: (Compilable t internal) => + t -> FilePath -> FilePath -> NameExtractor.OriginalFunctionSignature -> Options -> IO () +standaloneCompile prg inputFileName outputFileName originalFunctionSignature opts = do + appendFile (makeCFileName outputFileName) $ sourceCode $ sctccrSource compilationResult + appendFile (makeHFileName outputFileName) $ sourceCode $ sctccrHeader compilationResult + where + compilationResult = compileToCCore Standalone prg (Just outputFileName) IncludesNeeded originalFunctionSignature opts diff --git a/src/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs b/src/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs @@ -0,0 +1,36 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +module Feldspar.Compiler.Frontend.CommandLine.API.Constants where + +globalImportList = ["Feldspar.Compiler.Compiler"] + +warningPrefix = "[WARNING]: " +errorPrefix = "[ERROR ]: " + + diff --git a/src/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs b/src/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs @@ -0,0 +1,72 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +module Feldspar.Compiler.Frontend.CommandLine.API.Library where + + +import Data.Char +import Language.Haskell.Interpreter +import System.Console.ANSI +import Feldspar.Compiler.Backend.C.Library + +lowerFirst :: String -> String +lowerFirst (first:rest) = toLower first : rest +lowerFirst s = s + +upperFirst :: String -> String +upperFirst (first:rest) = toUpper first : rest +upperFirst s = s + +formatStringListCore :: [String] -> String +formatStringListCore [] = "" +formatStringListCore [x] = x +formatStringListCore (x:xs) = x ++ " | " ++ formatStringListCore xs + +formatStringList :: [String] -> String +formatStringList list | not (null list) = "(" ++ formatStringListCore list ++ ")" +formatStringList _ = error "This list should not be empty." + +rpad :: Int -> String -> String +rpad target = rpadWith target ' ' + +rpadWith :: Int -> Char -> String -> String +rpadWith target padchar s + | length s >= target = s + | otherwise = rpadWith target padchar (s ++ [padchar]) + +iPutStrLn :: String -> Interpreter () +iPutStrLn = liftIO . putStrLn + +iPutStr :: String -> Interpreter () +iPutStr = liftIO . putStr + +fancyWrite :: String -> IO () +fancyWrite s = do + withColor Blue $ putStr "=== [ " + withColor Cyan $ putStr $ rpad 70 s + withColor Blue $ putStrLn " ] ===" diff --git a/src/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs b/src/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs @@ -0,0 +1,135 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +module Feldspar.Compiler.Frontend.CommandLine.API.Options where + +import qualified Feldspar.Compiler.Backend.C.Options as CompilerCoreOptions +import qualified Feldspar.Compiler.Compiler as CompilerCore +import qualified Feldspar.Compiler.Frontend.CommandLine.API.Library as StandaloneLib +import Feldspar.Compiler.Frontend.CommandLine.API.Constants +import Feldspar.Compiler.Backend.C.Platforms + +import Data.List +import Data.Char +import Data.Maybe (fromMaybe) + +import System.Console.GetOpt +import System.Exit +import System.Environment +import System.IO +import System.Process +import System.Info +import System.Directory + +availablePlatformsStrRep = StandaloneLib.formatStringList $ + map (StandaloneLib.upperFirst . CompilerCoreOptions.name) availablePlatforms + +data StandaloneMode = SingleFunction String | MultiFunction + +data Options = Options { optStandaloneMode :: StandaloneMode + , optOutputFileName :: Maybe String + , optCompilerMode :: CompilerCoreOptions.Options + } + +-- | Default options +startOptions :: Options +startOptions = Options { optStandaloneMode = MultiFunction + , optOutputFileName = Nothing + , optCompilerMode = CompilerCore.defaultOptions + } + +helpHeader = "Standalone Feldspar Compiler\nUsage: feldspar [options] inputfile\n" ++ + "Notes: \n" ++ + " * When no output file name is specified, the input file's name with .c extension is used\n" ++ + " * The inputfile parameter is always needed, even in single-function mode\n" ++ + "\nAvailable options: \n" + +-- | Option descriptions for getOpt +optionDescriptors :: [ OptDescr (Options -> IO Options) ] +optionDescriptors = + [ Option "f" ["singlefunction"] + (ReqArg + (\arg opt -> return opt { optStandaloneMode = SingleFunction arg }) + "FUNCTION") + "Enables single-function compilation" + , Option "o" ["output"] + (ReqArg + (\arg opt -> return opt { optOutputFileName = Just arg }) + "outputfile") + "Overrides the file names for the generated output code" + + , Option "p" ["platform"] + (ReqArg + (\arg opt -> return opt { optCompilerMode = (optCompilerMode opt) + { CompilerCoreOptions.platform = decodePlatform arg } }) + "") + ("Overrides the target platform " ++ availablePlatformsStrRep) + , Option "u" ["unroll"] + (ReqArg + (\arg opt -> return opt { + optCompilerMode = (optCompilerMode opt) { + CompilerCoreOptions.unroll = CompilerCoreOptions.Unroll (parseInt arg "Invalid unroll count") + } + }) + "") + "Enables loop unrolling" + , Option "D" ["debuglevel"] + (ReqArg + (\arg opt -> return opt { optCompilerMode = (optCompilerMode opt) + { CompilerCoreOptions.debug = decodeDebug arg } }) + "") + "Specifies debug level (currently the only possible option is NoPrimitiveInstructionHandling)" + , Option "h" ["help"] + (NoArg + (\_ -> do + --prg <- getProgName + hPutStrLn stderr (usageInfo helpHeader optionDescriptors) + exitSuccess)) + "Show this help message" + ] + +-- ============================================================================== +-- == Option Decoders +-- ============================================================================== + +findPlatformByName :: String -> Maybe CompilerCoreOptions.Platform +findPlatformByName platformName = -- Finds a platform by name using case-insensitive comparison + find (\platform -> map toLower platformName == map toLower (CompilerCoreOptions.name platform)) + availablePlatforms + +decodePlatform :: String -> CompilerCoreOptions.Platform +decodePlatform s = fromMaybe (error $ "Invalid platform specified. Valid platforms are: " ++ availablePlatformsStrRep) + $ findPlatformByName s + +decodeDebug "NoPrimitiveInstructionHandling" = CompilerCoreOptions.NoPrimitiveInstructionHandling +decodeDebug _ = error "Invalid debug level specified" + +parseInt :: String -> String -> Int +parseInt arg message = case reads arg of + [(x, "")] -> x + _ -> error message diff --git a/src/Feldspar/Compiler/Frontend/CommandLine/Main.hs b/src/Feldspar/Compiler/Frontend/CommandLine/Main.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Compiler/Frontend/CommandLine/Main.hs @@ -0,0 +1,219 @@ +-- +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- + +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where +-- ====================================== Feldspar imports ================================== +import Feldspar.NameExtractor +import Feldspar.Compiler.Compiler +import qualified Feldspar.Compiler.Compiler as CompilerCore +import Feldspar.Compiler.Backend.C.Options +import qualified Feldspar.Compiler.Backend.C.Options as CoreOptions +import Feldspar.Compiler.Frontend.CommandLine.API.Options as StandaloneOptions +import Feldspar.Compiler.Frontend.CommandLine.API.Constants +import Feldspar.Compiler.Frontend.CommandLine.API.Library as StandaloneLib +import Feldspar.Compiler.Backend.C.Library +import Feldspar.Compiler.Frontend.CommandLine.API +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Backend.C.CodeGeneration +import Feldspar.Compiler.Error +import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint +-- ====================================== System imports ================================== +import System.IO +import System.Exit +import System.Info +import System.Process +import System.IO.Error +import System.FilePath +import System.Directory +import System.Environment +import System.Console.GetOpt +-- ====================================== Control imports ================================== +import Control.Monad +import Control.Exception +import Control.Monad.Error +import Control.Monad.CatchIO +-- ====================================== Other imports ================================== +import Data.List +import Data.Maybe (fromMaybe) +import Debug.Trace +import Language.Haskell.Interpreter + + +data CompilationError = + InterpreterError InterpreterError + | InternalErrorCall String + +compileFunction :: String -> String -> CoreOptions.Options -> OriginalFunctionSignature + -> Interpreter (String, Either SplitModuleDescriptor CompilationError) +compileFunction inFileName outFileName coreOptions originalFunctionSignature = do + let functionName = originalFunctionName originalFunctionSignature + (SomeCompilable prg) <- interpret ("SomeCompilable " ++ functionName) (as::SomeCompilable) + let splitModuleDescriptor = executePluginChain Standalone prg originalFunctionSignature coreOptions + -- XXX force evaluation in order to be able to catch the exceptions + -- liftIO $ evaluate $ compToC coreOptions compilationUnit -- XXX somehow not enough(?!) -- counter-example: structexamples + liftIO $ do + tempdir <- Control.Exception.catch getTemporaryDirectory (\(_ :: IOException) -> return ".") + (tempfile, temph) <- openTempFile tempdir "feldspar-temp.txt" + let core = compileToCCore Standalone prg (Just outFileName) IncludesNeeded originalFunctionSignature coreOptions + Control.Exception.finally (do hPutStrLn temph $ sourceCode $ sctccrSource core + hPutStrLn temph $ sourceCode $ sctccrHeader core) + (do hClose temph + removeFileIfPossible tempfile) + return (functionName, Left splitModuleDescriptor) + +compileAllFunctions :: String -> String -> CoreOptions.Options -> [OriginalFunctionSignature] + -> Interpreter [(String, Either SplitModuleDescriptor CompilationError)] +compileAllFunctions inFileName outFileName options [] = return [] +compileAllFunctions inFileName outFileName options (x:xs) = do + let functionName = originalFunctionName x + resultCurrent <- catchError (compileFunction inFileName outFileName options x) + (\(e::InterpreterError) -> return (functionName, Right $ InterpreterError e)) + `Control.Monad.CatchIO.catch` + (\msg -> return (functionName, + Right $ InternalErrorCall $ errorPrefix ++ show (msg::Control.Exception.ErrorCall))) + resultRest <- compileAllFunctions inFileName outFileName options xs + return $ resultCurrent : resultRest + +-- | Interpreter body for single-function compilation +singleFunctionCompilationBody :: String -> String -> CoreOptions.Options -> OriginalFunctionSignature + -> Interpreter (IO ()) +singleFunctionCompilationBody inFileName outFileName coreOptions originalFunctionSignature = do + liftIO $ fancyWrite $ "Compiling function " ++ originalFunctionName originalFunctionSignature ++ "..." + SomeCompilable prg <- + interpret ("SomeCompilable " ++ originalFunctionName originalFunctionSignature) (as::SomeCompilable) + liftIO $ standaloneCompile prg inFileName outFileName originalFunctionSignature coreOptions + return $ return () + +mergeModules :: [Module ()] -> Module () +mergeModules [] = handleError "Standalone" InvariantViolation "Called mergeModules with an empty list" +mergeModules [x] = x +mergeModules l@(x:xs) = Module { + entities = nub $ entities x ++ entities (mergeModules xs), -- nub is in fact a "global plugin" here + moduleLabel = () +} + +padFunctionName :: String -> String +padFunctionName n = StandaloneLib.rpadWith 50 '.' $ "Function " ++ n + +writeErrors :: (String, Either a CompilationError) -> IO () +writeErrors (functionName, Left x) = return () +writeErrors (functionName, Right err) = case err of + InterpreterError ie -> do + withColor Red $ putStrLn $ "Error in function " ++ functionName ++ ":" + printInterpreterError ie + InternalErrorCall ec -> do + withColor Red $ putStrLn $ "Error in function " ++ functionName ++ ":" + withColor Red $ putStrLn ec + +writeSummary :: (String, Either a CompilationError) -> IO () +writeSummary (functionName, Left x) = do + withColor Cyan $ putStr $ padFunctionName functionName + withColor Green $ putStrLn "[OK]" +writeSummary (functionName, Right msg) = do + withColor Cyan $ putStr $ padFunctionName functionName + withColor Red $ putStrLn "[FAILED]" + +filterLefts :: [(String, Either a b)] -> [a] +filterLefts [] = [] +filterLefts [(_,Left x)] = [x] +filterLefts [(_,Right _)] = [] +filterLefts ((_,Left x):xs) = x : filterLefts xs +filterLefts ((_,Right _):xs) = filterLefts xs + +-- | Interpreter body for multi-function compilation +multiFunctionCompilationBody :: String -> String -> CoreOptions.Options -> [OriginalFunctionSignature] -> Interpreter (IO ()) +multiFunctionCompilationBody inFileName outFileName coreOptions declarationList = do + let (hIncludes, hLineNum) = genIncludeLines coreOptions Nothing + let (cIncludes, cLineNum) = genIncludeLines coreOptions (Just outFileName) + liftIO $ appendFile (makeHFileName outFileName) hIncludes + liftIO $ appendFile (makeCFileName outFileName) cIncludes + modules <- compileAllFunctions inFileName outFileName coreOptions declarationList + liftIO $ do + mapM_ writeErrors modules + withColor Blue $ putStrLn "\n================= [ Summary of compilation results ] =================\n" + mapM_ writeSummary modules + let mergedCModules = mergeModules $ map smdSource $ filterLefts modules + let mergedHModules = mergeModules $ map smdHeader $ filterLefts modules + let cCompToCResult = compToCWithInfos ((coreOptions, Declaration_pl), cLineNum) mergedCModules + let hCompToCResult = compToCWithInfos ((coreOptions, Declaration_pl), hLineNum) mergedHModules + appendFile (makeCFileName outFileName) (fst $ snd cCompToCResult) `Control.Exception.catch` errorHandler + appendFile (makeHFileName outFileName) (fst $ snd hCompToCResult) `Control.Exception.catch` errorHandler + writeFile (makeDebugCFileName outFileName) (show $ fst cCompToCResult) `Control.Exception.catch` errorHandler + writeFile (makeDebugHFileName outFileName) (show $ fst hCompToCResult) `Control.Exception.catch` errorHandler + return $ return () + where + errorHandler msg = withColor Red $ putStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall) + +-- | Calculates the output file name. +convertOutputFileName :: String -> Maybe String -> String +convertOutputFileName inputFileName = fromMaybe (takeFileName $ dropExtension inputFileName) + +makeBackup :: String -> IO () +makeBackup filename = renameFile filename (filename ++ ".bak") `Control.Exception.catch` (\(_ :: IOException) -> return ()) + +main = do + (opts, inputFileName) <- handleOptions optionDescriptors startOptions helpHeader + let outputFileName = convertOutputFileName inputFileName (optOutputFileName opts) + + prepareInputFile inputFileName + makeBackup $ makeHFileName outputFileName + makeBackup $ makeCFileName outputFileName + makeBackup $ makeDebugHFileName outputFileName + makeBackup $ makeDebugCFileName outputFileName + + fileDescriptor <- openFile inputFileName ReadMode + fileContents <- hGetContents fileDescriptor + + let declarationList = getExtendedDeclarationList inputFileName fileContents + let moduleName = getModuleName inputFileName fileContents + fancyWrite $ "Compilation target: module " ++ moduleName + fancyWrite $ "Output file: " ++ outputFileName + + let highLevelInterpreterWithModuleInfo = + highLevelInterpreter moduleName inputFileName globalImportList False + + -- C code generation + case optStandaloneMode opts of + MultiFunction + | null declarationList -> putStrLn "No functions to compile." + | otherwise -> do + fancyWrite $ "Number of functions to compile: " ++ show (length declarationList) + highLevelInterpreterWithModuleInfo + (multiFunctionCompilationBody inputFileName outputFileName (optCompilerMode opts) declarationList) + return () + SingleFunction funName -> do + let originalFunctionSignatureNeeded = + case filter ((==funName).originalFunctionName) declarationList of + [a] -> a + [] -> error $ "Function " ++ funName ++ " not found" + _ -> error "Unexpected error SC/01" + highLevelInterpreterWithModuleInfo + (singleFunctionCompilationBody inputFileName outputFileName (optCompilerMode opts) originalFunctionSignatureNeeded) + return ()