diff --git a/Feldspar/C/feldspar_array.c b/Feldspar/C/feldspar_array.c new file mode 100644 --- /dev/null +++ b/Feldspar/C/feldspar_array.c @@ -0,0 +1,72 @@ +#include "feldspar_array.h" +#include + +/* Deep array copy */ +void copyArray(struct array *to, struct array from) +{ + to->length = from.length; + to->elemSize = from.elemSize; + if( from.elemSize == (-1) ) + { + unsigned i; + for( i = 0; i < from.length; ++i ) + copyArray( &at(struct array, *to, i), at(struct array, from, i) ); + } + else + { + memcpy( to->buffer, from.buffer, from.length * from.elemSize ); + } +} + +/* Deep array copy to a given position */ +void copyArrayPos(struct array *to, unsigned pos, struct array from) +{ + to->length = pos + from.length; + to->elemSize = from.elemSize; + if( from.elemSize == (-1) ) + { + unsigned i; + for( i = 0; i < from.length; ++i ) + copyArray( &at(struct array, *to, i + pos), at(struct array, from, i) ); + } + else + { + memcpy( (char*)(to->buffer) + pos * from.elemSize, from.buffer, from.length * from.elemSize ); + } +} + +/* Deep array copy with a given length */ +void copyArrayLen(struct array *to, struct array from, unsigned len) +{ + to->length = len; + to->elemSize = from.elemSize; + if( from.elemSize == (-1) ) + { + unsigned i; + for( i = 0; i < len; ++i ) + copyArray( &at(struct array, *to, i), at(struct array, from, i) ); + } + else + { + memcpy( to->buffer, from.buffer, len * from.elemSize ); + } +} + +/* Array length */ +unsigned length(struct array arr) +{ + return arr.length; +} + +/* (Re)set array length */ +void setLength(struct array *arr, unsigned len) +{ + arr->length = len; +} + +/* Reset array length by increasing it */ +void increaseLength(struct array *arr, unsigned len) +{ + arr->length += len; +} + diff --git a/Feldspar/C/feldspar_array.h b/Feldspar/C/feldspar_array.h new file mode 100644 --- /dev/null +++ b/Feldspar/C/feldspar_array.h @@ -0,0 +1,33 @@ +#ifndef FELDSPAR_ARRAY_H +#define FELDSPAR_ARRAY_H + +struct array +{ + void* buffer; /* pointer to the buffer of elements */ + unsigned int length; /* number of elements in the array */ + int elemSize; /* size of elements in bytes; (-1) for nested arrays */ +}; + +/* Deep array copy */ +void copyArray(struct array *to, struct array from); + +/* Deep array copy to a given position */ +void copyArrayPos(struct array *to, unsigned pos, struct array from); + +/* Deep array copy with a given length */ +void copyArrayLen(struct array *to, struct array from, unsigned len); + +/* Array length */ +unsigned length(struct array arr); + +/* (Re)set array length */ +void setLength(struct array *arr, unsigned len); + +/* Reset array length by increasing it */ +void increaseLength(struct array *arr, unsigned len); + +/* Indexing into an array: */ +/* Result: element of type 'type' */ +#define at(type,arr,idx) (((type*)((arr).buffer))[idx]) + +#endif diff --git a/Feldspar/C/feldspar_c99.c b/Feldspar/C/feldspar_c99.c --- a/Feldspar/C/feldspar_c99.c +++ b/Feldspar/C/feldspar_c99.c @@ -1,1008 +1,1865 @@ -// -// Copyright (c) 2009-2010, 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 - -#if defined(WIN32) - #include -#else - #include - #include -#endif /* WIN32 */ - - - -/*--------------------------------------------------------------------------* - * pow(), abs(), signum() * - *--------------------------------------------------------------------------*/ - -int8_t pow_fun_int8( int8_t a, int8_t b ) -{ - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); - exit(1); - } - int8_t r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -int16_t pow_fun_int16( int16_t a, int16_t b ) -{ - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); - exit(1); - } - int16_t r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -int32_t pow_fun_int32( int32_t a, int32_t b ) -{ - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %d `pow` %d", a, b); - exit(1); - } - int32_t r = 1; - int i; - for(i = 0; i < b; ++i) - r *= a; - return r; -} - -int64_t pow_fun_int64( int64_t a, int64_t b ) -{ - if (b < 0) { - fprintf(stderr, "Negative exponent in function pow_fun_(): %lld `pow` %lld", a, b); - exit(1); - } - int64_t r = 1; - int i; - 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); -} - - - -/*--------------------------------------------------------------------------* - * Bit operations * - *--------------------------------------------------------------------------*/ - -int8_t bit_fun_int8( int32_t i ) -{ - return 1 << i; -} - -int16_t bit_fun_int16( int32_t i ) -{ - return 1 << i; -} - -int32_t bit_fun_int32( int32_t i ) -{ - return 1 << i; -} - -int64_t bit_fun_int64( int32_t i ) -{ - return 1 << i; -} - -uint8_t bit_fun_uint8( int32_t i ) -{ - return 1 << i; -} - -uint16_t bit_fun_uint16( int32_t i ) -{ - return 1 << i; -} - -uint32_t bit_fun_uint32( int32_t i ) -{ - return 1 << i; -} - -uint64_t bit_fun_uint64( int32_t i ) -{ - return 1 << i; -} - - - -int8_t setBit_fun_int8( int8_t x, int32_t i ) -{ - return x | 1 << i; -} - -int16_t setBit_fun_int16( int16_t x, int32_t i ) -{ - return x | 1 << i; -} - -int32_t setBit_fun_int32( int32_t x, int32_t i ) -{ - return x | 1 << i; -} - -int64_t setBit_fun_int64( int64_t x, int32_t i ) -{ - return x | 1 << i; -} - -uint8_t setBit_fun_uint8( uint8_t x, int32_t i ) -{ - return x | 1 << i; -} - -uint16_t setBit_fun_uint16( uint16_t x, int32_t i ) -{ - return x | 1 << i; -} - -uint32_t setBit_fun_uint32( uint32_t x, int32_t i ) -{ - return x | 1 << i; -} - -uint64_t setBit_fun_uint64( uint64_t x, int32_t i ) -{ - return x | 1 << i; -} - - - -int8_t clearBit_fun_int8( int8_t x, int32_t i ) -{ - return x & ~(1 << i); -} - -int16_t clearBit_fun_int16( int16_t x, int32_t i ) -{ - return x & ~(1 << i); -} - -int32_t clearBit_fun_int32( int32_t x, int32_t i ) -{ - return x & ~(1 << i); -} - -int64_t clearBit_fun_int64( int64_t x, int32_t i ) -{ - return x & ~(1 << i); -} - -uint8_t clearBit_fun_uint8( uint8_t x, int32_t i ) -{ - return x & ~(1 << i); -} - -uint16_t clearBit_fun_uint16( uint16_t x, int32_t i ) -{ - return x & ~(1 << i); -} - -uint32_t clearBit_fun_uint32( uint32_t x, int32_t i ) -{ - return x & ~(1 << i); -} - -uint64_t clearBit_fun_uint64( uint64_t x, int32_t i ) -{ - return x & ~(1 << i); -} - - - -int8_t complementBit_fun_int8( int8_t x, int32_t i ) -{ - return x ^ 1 << i; -} - -int16_t complementBit_fun_int16( int16_t x, int32_t i ) -{ - return x ^ 1 << i; -} - -int32_t complementBit_fun_int32( int32_t x, int32_t i ) -{ - return x ^ 1 << i; -} - -int64_t complementBit_fun_int64( int64_t x, int32_t i ) -{ - return x ^ 1 << i; -} - -uint8_t complementBit_fun_uint8( uint8_t x, int32_t i ) -{ - return x ^ 1 << i; -} - -uint16_t complementBit_fun_uint16( uint16_t x, int32_t i ) -{ - return x ^ 1 << i; -} - -uint32_t complementBit_fun_uint32( uint32_t x, int32_t i ) -{ - return x ^ 1 << i; -} - -uint64_t complementBit_fun_uint64( uint64_t x, int32_t i ) -{ - return x ^ 1 << i; -} - - - -int testBit_fun_int8( int8_t x, int32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_int16( int16_t x, int32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_int32( int32_t x, int32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_int64( int64_t x, int32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uint8( uint8_t x, int32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uint16( uint16_t x, int32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uint32( uint32_t x, int32_t i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uint64( uint64_t x, int32_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 x << 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; -} - - - -int32_t bitScan_fun_int8( int8_t x ) -{ - if (x == 0) return 7; - int32_t r = 0; - int8_t s = (x & 0x80); - while (((x <<= 1) & 0x80) == s) - ++r; - return r; -} - -int32_t bitScan_fun_int16( int16_t x ) -{ - if (x == 0) return 15; - int32_t r = 0; - int16_t s = (x & 0x8000); - while (((x <<= 1) & 0x8000) == s) - ++r; - return r; -} - -int32_t bitScan_fun_int32( int32_t x ) -{ - if (x == 0) return 31; - int32_t r = 0; - int32_t s = (x & 0x80000000); - while (((x <<= 1) & 0x80000000) == s) - ++r; - return r; -} - -int32_t bitScan_fun_int64( int64_t x ) -{ - if (x == 0) return 63; - int32_t r = 0; - int64_t s = (x & 0x8000000000000000ll); - while (((x <<= 1) & 0x8000000000000000ll) == s) - ++r; - return r; -} - -int32_t bitScan_fun_uint8( uint8_t x ) -{ - int32_t r = 8; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -int32_t bitScan_fun_uint16( uint16_t x ) -{ - int32_t r = 16; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -int32_t bitScan_fun_uint32( uint32_t x ) -{ - int32_t r = 32; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -int32_t bitScan_fun_uint64( uint64_t x ) -{ - int32_t r = 64; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -int32_t bitCount_fun_int8( int8_t x ) -{ - int32_t r = x & 1; - for (x = x >> 1 & 0x7f; x; x >>= 1) - r += x & 1; - return r; -} - -int32_t bitCount_fun_int16( int16_t x ) -{ - int32_t r = x & 1; - for (x = x >> 1 & 0x7fff; x; x >>= 1) - r += x & 1; - return r; -} - -int32_t bitCount_fun_int32( int32_t x ) -{ - int32_t r = x & 1; - for (x = x >> 1 & 0x7fffffff; x; x >>= 1) - r += x & 1; - return r; -} - -int32_t bitCount_fun_int64( int64_t x ) -{ - int32_t r = x & 1; - for (x = x >> 1 & 0x7fffffffffffffffll; x; x >>= 1) - r += x & 1; - return r; -} - -int32_t bitCount_fun_uint8( uint8_t x ) -{ - int32_t r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -int32_t bitCount_fun_uint16( uint16_t x ) -{ - int32_t r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -int32_t bitCount_fun_uint32( uint32_t x ) -{ - int32_t r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -int32_t bitCount_fun_uint64( uint64_t x ) -{ - int32_t r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - - - -/*--------------------------------------------------------------------------* - * copy_arrayOf() * - *--------------------------------------------------------------------------*/ - -void copy_arrayOf_int8( int8_t* a, int32_t a1, int8_t* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_int16( int16_t* a, int32_t a1, int16_t* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_int32( int32_t* a, int32_t a1, int32_t* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_int64( int64_t* a, int32_t a1, int64_t* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_uint8( uint8_t* a, int32_t a1, uint8_t* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_uint16( uint16_t* a, int32_t a1, uint16_t* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_uint32( uint32_t* a, int32_t a1, uint32_t* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_uint64( uint64_t* a, int32_t a1, uint64_t* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_float( float* a, signed int a1, float* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[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(); -} - -inline 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); -} - -inline 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.%06ld", 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); -} +#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.%06ld", 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 --- a/Feldspar/C/feldspar_c99.h +++ b/Feldspar/C/feldspar_c99.h @@ -1,35 +1,8 @@ -// -// Copyright (c) 2009-2010, 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 @@ -57,52 +30,45 @@ uint64_t signum_fun_uint64( uint64_t ); float signum_fun_float( float ); +float logBase_fun_float( float, float ); -int8_t bit_fun_int8( int32_t ); -int16_t bit_fun_int16( int32_t ); -int32_t bit_fun_int32( int32_t ); -int64_t bit_fun_int64( int32_t ); -uint8_t bit_fun_uint8( int32_t ); -uint16_t bit_fun_uint16( int32_t ); -uint32_t bit_fun_uint32( int32_t ); -uint64_t bit_fun_uint64( int32_t ); -int8_t setBit_fun_int8( int8_t, int32_t ); -int16_t setBit_fun_int16( int16_t, int32_t ); -int32_t setBit_fun_int32( int32_t, int32_t ); -int64_t setBit_fun_int64( int64_t, int32_t ); -uint8_t setBit_fun_uint8( uint8_t, int32_t ); -uint16_t setBit_fun_uint16( uint16_t, int32_t ); -uint32_t setBit_fun_uint32( uint32_t, int32_t ); -uint64_t setBit_fun_uint64( uint64_t, int32_t ); +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, int32_t ); -int16_t clearBit_fun_int16( int16_t, int32_t ); -int32_t clearBit_fun_int32( int32_t, int32_t ); -int64_t clearBit_fun_int64( int64_t, int32_t ); -uint8_t clearBit_fun_uint8( uint8_t, int32_t ); -uint16_t clearBit_fun_uint16( uint16_t, int32_t ); -uint32_t clearBit_fun_uint32( uint32_t, int32_t ); -uint64_t clearBit_fun_uint64( uint64_t, int32_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, int32_t ); -int16_t complementBit_fun_int16( int16_t, int32_t ); -int32_t complementBit_fun_int32( int32_t, int32_t ); -int64_t complementBit_fun_int64( int64_t, int32_t ); -uint8_t complementBit_fun_uint8( uint8_t, int32_t ); -uint16_t complementBit_fun_uint16( uint16_t, int32_t ); -uint32_t complementBit_fun_uint32( uint32_t, int32_t ); -uint64_t complementBit_fun_uint64( uint64_t, int32_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, int32_t ); -int testBit_fun_int16( int16_t, int32_t ); -int testBit_fun_int32( int32_t, int32_t ); -int testBit_fun_int64( int64_t, int32_t ); -int testBit_fun_uint8( uint8_t, int32_t ); -int testBit_fun_uint16( uint16_t, int32_t ); -int testBit_fun_uint32( uint32_t, int32_t ); -int testBit_fun_uint64( uint64_t, int32_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 ); @@ -131,38 +97,209 @@ uint32_t reverseBits_fun_uint32( uint32_t ); uint64_t reverseBits_fun_uint64( uint64_t ); -int32_t bitScan_fun_int8( int8_t ); -int32_t bitScan_fun_int16( int16_t ); -int32_t bitScan_fun_int32( int32_t ); -int32_t bitScan_fun_int64( int64_t ); -int32_t bitScan_fun_uint8( uint8_t ); -int32_t bitScan_fun_uint16( uint16_t ); -int32_t bitScan_fun_uint32( uint32_t ); -int32_t bitScan_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 ); -int32_t bitCount_fun_int8( int8_t ); -int32_t bitCount_fun_int16( int16_t ); -int32_t bitCount_fun_int32( int32_t ); -int32_t bitCount_fun_int64( int64_t ); -int32_t bitCount_fun_uint8( uint8_t ); -int32_t bitCount_fun_uint16( uint16_t ); -int32_t bitCount_fun_uint32( uint32_t ); -int32_t bitCount_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 ); -void copy_arrayOf_int8( int8_t*, int32_t, int8_t* ); -void copy_arrayOf_int16( int16_t*, int32_t, int16_t* ); -void copy_arrayOf_int32( int32_t*, int32_t, int32_t* ); -void copy_arrayOf_int64( int64_t*, int32_t, int64_t* ); -void copy_arrayOf_uint8( uint8_t*, int32_t, uint8_t* ); -void copy_arrayOf_uint16( uint16_t*, int32_t, uint16_t* ); -void copy_arrayOf_uint32( uint32_t*, int32_t, uint32_t* ); -void copy_arrayOf_uint64( uint64_t*, int32_t, uint64_t* ); -void copy_arrayOf_float( float*, int32_t, float* ); +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(); @@ -175,5 +312,14 @@ 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 --- a/Feldspar/C/feldspar_tic64x.c +++ b/Feldspar/C/feldspar_tic64x.c @@ -1,1078 +1,2336 @@ -// -// Copyright (c) 2009-2010, 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 - - - -/*--------------------------------------------------------------------------* - * pow(), abs(), signum() * - *--------------------------------------------------------------------------*/ - -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); -} - - - -/*--------------------------------------------------------------------------* - * Bit operations * - *--------------------------------------------------------------------------*/ - -char setBit_fun_char( char x, int i ) -{ - return x | 1 << i; -} - -short setBit_fun_short( short x, int i ) -{ - return x | 1 << i; -} - -int setBit_fun_int( int x, int i ) -{ - return x | 1 << i; -} - -long setBit_fun_long( long x, int i ) -{ - return x | 1 << i; -} - -long long setBit_fun_llong( long long x, int i ) -{ - return x | 1 << i; -} - -unsigned char setBit_fun_uchar( unsigned char x, int i ) -{ - return x | 1 << i; -} - -unsigned short setBit_fun_ushort( unsigned short x, int i ) -{ - return x | 1 << i; -} - -unsigned setBit_fun_uint( unsigned x, int i ) -{ - return x | 1 << i; -} - -unsigned long setBit_fun_ulong( unsigned long x, int i ) -{ - return x | 1 << i; -} - -unsigned long long setBit_fun_ullong( unsigned long long x, int i ) -{ - return x | 1 << i; -} - - - -char clearBit_fun_char( char x, int i ) -{ - return x & ~(1 << i); -} - -short clearBit_fun_short( short x, int i ) -{ - return x & ~(1 << i); -} - -int clearBit_fun_int( int x, int i ) -{ - return x & ~(1 << i); -} - -long clearBit_fun_long( long x, int i ) -{ - return x & ~(1 << i); -} - -long long clearBit_fun_llong( long long x, int i ) -{ - return x & ~(1 << i); -} - -unsigned char clearBit_fun_uchar( unsigned char x, int i ) -{ - return x & ~(1 << i); -} - -unsigned short clearBit_fun_ushort( unsigned short x, int i ) -{ - return x & ~(1 << i); -} - -unsigned clearBit_fun_uint( unsigned x, int i ) -{ - return x & ~(1 << i); -} - -unsigned long clearBit_fun_ulong( unsigned long x, int i ) -{ - return x & ~(1 << i); -} - -unsigned long long clearBit_fun_ullong( unsigned long long x, int i ) -{ - return x & ~(1 << i); -} - - - -char complementBit_fun_char( char x, int i ) -{ - return x ^ 1 << i; -} - -short complementBit_fun_short( short x, int i ) -{ - return x ^ 1 << i; -} - -int complementBit_fun_int( int x, int i ) -{ - return x ^ 1 << i; -} - -long complementBit_fun_long( long x, int i ) -{ - return x ^ 1 << i; -} - -long long complementBit_fun_llong( long long x, int i ) -{ - return x ^ 1 << i; -} - -unsigned char complementBit_fun_uchar( unsigned char x, int i ) -{ - return x ^ 1 << i; -} - -unsigned short complementBit_fun_ushort( unsigned short x, int i ) -{ - return x ^ 1 << i; -} - -unsigned complementBit_fun_uint( unsigned x, int i ) -{ - return x ^ 1 << i; -} - -unsigned long complementBit_fun_ulong( unsigned long x, int i ) -{ - return x ^ 1 << i; -} - -unsigned long long complementBit_fun_ullong( unsigned long long x, int i ) -{ - return x ^ 1 << i; -} - - - -int testBit_fun_char( char x, int i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_short( short x, int i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_int( int x, int i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_long( long x, int i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_llong( long long x, int i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uchar( unsigned char x, int i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_ushort( unsigned short x, int i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_uint( unsigned x, int i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_ulong( unsigned long x, int i ) -{ - return (x & 1 << i) != 0; -} - -int testBit_fun_ullong( unsigned long long x, int 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))); -} - -int rotateL_fun_int( int x, int i ) -{ - return (int)_rotl((unsigned)x, (unsigned)i); -/* if ((i %= 32) == 0) return x; - return (x << i) | ((0x7fffffff >> (31 - i)) & (x >> (32 - 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))); -} - -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 x << 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; -} - - - -int bitScan_fun_char( char x ) -{ - int r = 0; - char s = (x & 0x80); - if (x == 0) return 7; - while (((x <<= 1) & 0x80) == s) - ++r; - return r; -} - -int bitScan_fun_short( short x ) -{ - int r = 0; - short s = (x & 0x8000); - if (x == 0) return 15; - while (((x <<= 1) & 0x8000) == s) - ++r; - return r; -} - -int bitScan_fun_int( int x ) -{ - int r = 0; - int s = (x & 0x80000000); - if (x == 0) return 31; - while (((x <<= 1) & 0x80000000) == s) - ++r; - return r; -} - -int bitScan_fun_long( long x ) -{ - int r = 0; - long s = (x & 0x8000000000l); - if (x == 0) return 39; - while (((x <<= 1) & 0x8000000000l) == s) - ++r; - return r; -} - -int bitScan_fun_llong( long long x ) -{ - int r = 0; - long long s = (x & 0x8000000000000000ll); - if (x == 0) return 63; - while (((x <<= 1) & 0x8000000000000000ll) == s) - ++r; - return r; -} - -int bitScan_fun_uchar( unsigned char x ) -{ - int r = 8; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -int bitScan_fun_ushort( unsigned short x ) -{ - int r = 16; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -int bitScan_fun_uint( unsigned x ) -{ - int r = 32; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -int bitScan_fun_ulong( unsigned long x ) -{ - int r = 40; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -int bitScan_fun_ullong( unsigned long long x ) -{ - int r = 64; - while (x) - { - --r; - x >>= 1; - } - return r; -} - -int bitCount_fun_char( char x ) -{ - int r = x & 1; - for (x = x >> 1 & 0x7f; x; x >>= 1) - r += x & 1; - return r; -} - -int bitCount_fun_short( short x ) -{ - int r = x & 1; - for (x = x >> 1 & 0x7fff; x; x >>= 1) - r += x & 1; - return r; -} - -int bitCount_fun_int( int x ) -{ - int r = x & 1; - for (x = x >> 1 & 0x7fffffff; x; x >>= 1) - r += x & 1; - return r; -} - -int bitCount_fun_long( long x ) -{ - int r = x & 1; - for (x = x >> 1 & 0x7fffffffffl; x; x >>= 1) - r += x & 1; - return r; -} - -int bitCount_fun_llong( long long x ) -{ - int r = x & 1; - for (x = x >> 1 & 0x7fffffffffffffffll; x; x >>= 1) - r += x & 1; - return r; -} - -int bitCount_fun_uchar( unsigned char x ) -{ - int r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -int bitCount_fun_ushort( unsigned short x ) -{ - int r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -int bitCount_fun_ulong( unsigned long x ) -{ - int r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - -int bitCount_fun_ullong( unsigned long long x ) -{ - int r = x & 1; - while (x >>= 1) - r += x & 1; - return r; -} - - - -/*--------------------------------------------------------------------------* - * copy_arrayOf() * - *--------------------------------------------------------------------------*/ - -void copy_arrayOf_char( char* a, int a1, char* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_short( short* a, int a1, short* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_int( int* a, int a1, int* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_long( long* a, int a1, long* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_llong( long long* a, int a1, long long* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_uchar( unsigned char* a, int a1, unsigned char* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_ushort( unsigned short* a, int a1, unsigned short* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_uint( unsigned* a, int a1, unsigned* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_ulong( unsigned long* a, int a1, unsigned long* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_ullong( unsigned long long* a, int a1, unsigned long long* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - -void copy_arrayOf_float( float* a, signed int a1, float* b ) -{ - int i; - for(i = 0; i < a1; ++i) - b[i] = a[i]; -} - - - -/*--------------------------------------------------------------------------* - * 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); -} - -inline 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); -} +#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 --- a/Feldspar/C/feldspar_tic64x.h +++ b/Feldspar/C/feldspar_tic64x.h @@ -1,31 +1,3 @@ -// -// Copyright (c) 2009-2010, 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 @@ -59,57 +31,59 @@ 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, int ); -short setBit_fun_short( short, int ); -int setBit_fun_int( int, int ); -long setBit_fun_long( long, int ); -long long setBit_fun_llong( long long, int ); -unsigned char setBit_fun_uchar( unsigned char, int ); -unsigned short setBit_fun_ushort( unsigned short, int ); -unsigned setBit_fun_uint( unsigned, int ); -unsigned long setBit_fun_ulong( unsigned long, int ); -unsigned long long setBit_fun_ullong( unsigned long long, int ); -char clearBit_fun_char( char, int ); -short clearBit_fun_short( short, int ); -int clearBit_fun_int( int, int ); -long clearBit_fun_long( long, int ); -long long clearBit_fun_llong( long long, int ); -unsigned char clearBit_fun_uchar( unsigned char, int ); -unsigned short clearBit_fun_ushort( unsigned short, int ); -unsigned clearBit_fun_uint( unsigned, int ); -unsigned long clearBit_fun_ulong( unsigned long, int ); -unsigned long long clearBit_fun_ullong( unsigned long long, int ); +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 complementBit_fun_char( char, int ); -short complementBit_fun_short( short, int ); -int complementBit_fun_int( int, int ); -long complementBit_fun_long( long, int ); -long long complementBit_fun_llong( long long, int ); -unsigned char complementBit_fun_uchar( unsigned char, int ); -unsigned short complementBit_fun_ushort( unsigned short, int ); -unsigned complementBit_fun_uint( unsigned, int ); -unsigned long complementBit_fun_ulong( unsigned long, int ); -unsigned long long complementBit_fun_ullong( unsigned long long, int ); +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 ); -int testBit_fun_char( char, int ); -int testBit_fun_short( short, int ); -int testBit_fun_int( int, int ); -int testBit_fun_long( long, int ); -int testBit_fun_llong( long long, int ); -int testBit_fun_uchar( unsigned char, int ); -int testBit_fun_ushort( unsigned short, int ); -int testBit_fun_uint( unsigned, int ); -int testBit_fun_ulong( unsigned long, int ); -int testBit_fun_ullong( unsigned long long, int ); +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 ); -int rotateL_fun_int( int, 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 ); @@ -136,43 +110,282 @@ unsigned long reverseBits_fun_ulong( unsigned long ); unsigned long long reverseBits_fun_ullong( unsigned long long ); -int bitScan_fun_char( char ); -int bitScan_fun_short( short ); -int bitScan_fun_int( int ); -int bitScan_fun_long( long ); -int bitScan_fun_llong( long long ); -int bitScan_fun_uchar( unsigned char ); -int bitScan_fun_ushort( unsigned short ); -int bitScan_fun_uint( unsigned ); -int bitScan_fun_ulong( unsigned long ); -int bitScan_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 ); -int bitCount_fun_char( char ); -int bitCount_fun_short( short ); -int bitCount_fun_int( int ); -int bitCount_fun_long( long ); -int bitCount_fun_llong( long long ); -int bitCount_fun_uchar( unsigned char ); -int bitCount_fun_ushort( unsigned short ); -int bitCount_fun_ulong( unsigned long ); -int bitCount_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 ); -void copy_arrayOf_char( char*, int, char* ); -void copy_arrayOf_short( short*, int, short* ); -void copy_arrayOf_int( int*, int, int* ); -void copy_arrayOf_long( long*, int, long* ); -void copy_arrayOf_llong( long long*, int, long long* ); -void copy_arrayOf_uchar( unsigned char*, int, unsigned char* ); -void copy_arrayOf_ushort( unsigned short*, int, unsigned short* ); -void copy_arrayOf_uint( unsigned*, int, unsigned* ); -void copy_arrayOf_ulong( unsigned long*, int, unsigned long* ); -void copy_arrayOf_ullong( unsigned long long*, int, unsigned long long* ); -void copy_arrayOf_float( float*, int, float* ); +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(); @@ -187,5 +400,16 @@ 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 --- a/Feldspar/Compiler.hs +++ b/Feldspar/Compiler.hs @@ -1,39 +1,17 @@ --- --- Copyright (c) 2009-2010, 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 ( compile , icompile , icompile' + , icompileWithInfos_ + , getProgram + , forPrg + , ifPrg + , switchPrg + , assignPrg , defaultOptions + , c99PlatformOptions , tic64xPlatformOptions , unrollOptions - , noSimplification , noPrimitiveInstructionHandling ) where diff --git a/Feldspar/Compiler/Backend/C/CodeGeneration.hs b/Feldspar/Compiler/Backend/C/CodeGeneration.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/CodeGeneration.hs @@ -0,0 +1,166 @@ +{-# 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 (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@(UnionType 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 + len2str (IndirectLen s) = s +getStructTypeName options place t = replace (toC options place t) " " "" -- float complex -> floatcomplex + +instance ToC Type where + toC options place t@(StructType types) = "struct s" ++ getStructTypeName options place t + toC options place t@(UnionType types) = "union u" ++ getStructTypeName options place t + toC options place (UserType u) = u + toC options place VoidType = "void" + -- 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 ()) 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 = codeGenerationError InternalError $ "Array allocation is not allowed." +show_type options MainParameter_pl (ArrayType s t) restr = "struct array" +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 _ _ _ = "" + +show_name :: VariableRole -> Place -> Type -> String -> String +show_name Value place t n + | place == AddressNeed_pl = "&" ++ n + | otherwise = 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 _ = "" + +---------------------- +-- Type -- +---------------------- + +class HasType a where + typeof :: a -> Type + +instance HasType (Variable t) where + typeof (Variable r t s _) = t + +instance (ShowLabel t) => HasType (Constant t) where + typeof (IntConst _ _ _) = NumType Signed S32 + typeof (FloatConst _ _ _) = FloatType + typeof (BoolConst _ _ _) = BoolType + typeof (ComplexConst r i _ _) = ComplexType (typeof r) + typeof arr@(ArrayConst l _ _) = ArrayType (LiteralLen $ length l) elemtype + where + elemtype = case l of + [] -> codeGenerationError InternalError $ "Const array with 0 elements: " ++ show arr + _ -> checktype (typeof $ head l) (map typeof l) + checktype :: Type -> [Type] -> Type + checktype t [] = t + checktype t (x:xs) + | t == x = checktype t xs + | otherwise = codeGenerationError InternalError $ "Different element types in constant array: " ++ show arr + +instance (ShowLabel t) => HasType (Expression t) where + typeof (VarExpr v _) = typeof v + typeof (ArrayElem n i _ _) = decrArrayDepth (typeof n) + typeof (StructField s f _ _) = getStructFieldType f (typeof s) + typeof (ConstExpr c _) = typeof c + typeof (FunctionCall f t r p _ _) = t + typeof (Cast t e _ _) = t + typeof (SizeOf s _ _) = NumType Signed S32 + +instance (ShowLabel t) => HasType (ActualParameter t) where + typeof (In e _) = typeof e + typeof (Out l _) = typeof l + +---------------------- +-- 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 _ = codeGenerationError InternalError "Non-array variable 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Library.hs @@ -0,0 +1,41 @@ +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 + +data CompilationMode = Interactive | Standalone + deriving (Show, Eq) + +-- =========================================================================== +-- == 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" + +-- =========================================================================== +-- == 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Options.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE TypeSynonymInstances #-} + +module Feldspar.Compiler.Backend.C.Options where + + +import Feldspar.Compiler.Imperative.Representation + + +data Options = + Options + { platform :: Platform + , unroll :: UnrollStrategy + , debug :: DebugOption + , defaultArraySize :: Int + } 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)], + primitives :: [(FeldPrimDesc, Either CPrimDesc TransformPrim)], + includes :: [String], + isRestrict :: IsRestrict +} deriving (Eq, Show) + + +data FeldPrimDesc = FeldPrimDesc { + fName :: String, + inputs :: [TypeDesc] +} deriving (Eq, Show) + + +data CPrimDesc = Op1 { + cOp :: String +} | Op2 { + cOp :: String +} | Fun { + cName :: String, + funPf :: FunPostfixDescr +} | Proc { + cName :: String, + funPf :: FunPostfixDescr +} | Assig + | Cas + | InvalidDesc + deriving (Eq, Show) + + +data TypeDesc + = AllT + | BoolT + | RealT + | FloatT + | IntT | IntTS | IntTU | IntTS_ Size | IntTU_ Size | IntT_ Size + | ComplexT TypeDesc + | UserT String + deriving (Eq, Show) + + +data FunPostfixDescr = FunPostfixDescr { + useInputs :: Int, + useOutputs :: Int +} deriving (Eq, Show) + +noneFP = FunPostfixDescr 0 0 +firstInFP = FunPostfixDescr 1 0 +firstOutFP = FunPostfixDescr 0 1 + + +type ShowValue = Constant () -> String + +instance Eq ShowValue where + (==) _ _ = True + +instance Show ShowValue where + show _ = "<>" + + +type TransformPrim + = FeldPrimDesc + -> [Expression ()] + -> Type + -> PrgDesc + +instance Eq TransformPrim where + (==) _ _ = True + +instance Show TransformPrim where + show _ = "<>" + + +data PrgDesc + = PrgDesc [Crt] [Line] Rgt + deriving (Eq, Show) + +data Crt + = Crt Type Var (Maybe Rgt) + deriving (Eq, Show) + +data Line + = Asg Var Rgt + | Prc CPrimDesc [Rgt] [Var] + deriving (Eq, Show) + +data Rgt + = Exp (Expression ()) + | Fnc CPrimDesc [Rgt] Type + | VarR Var + deriving (Eq, Show) + +data Var + = Var String + deriving (Eq, Show) + +data IsRestrict = Restrict | NoRestrict + deriving (Show,Eq) + +machTypes :: TypeDesc -> Type -> Bool +machTypes AllT _ = True +machTypes BoolT BoolType = True +machTypes RealT FloatType = True +machTypes RealT (NumType _ _) = True +machTypes FloatT FloatType = True +machTypes IntT (NumType _ _) = True +machTypes IntTS (NumType Signed _) = True +machTypes IntTU (NumType Unsigned _) = True +machTypes (IntTS_ s) (NumType Signed s') = s == s' +machTypes (IntTU_ s) (NumType Unsigned s') = s == s' +machTypes (IntT_ s) (NumType _ s') = s == s' +machTypes (ComplexT a) (ComplexType a') = machTypes a a' +machTypes (UserT s) (UserType s') = s == s' +machTypes _ _ = False + + diff --git a/Feldspar/Compiler/Backend/C/Platforms.hs b/Feldspar/Compiler/Backend/C/Platforms.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Platforms.hs @@ -0,0 +1,406 @@ +module Feldspar.Compiler.Backend.C.Platforms + ( availablePlatforms + , c99 + , tic64x + ) where + + +import Feldspar.Compiler.Backend.C.Options +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Backend.C.CodeGeneration (typeof) + + + +availablePlatforms :: [Platform] +availablePlatforms = [ c99, tic64x ] + + +-- ansiC = Platform "ansiC" undefined [] [] ["\"feldspar.h\""] NoRestrict + + +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, "int", "int") + , (FloatType, "float", "float") + , (ComplexType (NumType Signed S8), "complexOf_int8", "complexOf_int8") + , (ComplexType (NumType Signed S16), "complexOf_int16", "complexOf_int16") + , (ComplexType (NumType Signed S32), "complexOf_int32", "complexOf_int32") + , (ComplexType (NumType Signed S64), "complexOf_int64", "complexOf_int64") + , (ComplexType (NumType Unsigned S8), "complexOf_uint8", "complexOf_uint8") + , (ComplexType (NumType Unsigned S16), "complexOf_uint16", "complexOf_uint16") + , (ComplexType (NumType Unsigned S32), "complexOf_uint32", "complexOf_uint32") + , (ComplexType (NumType Unsigned S64), "complexOf_uint64", "complexOf_uint64") + , (ComplexType FloatType, "float complex", "complexOf_float") + ] , + values = + [ (ComplexType (NumType Signed S8), + (\cx -> "complex_fun_int8(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Signed S16), + (\cx -> "complex_fun_int16(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Signed S32), + (\cx -> "complex_fun_int32(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Signed S64), + (\cx -> "complex_fun_int64(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Unsigned S8), + (\cx-> "complex_fun_uint8(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Unsigned S16), + (\cx -> "complex_fun_uint16(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Unsigned S32), + (\cx -> "complex_fun_uint32(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Unsigned S64), + (\cx -> "complex_fun_uint64(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType FloatType, + (\cx -> "(" ++ showRe cx ++ "+" ++ showIm cx ++ "i)")) + ] , + primitives = + [ (FeldPrimDesc "(==)" [ComplexT IntT, ComplexT IntT], Left $ Fun "equal" firstInFP) -- Eq instanced for Bool, Int, Float, Complex (Eq.hs) + , (FeldPrimDesc "(==)" [AllT, AllT], Left $ Op2 "==") + , (FeldPrimDesc "(/=)" [ComplexT IntT, ComplexT IntT], Left $ Fun "!equal" firstInFP) + , (FeldPrimDesc "(/=)" [AllT, AllT], Left $ Op2 "!=") + + , (FeldPrimDesc "(<)" [RealT, RealT], Left $ Op2 "<") -- Ord instanced for Int, Float (Ord.hs) + , (FeldPrimDesc "(>)" [RealT, RealT], Left $ Op2 ">") + , (FeldPrimDesc "(<=)" [RealT, RealT], Left $ Op2 "<=") + , (FeldPrimDesc "(>=)" [RealT, RealT], Left $ Op2 ">=") + + , (FeldPrimDesc "not" [BoolT], Left $ Op1 "!") -- Logic operations for Bool (Logic.hs) + , (FeldPrimDesc "(&&)" [BoolT, BoolT], Left $ Op2 "&&") + , (FeldPrimDesc "(||)" [BoolT, BoolT], Left $ Op2 "||") + + , (FeldPrimDesc "quot" [IntT, IntT], Left $ Op2 "/") +-- , (FeldPrimDesc "quot" [IntT, IntT], Right optimizedDivide) -- Integral instanced for Int (Integral.hs) + -- This optimization is invalid for odd negative numbers + , (FeldPrimDesc "rem" [IntT, IntT], Left $ Op2 "%") + , (FeldPrimDesc "(^)" [IntT, IntT], Left $ Fun "pow" firstInFP) + + , (FeldPrimDesc "negate" [ComplexT FloatT], Left $ Op1 "-") -- Num instanced for Int, Float, Complex (Num.hs) + , (FeldPrimDesc "negate" [ComplexT IntT], Left $ Fun "negate" firstInFP) + , (FeldPrimDesc "negate" [RealT], Left $ Op1 "-") + , (FeldPrimDesc "abs" [ComplexT FloatT], Left $ Fun "cabsf" noneFP) + , (FeldPrimDesc "abs" [ComplexT IntT], Left $ Fun "abs" firstInFP) + , (FeldPrimDesc "abs" [FloatT], Left $ Fun "fabsf" noneFP) + , (FeldPrimDesc "abs" [IntTU], Left Assig) +-- , (FeldPrimDesc "abs" [IntTS], Right absIntTS) + , (FeldPrimDesc "abs" [IntTS], Left $ Fun "abs" firstInFP) + , (FeldPrimDesc "signum" [ComplexT RealT], Left $ Fun "signum" firstInFP) +-- , (FeldPrimDesc "signum" [RealT], Right signumRealT) + , (FeldPrimDesc "signum" [RealT], Left $ Fun "signum" firstInFP) + , (FeldPrimDesc "(+)" [ComplexT IntT, ComplexT IntT], Left $ Fun "add" firstInFP) + , (FeldPrimDesc "(+)" [ComplexT FloatT, ComplexT FloatT], Left $ Op2 "+") + , (FeldPrimDesc "(+)" [RealT, RealT], Left $ Op2 "+") + , (FeldPrimDesc "(-)" [ComplexT IntT, ComplexT IntT], Left $ Fun "sub" firstInFP) + , (FeldPrimDesc "(-)" [ComplexT FloatT, ComplexT FloatT], Left $ Op2 "-") + , (FeldPrimDesc "(-)" [RealT, RealT], Right optimizedSubtract) + , (FeldPrimDesc "(*)" [ComplexT IntT, ComplexT IntT], Left $ Fun "mult" firstInFP) + , (FeldPrimDesc "(*)" [ComplexT FloatT, ComplexT FloatT], Left $ Op2 "*") + , (FeldPrimDesc "(*)" [RealT, RealT], Right optimizedMultiply) + + , (FeldPrimDesc "(/)" [ComplexT FloatT, ComplexT FloatT], Left $ Op2 "/") -- Fractional instanced for Float, Complex Float (Fractional.hs) + , (FeldPrimDesc "(/)" [FloatT, FloatT], Left $ Op2 "/") + + , (FeldPrimDesc "exp" [FloatT], Left $ Fun "expf" noneFP) -- Floating instanced for Float, Complex Float (Floating.hs) + , (FeldPrimDesc "exp" [ComplexT FloatT], Left $ Fun "cexpf" noneFP) + , (FeldPrimDesc "sqrt" [FloatT], Left $ Fun "sqrtf" noneFP) + , (FeldPrimDesc "sqrt" [ComplexT FloatT], Left $ Fun "csqrtf" noneFP) + , (FeldPrimDesc "log" [FloatT], Left $ Fun "logf" noneFP) + , (FeldPrimDesc "log" [ComplexT FloatT], Left $ Fun "clogf" noneFP) + , (FeldPrimDesc "(**)" [FloatT, FloatT], Left $ Fun "powf" noneFP) + , (FeldPrimDesc "(**)" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "cpowf" noneFP) + , (FeldPrimDesc "logBase" [FloatT, FloatT], Left $ Fun "logBase" firstInFP) + , (FeldPrimDesc "logBase" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "logBase" firstInFP) + , (FeldPrimDesc "sin" [FloatT], Left $ Fun "sinf" noneFP) + , (FeldPrimDesc "sin" [ComplexT FloatT], Left $ Fun "csinf" noneFP) + , (FeldPrimDesc "tan" [FloatT], Left $ Fun "tanf" noneFP) + , (FeldPrimDesc "tan" [ComplexT FloatT], Left $ Fun "ctanf" noneFP) + , (FeldPrimDesc "cos" [FloatT], Left $ Fun "cosf" noneFP) + , (FeldPrimDesc "cos" [ComplexT FloatT], Left $ Fun "ccosf" noneFP) + , (FeldPrimDesc "asin" [FloatT], Left $ Fun "asinf" noneFP) + , (FeldPrimDesc "asin" [ComplexT FloatT], Left $ Fun "casinf" noneFP) + , (FeldPrimDesc "atan" [FloatT], Left $ Fun "atanf" noneFP) + , (FeldPrimDesc "atan" [ComplexT FloatT], Left $ Fun "catanf" noneFP) + , (FeldPrimDesc "acos" [FloatT], Left $ Fun "acosf" noneFP) + , (FeldPrimDesc "acos" [ComplexT FloatT], Left $ Fun "cacosf" noneFP) + , (FeldPrimDesc "sinh" [FloatT], Left $ Fun "sinhf" noneFP) + , (FeldPrimDesc "sinh" [ComplexT FloatT], Left $ Fun "csinhf" noneFP) + , (FeldPrimDesc "tanh" [FloatT], Left $ Fun "tanhf" noneFP) + , (FeldPrimDesc "tanh" [ComplexT FloatT], Left $ Fun "ctanhf" noneFP) + , (FeldPrimDesc "cosh" [FloatT], Left $ Fun "coshf" noneFP) + , (FeldPrimDesc "cosh" [ComplexT FloatT], Left $ Fun "ccoshf" noneFP) + , (FeldPrimDesc "asinh" [FloatT], Left $ Fun "asinhf" noneFP) + , (FeldPrimDesc "asinh" [ComplexT FloatT], Left $ Fun "casinhf" noneFP) + , (FeldPrimDesc "atanh" [FloatT], Left $ Fun "atanhf" noneFP) + , (FeldPrimDesc "atanh" [ComplexT FloatT], Left $ Fun "catanhf" noneFP) + , (FeldPrimDesc "acosh" [FloatT], Left $ Fun "acoshf" noneFP) + , (FeldPrimDesc "acosh" [ComplexT FloatT], Left $ Fun "cacoshf" noneFP) + + , (FeldPrimDesc "(.&.)" [IntT, IntT], Left $ Op2 "&") -- Bits instanced for Int (Bits.hs) + , (FeldPrimDesc "(.|.)" [IntT, IntT], Left $ Op2 "|") + , (FeldPrimDesc "xor" [IntT, IntT], Left $ Op2 "^") + , (FeldPrimDesc "complement" [IntT], Left $ Op1 "~") + , (FeldPrimDesc "bit" [IntT], Right bitFunToShift) + , (FeldPrimDesc "setBit" [IntT, IntT], Left $ Fun "setBit" firstInFP) + , (FeldPrimDesc "clearBit" [IntT, IntT], Left $ Fun "clearBit" firstInFP) + , (FeldPrimDesc "complementBit" [IntT, IntT], Left $ Fun "complementBit" firstInFP) + , (FeldPrimDesc "testBit" [IntT, IntT], Left $ Fun "testBit" firstInFP) + , (FeldPrimDesc "shiftL" [IntT, IntT], Left $ Op2 "<<") + , (FeldPrimDesc "shiftR" [IntT, IntT], Left $ Op2 ">>") + , (FeldPrimDesc "rotateL" [IntT, IntT], Left $ Fun "rotateL" firstInFP) + , (FeldPrimDesc "rotateR" [IntT, IntT], Left $ Fun "rotateR" firstInFP) + , (FeldPrimDesc "reverseBits" [IntT], Left $ Fun "reverseBits" firstInFP) + , (FeldPrimDesc "bitScan" [IntT], Left $ Fun "bitScan" firstInFP) + , (FeldPrimDesc "bitCount" [IntT], Left $ Fun "bitCount" firstInFP) + , (FeldPrimDesc "bitSize" [IntT], Right bitSizeFunToConst) + , (FeldPrimDesc "isSigned" [IntT], Right isSignedFunToConst) + + , (FeldPrimDesc "complex" [RealT, RealT], Left $ Fun "complex" firstInFP) -- Complex operations for Complex (Complex.hs) + , (FeldPrimDesc "creal" [ComplexT FloatT], Left $ Fun "crealf" noneFP) + , (FeldPrimDesc "creal" [ComplexT IntT], Left $ Fun "creal" firstInFP) + , (FeldPrimDesc "cimag" [ComplexT FloatT], Left $ Fun "cimagf" noneFP) + , (FeldPrimDesc "cimag" [ComplexT IntT], Left $ Fun "cimag" firstInFP) + , (FeldPrimDesc "conjugate" [ComplexT FloatT], Left $ Fun "conjf" noneFP) + , (FeldPrimDesc "conjugate" [ComplexT IntT], Left $ Fun "conj" firstInFP) + , (FeldPrimDesc "magnitude" [ComplexT FloatT], Left $ Fun "cabsf" noneFP) + , (FeldPrimDesc "magnitude" [ComplexT IntT], Left $ Fun "magnitude" firstInFP) + , (FeldPrimDesc "phase" [ComplexT FloatT], Left $ Fun "cargf" noneFP) + , (FeldPrimDesc "phase" [ComplexT IntT], Left $ Fun "phase" firstInFP) + , (FeldPrimDesc "mkPolar" [RealT, RealT], Left $ Fun "mkPolar" firstInFP) + , (FeldPrimDesc "cis" [RealT], Left $ Fun "cis" firstInFP) + + , (FeldPrimDesc "f2i" [FloatT], Right (\_ [i] ot -> PrgDesc [] [] (Fnc Cas [Fnc (Fun "truncf" noneFP) [Exp i] FloatType] ot))) + , (FeldPrimDesc "i2n" [IntT], Right i2n) + , (FeldPrimDesc "b2i" [BoolT], Left $ Cas) + , (FeldPrimDesc "round" [FloatT], Right (\_ [i] ot -> PrgDesc [] [] (Fnc Cas [Fnc (Fun "roundf" noneFP) [Exp i] FloatType] ot))) + , (FeldPrimDesc "ceiling" [FloatT], Right (\_ [i] ot -> PrgDesc [] [] (Fnc Cas [Fnc (Fun "ceilf" noneFP) [Exp i] FloatType] ot))) + , (FeldPrimDesc "floor" [FloatT], Right (\_ [i] ot -> PrgDesc [] [] (Fnc Cas [Fnc (Fun "floorf" noneFP) [Exp i] FloatType] ot))) + ] , + includes = ["\"feldspar_c99.h\"", "\"feldspar_array.h\"", "", "", "", ""], + 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", "int") + , (FloatType, "float", "float") + , (ComplexType (NumType Signed S8), "complexOf_char", "complexOf_char") + , (ComplexType (NumType Signed S16), "unsigned", "complexOf_short") + , (ComplexType (NumType Signed S32), "complexOf_int", "complexOf_int") + , (ComplexType (NumType Signed S40), "complexOf_long", "complexOf_long") + , (ComplexType (NumType Signed S64), "complexOf_llong", "complexOf_llong") + , (ComplexType (NumType Unsigned S8), "complexOf_uchar", "complexOf_uchar") + , (ComplexType (NumType Unsigned S16), "unsigned", "complexOf_ushort") + , (ComplexType (NumType Unsigned S32), "complexOf_uint", "complexOf_uint") + , (ComplexType (NumType Unsigned S40), "complexOf_ulong", "complexOf_ulong") + , (ComplexType (NumType Unsigned S64), "complexOf_ullong", "complexOf_ullong") + , (ComplexType FloatType, "complexOf_float", "complexOf_float") + ] , + values = + [ (ComplexType (NumType Signed S8), + (\cx -> "complex_fun_char(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Signed S16), + (\cx -> "_pack2(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Signed S32), + (\cx -> "complex_fun_int(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Signed S40), + (\cx -> "complex_fun_long(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Signed S64), + (\cx -> "complex_fun_llong(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Unsigned S8), + (\cx -> "complex_fun_uchar(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Unsigned S16), + (\cx -> "_pack2(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Unsigned S32), + (\cx -> "complex_fun_uint(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Unsigned S40), + (\cx -> "complex_fun_ulong(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType (NumType Unsigned S64), + (\cx -> "complex_fun_ullong(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + , (ComplexType FloatType, + (\cx -> "complex_fun_float(" ++ showRe cx ++ "," ++ showIm cx ++ ")")) + ] , + primitives = + [ (FeldPrimDesc "(==)" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "equal" firstInFP) + , (FeldPrimDesc "(==)" [ComplexT (IntT_ S16), ComplexT (IntT_ S16)], Left $ Op2 "==") + , (FeldPrimDesc "(/=)" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "!equal" firstInFP) + , (FeldPrimDesc "(/=)" [ComplexT (IntT_ S16), ComplexT (IntT_ S16)], Left $ Op2 "!=") + + , (FeldPrimDesc "negate" [ComplexT FloatT], Left $ Fun "negate" firstInFP) + , (FeldPrimDesc "negate" [ComplexT (IntT_ S16)], Right (\_ [i] ot -> PrgDesc [] [] (Fnc (Fun "_sub2" noneFP) [Exp $ intToCe 0, Exp i] ot))) + , (FeldPrimDesc "abs" [ComplexT FloatT], Left $ Fun "abs" firstInFP) + , (FeldPrimDesc "abs" [FloatT], Left $ Fun "_fabsf" noneFP) + , (FeldPrimDesc "abs" [IntTS_ S32], Left $ Fun "_abs" noneFP) + , (FeldPrimDesc "(+)" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "add" firstInFP) + , (FeldPrimDesc "(+)" [ComplexT (IntT_ S16), ComplexT (IntT_ S16)], Left $ Fun "_add2" noneFP) + , (FeldPrimDesc "(-)" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "sub" firstInFP) + , (FeldPrimDesc "(-)" [ComplexT (IntT_ S16), ComplexT (IntT_ S16)], Left $ Fun "_sub2" noneFP) + , (FeldPrimDesc "(*)" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "mult" firstInFP) +-- , (FeldPrimDesc "(*)" [ComplexT (IntT_ S16), ComplexT (IntT_ S16)], Left $ Fun "_cmpyr" noneFP) -- Just on TI C64x+ + + , (FeldPrimDesc "(/)" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "div" firstInFP) + + , (FeldPrimDesc "exp" [ComplexT FloatT], Left $ Fun "exp" firstInFP) + , (FeldPrimDesc "sqrt" [ComplexT FloatT], Left $ Fun "sqrt" firstInFP) + , (FeldPrimDesc "log" [ComplexT FloatT], Left $ Fun "log" firstInFP) + , (FeldPrimDesc "(**)" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "cpow" firstInFP) + , (FeldPrimDesc "logBase" [ComplexT FloatT, ComplexT FloatT], Left $ Fun "logBase" firstInFP) + , (FeldPrimDesc "sin" [ComplexT FloatT], Left $ Fun "sin" firstInFP) + , (FeldPrimDesc "tan" [ComplexT FloatT], Left $ Fun "tan" firstInFP) + , (FeldPrimDesc "cos" [ComplexT FloatT], Left $ Fun "cos" firstInFP) + , (FeldPrimDesc "asin" [ComplexT FloatT], Left $ Fun "asin" firstInFP) + , (FeldPrimDesc "atan" [ComplexT FloatT], Left $ Fun "atan" firstInFP) + , (FeldPrimDesc "acos" [ComplexT FloatT], Left $ Fun "acos" firstInFP) + , (FeldPrimDesc "sinh" [ComplexT FloatT], Left $ Fun "sinh" firstInFP) + , (FeldPrimDesc "tanh" [ComplexT FloatT], Left $ Fun "tanh" firstInFP) + , (FeldPrimDesc "cosh" [ComplexT FloatT], Left $ Fun "cosh" firstInFP) + , (FeldPrimDesc "asinh" [ComplexT FloatT], Left $ Fun "asinh" firstInFP) + , (FeldPrimDesc "atanh" [ComplexT FloatT], Left $ Fun "atanh" firstInFP) + , (FeldPrimDesc "acosh" [ComplexT FloatT], Left $ Fun "acosh" firstInFP) + + , (FeldPrimDesc "rotateL" [IntTU_ S32, IntT], Left $ Fun "_rotl" noneFP) + , (FeldPrimDesc "reverseBits" [IntTU_ S32], Left $ Fun "_bitr" noneFP) + , (FeldPrimDesc "bitCount" [IntTU_ S32], Right optimizedBitCount) + + , (FeldPrimDesc "complex" [IntT_ S16, IntT_ S16], Left $ Fun "_pack2" noneFP) + , (FeldPrimDesc "creal" [ComplexT FloatT], Left $ Fun "creal" firstInFP) + , (FeldPrimDesc "cimag" [ComplexT FloatT], Left $ Fun "cimag" firstInFP) + , (FeldPrimDesc "conjugate" [ComplexT FloatT], Left $ Fun "conj" firstInFP) + , (FeldPrimDesc "magnitude" [ComplexT FloatT], Left $ Fun "magnitude" firstInFP) + , (FeldPrimDesc "phase" [ComplexT FloatT], Left $ Fun "phase" firstInFP) + + , (FeldPrimDesc "i2n" [IntT_ S16], Right (\_ [i] ot -> PrgDesc [] [] (Fnc (Fun "_pack2" noneFP) [Exp i, Exp $ intToCe 0] ot))) + ] + ++ primitives c99, + includes = ["\"feldspar_tic64x.h\"", "\"feldspar_array.h\"", "", "", ""], + isRestrict = Restrict +} + + +optimizedSubtract :: TransformPrim +optimizedSubtract _ [x, y] ot = case (x,y) of + ((ConstExpr (IntConst 0 _ _) _), _) -> PrgDesc [] [] (Fnc (Op1 "-") [Exp y] ot) + (_, _) -> PrgDesc [] [] (Fnc (Op2 "-") [Exp x, Exp y] ot) + + +optimizedMultiply :: TransformPrim +optimizedMultiply _ [x, y] ot = case (x,y) of + (_, (ConstExpr (IntConst _ _ _) _)) -> optimizedMultiply' x y + ((ConstExpr (IntConst _ _ _) _), _) -> optimizedMultiply' y x + (_, _conjugate) -> PrgDesc [] [] (Fnc (Op2 "*") [Exp x, Exp y] ot) + where + optimizedMultiply' int con + | (machTypes IntT $ typeof int) + && (con' >= 0) + && (2 ^ (numberOfTwoPrimeFactors con') == con') + = PrgDesc [] [] (Fnc (Op2 "<<") [Exp int, Exp $ intToCe $ numberOfTwoPrimeFactors con'] ot) + | (machTypes IntT $ typeof int) + && (con' < 0) + && (2 ^ (numberOfTwoPrimeFactors $ con' * (-1)) == con' * (-1)) + = PrgDesc [] [] (Fnc (Op1 "-") [Fnc (Op2 "<<") [Exp int, Exp $ intToCe $ numberOfTwoPrimeFactors $ con' * (-1)] ot] ot) + | otherwise = PrgDesc [] [] (Fnc (Op2 "*") [Exp x, Exp y] ot) + where + con' = ceToInt con + + +-- optimizedDivide :: TransformPrim +-- optimizedDivide _ [x, y] ot = case (x,y) of + -- (_, (ConstExpr (IntConst _ _ _) _)) -> optimizedDivide' x y + -- (_, _) -> PrgDesc [] [] (Fnc (Op2 "/") [Exp x, Exp y] ot) + -- where + -- optimizedDivide' int con + -- | (machTypes IntT $ typeof int) + -- && (con' >= 0) + -- && (2 ^ (numberOfTwoPrimeFactors con') == con') + -- = PrgDesc [] [] (Fnc (Op2 ">>") [Exp int, Exp $ intToCe $ numberOfTwoPrimeFactors con'] ot) + -- | (machTypes IntT $ typeof int) + -- && (con' < 0) + -- && (2 ^ (numberOfTwoPrimeFactors $ con' * (-1)) == con' * (-1)) + -- = PrgDesc [] [] (Fnc (Op1 "-") [Fnc (Op2 ">>") [Exp int, Exp $ intToCe $ numberOfTwoPrimeFactors $ con' * (-1)] ot] ot) + -- | otherwise = PrgDesc [] [] (Fnc (Op2 "/") [Exp x, Exp y] ot) + -- where + -- con' = ceToInt con + + +bitFunToShift _ [i] ot = PrgDesc [] [] (Fnc (Op2 "<<") [Exp $ intToCe 1, Exp i] ot) + + +bitSizeFunToConst :: TransformPrim +bitSizeFunToConst _ [i] _ = case (typeof i) of + (NumType _ s) -> PrgDesc [] [] (Exp $ intToCe $ sizeToInt s) + + +isSignedFunToConst :: TransformPrim +isSignedFunToConst _ [i] _ = case (typeof i) of + (NumType Signed _) -> PrgDesc [] [] (Exp $ boolToCe True) + (NumType Unsigned _) -> PrgDesc [] [] (Exp $ boolToCe False) + + +i2n :: TransformPrim +i2n _ [i] ot@(ComplexType _) = PrgDesc [] [] (Fnc (Fun "complex" firstInFP) [Exp i, Exp $ intToCe 0] ot) +i2n _ [i] ot = PrgDesc [] [] (Fnc Cas [Exp i] ot) + + +optimizedBitCount :: TransformPrim +optimizedBitCount _ [i] ot + = PrgDesc [] [] (Fnc (Fun "_dotpu4" noneFP) [Fnc (Fun "_bitc4" noneFP) [Exp i] ot, Exp $ intToCe 0x01010101] ot) + + +-- absIntTS :: TransformPrim +-- absIntTS _ [i] ot@(NumType _ s) +-- = PrgDesc +-- [Crt ot (Var "mask") (Just $ Fnc (Op2 ">>") [Exp i, Exp $ intToCe $ sizeToInt s - 1] ot)] +-- [] +-- (Fnc (Op2 "^") [Fnc (Op2 "+") [Exp i, VarR (Var "mask")] ot, VarR (Var "mask")] ot) + + +-- signumRealT :: TransformPrim +-- signumRealT _ [i] ot@(NumType Signed s) = PrgDesc [] [] (Fnc (Op2 "|") [Fnc (Op2 "!=") [Exp i, Exp $ intToCe 0] ot, Fnc (Op2 ">>") [Exp i, Exp $ intToCe $ sizeToInt s - 1] ot] ot) +-- signumRealT _ [i] ot@(NumType Unsigned s) = PrgDesc [] [] (Fnc (Op2 ">") [Exp i, Exp $ intToCe 0] ot) +-- signumRealT _ [i] ot@(FloatType) = PrgDesc [] [] (Fnc (Op2 "-") [Fnc (Op2 ">") [Exp i, Exp $ intToCe 0] ot, Fnc (Op2 "<") [Exp i, Exp $ intToCe 0] ot] ot) + + +numberOfTwoPrimeFactors 2 = 1 +numberOfTwoPrimeFactors x | x `mod` 2 == 0 = (numberOfTwoPrimeFactors $ x `div` 2) + 1 + | otherwise = 0 + +sizeToInt :: Size -> Integer +sizeToInt S8 = 8 +sizeToInt S16 = 16 +sizeToInt S32 = 32 +sizeToInt S40 = 40 +sizeToInt S64 = 64 + + +ceToInt (ConstExpr (IntConst x _ _) _) = x +intToCe x = ConstExpr (IntConst x () ()) () +boolToCe x = ConstExpr (BoolConst x () ()) () + + +showRe = showConstant . realPartComplexValue +showIm = showConstant . imagPartComplexValue + + +showConstant (IntConst c _ _) = show c +showConstant (FloatConst c _ _) = show c ++ "f" + + diff --git a/Feldspar/Compiler/Backend/C/Plugin/AllocationEliminator.hs b/Feldspar/Compiler/Backend/C/Plugin/AllocationEliminator.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Plugin/AllocationEliminator.hs @@ -0,0 +1,72 @@ +module Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator where + +import Data.Map (Map) +import qualified Data.Map as Map +import Feldspar.Transformation + +data AllocationEliminator = AllocationEliminator + +instance Transformation AllocationEliminator + where + type From AllocationEliminator = () + type To AllocationEliminator = () + type Down AllocationEliminator = () + type Up AllocationEliminator = () + type State AllocationEliminator = (Integer, Map String Integer) + +instance Transformable AllocationEliminator Definition + where + transform t s d proc@(Procedure _ _ _ _ _ _) = Result proc'{ inParams = mem : inParams proc' } s' u' + where + Result proc' s' u' = defaultTransform t s d proc + mem = Variable + { varName = "mem" + , varType = ArrayType UndefinedLen $ ArrayType UndefinedLen VoidType + , varRole = Value + , varLabel = () + } + + 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 = Value + , varLabel = () + } + , exprLabel = () + } + , arrayIndex = ConstExpr + { constExpr = IntConst + { intValue = i + , 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 m) d xs + _ -> Result1 (x:xs') s' u' + where + Result1 xs' s' u' = transform1 t s d xs + +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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Plugin/BlockProgramHandler.hs @@ -0,0 +1,52 @@ +{-# 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/HandlePrimitives.hs b/Feldspar/Compiler/Backend/C/Plugin/HandlePrimitives.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Plugin/HandlePrimitives.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE FlexibleInstances, TypeFamilies #-} + +module Feldspar.Compiler.Backend.C.Plugin.HandlePrimitives + ( HandlePrimitives(..) + , completeFunProcName + ) where + +import Data.List (find) +import Data.Maybe (fromJust) + +import Feldspar.Compiler.Imperative.Representation +import Feldspar.Compiler.Backend.C.CodeGeneration (typeof, defaultMemberName) +import Feldspar.Transformation +import Feldspar.Compiler.Backend.C.Options +import Feldspar.Compiler.Error + +handlePrimitivesError = handleError "PluginArch/HandlePrimitives" InternalError + +data HandleTraceFunctions = HandleTraceFunctions + +instance Default Bool where + def = False + +instance Combine Bool where + combine x y = or [x,y] + +instance Transformation HandleTraceFunctions where + type From HandleTraceFunctions = () + type To HandleTraceFunctions = () + type Down HandleTraceFunctions = () + type Up HandleTraceFunctions = Bool + type State HandleTraceFunctions = () + +instance Transformable HandleTraceFunctions Expression where + transform t s d p = tr { up = combine u' (up tr) } where + tr = defaultTransform t s d p + u' = case p of + FunctionCall "trace" _ _ _ _ _ -> True + _ -> False + +instance Transformable HandleTraceFunctions Definition where + transform t s d p@(Procedure n i o b _ _) = case up tr of + False -> tr + True -> tr + { result = (result tr) + { procBody = (procBody $ result tr) + { blockBody = addTraceSE $ blockBody $ procBody $ result tr + } + } + } + where + tr = defaultTransform t s d p + addTraceSE sequ@(Sequence _ _ _) = sequ { sequenceProgs = [traceStart] ++ (sequenceProgs sequ) ++ [traceEnd] } + addTraceSE p = Sequence [traceStart, p, traceEnd] () () + traceStart = ProcedureCall "traceStart" [] () () + traceEnd = ProcedureCall "traceEnd" [] () () + transform t s d p = defaultTransform t s d p +data HandlePrimitives = HandlePrimitives + + +instance Transformation HandlePrimitives where + type From HandlePrimitives = () + type To HandlePrimitives = () + type Down HandlePrimitives = (Int, Platform, Maybe (Expression ())) + type Up HandlePrimitives = ([Declaration ()], [Program ()]) + type State HandlePrimitives = Int + + +instance Plugin HandlePrimitives where + type ExternalInfo HandlePrimitives = (Int, DebugOption, Platform) + executePlugin _ (_,NoPrimitiveInstructionHandling,_) procedure = procedure + executePlugin _ (defArrSize,_,platform) procedure + = result $ transform HandlePrimitives 0 (defArrSize, platform, Nothing) $ + result $ transform HandleTraceFunctions ({-state-}) ({-down-}) procedure + +instance Combine ([Declaration ()], [Program ()]) where + combine (xl, xi) (yl, yi) = (xl ++ yl, xi ++ yi) + +instance Default [Declaration ()] where + def = [] + +instance Default [Program ()] where + def = [] + + + +instance Transformable HandlePrimitives Block where + transform t s d b = tr + { result = addToBlock (result tr) (up tr) + , up = ([],[]) + } where + tr = case (up tr') of + (_,[]) -> tr' + _ -> handlePrimitivesError $ "transform Block: upwards program list is not empty." + tr' = defaultTransform t s d b + + +instance Transformable HandlePrimitives Program where + transform t s d p@(ProcedureCall "copy" [o@(Out out _), i@(In inp _)] _ _) = case typeof out of + (ArrayType _ _) -> Result (ProcedureCall "copyArray" [out', inp'] () ()) arrS' arrU' + _ -> Result (Assign lhs rhs () ()) assS' assU' + where + (Result out' arrS arrU1) = transform t s d o + (Result inp' arrS' arrU2) = transform t arrS d i + arrU' = arrU1 `combine` arrU2 + (Result lhs assS assU1) = transform t s d out + (Result rhs assS' assU2) = transform t assS d inp + assU' = assU1 `combine` assU2 + -- transform t s d@(das, pfm, _) p@(ProcedureCall "copy" [Out out _, In _ _] _ _) = tr { result = makeAssignment (das, pfm) inp' out' } where + -- tr = case out of + -- e@(VarExpr v _) -> defaultTransform t s (das, pfm, Just e) p + -- e@(ArrayElem _ _ _ _) -> defaultTransform t s (das, pfm, Just e) p + -- e@(StructField _ _ _ _) -> defaultTransform t s (das, pfm, Just e) p + -- _ -> defaultTransform t s (das, pfm, Nothing) p + -- inp' = aToE $ head $ filter isInparam $ procCallParams $ result tr + -- out' = aToE $ head $ filter (not . isInparam) $ procCallParams $ result tr + transform t s d (SeqLoop c cc p inf1 inf2) = Result (SeqLoop (result tr1) cc' (result tr3) (convert inf1) $ convert inf2) (state tr3) ([],[]) where + tr1 = transform t s d c + tr2 = transform t (state tr1) d cc + tr3 = transform t (state tr2) d p + cc' = addToBlock (result tr2) (up tr1) + transform t s d p = defaultTransform t s d p + + +instance Transformable1 HandlePrimitives [] Program where + transform1 t s d [] = Result1 [] s def + transform1 t s d (x:xs) = Result1 (snd (up tr1) ++ [result tr1] ++ (result1 tr2)) (state1 tr2) (concatMap fst [up tr1,up1 tr2],[]) where + tr1 = transform t s d x + tr2 = transform1 t (state tr1) d xs + + +instance Transformable HandlePrimitives Declaration where + transform t s d@(das, pfm, _) (Declaration v i inf) = Result (Declaration (result tr1) i' $ convert inf) (state1 tr2) u' where + tr1 = transform t s d v + tr2 = transform1 t (state tr1) d i + (i',u') = case (up1 tr2) of + u@(ls,[]) -> (result1 tr2, combine (up tr1) u) + (ls, is) -> (Nothing, (ls, is ++ [makeAssignment (das, pfm) (fromJust $ result1 tr2) (vToE $ result tr1)])) + +instance Transformable HandlePrimitives Expression where + transform t s d@(das, pfm, me) f@(FunctionCall nameS ot origRole origInps _ _) = res + where + res = case (nameS, origInps) of + ("getFst", [FunctionCall "pair" _ _ [fs,sn] _ _]) -> transform t s (das, pfm, Nothing) fs + ("getSnd", [FunctionCall "pair" _ _ [fs,sn] _ _]) -> transform t s (das, pfm, Nothing) sn + _ -> Result e' s' $ combine (up tr) (l',p') + tr = defaultTransform t s (das, pfm, Nothing) f + s2 = state tr + (s',l',p',e') = case (nameS, inps, me) of + ("(!)", [arr, idx], _) -> (s2, [], [], ArrayElem arr idx () ()) + ("setIx", [arr, idx, val], _) -> (s2 + , [] + , [ makeAssignment d' val (ArrayElem arr idx () ()) ] + , arr + ) + ("getFst", [l], _) -> (s2, [], [], StructField l (defaultMemberName ++ "1") () ()) + ("getSnd", [l], _) -> (s2, [], [], StructField l (defaultMemberName ++ "2") () ()) + ("pair", [a,b], Just e) -> (s2 + , [] + , [ makeAssignment d' a (StructField e (defaultMemberName ++ "1") () ()) + , makeAssignment d' b (StructField e (defaultMemberName ++ "2") () ()) + ] + , e + ) + ("pair", [a,b], Nothing) -> (s3 + , [ makeDeclaration stc Nothing ] + , [ makeAssignment d' a (StructField (VarExpr stc ()) (defaultMemberName ++ "1") () ()) + , makeAssignment d' b (StructField (VarExpr stc ()) (defaultMemberName ++ "2") () ()) + ] + , VarExpr stc () + ) where (s3, stc) = makeVariable ot "stc" s2 + ("trace", [lab, orig], Just e) -> (s2 + , [] + , [ makeAssignment d' orig e + , makeProcedureCall pfm (Proc "trace" firstInFP) [e, lab] [] + ] + , e + ) + ("trace", [lab, orig], Nothing) -> (s3 + , [ makeDeclaration trc Nothing ] + , [ makeAssignment d' orig (VarExpr trc ()) + , makeProcedureCall pfm (Proc "trace" firstInFP) [VarExpr trc (), lab] [] + ] + , VarExpr trc () + ) where (s3, trc) = makeVariable ot "trc" s2 + _ -> case (find matchPrimitive $ primitives pfm) of + Just (fd,Right tp) -> transformPrgDesc d' s2 (tp fd inps ot) + Just (fd,Left cd) -> transformCPrimDesc d' s2 cd inps ot + Nothing -> (s2, [], [], result tr) + matchPrimitive (fd,_) = (fName fd == nameS) && (matchTypes' (inputs fd) inps) + inps = funCallParams $ result tr + d' = (das, pfm) + transform t s d@(das, pfm, _) p = defaultTransform t s (das, pfm, Nothing) p + + +addToBlock :: Block () -> ([Declaration ()], [Program ()]) -> Block () +addToBlock b (ls,is) + = b { + locals = locals b ++ ls, + blockBody = case (blockBody b) of + (Sequence s () ()) -> Sequence (s ++ is) () () + p -> Sequence ([p] ++ is) () () + } + + + +transformCPrimDesc :: (Int,Platform) -> Int -> CPrimDesc -> [Expression ()] -> Type -> (Int, [Declaration ()], [Program ()], Expression ()) +transformCPrimDesc (_,pfm) serial cd inps ot + = case (cd, length inps) of + (Op1 op, 1) -> (serial, [], [], FunctionCall op ot PrefixOp inps () ()) + (Op2 op, 2) -> (serial, [], [], FunctionCall op ot InfixOp inps () ()) + (Fun _ _, _) -> (serial, [], [], FunctionCall (completeFunProcName pfm cd (map typeof inps) [ot]) ot SimpleFun inps () ()) + (Cas, 1) -> (serial, [], [], Cast ot (head inps) () ()) + (Assig, 1) -> (serial, [], [], head inps) + _ -> (serial', [makeDeclaration ov Nothing], [makeProcedureCall pfm cd inps [vToE ov]], vToE ov) + where + (serial', ov) = makeVariable ot "vhp" serial + + + +transformPrgDesc :: (Int,Platform) -> Int -> PrgDesc -> (Int, [Declaration ()], [Program ()], Expression ()) +transformPrgDesc down@(_,pfm) serial (PrgDesc crts lns rgt) + = (serial', map (\(_,_,v,me) -> makeDeclaration v me) vars, ins, transformRgt vars rgt) + where + (serial', vars') = foldl transformCrtFold (serial, []) (map searchDuplicateLabels crts) + (vars, ins) = foldl transformLineFold (vars', []) lns + + searchDuplicateLabels c = if (length $ filter (==c) crts) > 1 then handlePrimitivesError $ "multiple declaration" ++ show c else c + + transformCrtFold (n ,vs) (Crt t v@(Var s) (Just r)) = (n', vs ++ [(v, True, mv, Just $ transformRgt vs r)]) + where + (n', mv) = makeVariable t s n + transformCrtFold (n ,vs) (Crt t v@(Var s) Nothing) = (n', vs ++ [(v, False, mv, Nothing)]) + where + (n', mv) = makeVariable t s n + + transformLineFold (vs, is) ln = case (ln) of + (Asg v r) -> (updateVars [v], is ++ [makeAssignment down (transformRgt' r) (transformVarL' v)]) + (Prc cd inps outs) -> (updateVars outs, is ++ [makeProcedureCall pfm cd (map transformRgt' inps) (map transformVarL' outs)]) + where + updateVars xs = map (\y@(v',_,vv,mr) -> if elem v' xs then (v',True,vv,mr) else y) vs + transformRgt' = transformRgt vs + transformVarL' = vToE . transformVarL vs + + transformRgt vs (Exp e) = e + transformRgt vs (Fnc cd rgts ot) = makeFunctionCallOrCast down cd (map (transformRgt vs) rgts) ot + transformRgt vs (VarR v) = vToE $ transformVarR vs v + + transformVarL vs v@(Var s) = case (find (\(v',_,_,_) -> v' == v) vs) of + Just (_,_,vv,_) -> vv + Nothing -> handlePrimitivesError $ "Not declared: " ++ show v + transformVarR vs v@(Var s) = case (find (\(v',_,_,_) -> v' == v) vs) of + Just (_,True,vv,_) -> vv + Just (_,False,vv,_) -> vv -- Do not check that is there any initial assignment -- quick bugfix with pair - set_pair macros + -- Just _ -> handlePrimitivesError $ "The variable hasn't got value yet: " ++ show v + Nothing -> handlePrimitivesError $ "Not declared: " ++ show v + + + + +makeFunctionCallOrCast :: (Int,Platform) -> CPrimDesc -> [Expression ()] -> Type -> Expression () +makeFunctionCallOrCast down cd inps ot + = case (transformCPrimDesc down (-1) cd inps ot) of + (_, [], [], ed) -> ed + _ -> handlePrimitivesError $ "it's not a FunctionCall: " ++ show cd ++ "number of inputs: " ++ (show $ length inps) + + +makeVariable :: Type -> String -> Int -> (Int, Variable ()) +makeVariable t s n = (n+1, Variable (s ++ show n) t Value ()) + + +makeDeclaration :: Variable () -> Maybe (Expression ()) -> Declaration () +makeDeclaration v me = Declaration v me () + + +makeAssignment :: (Int,Platform) -> Expression () -> Expression () -> Program () +makeAssignment (defArrSize,pfm) inp out + = case (sameVariable inp out, typeof inp) of + (True, _) -> Empty () () + (_, ArrayType _ t) -> ProcedureCall "copyArray" [eToOut out, eToIn inp] () () + where + -- size = prod_const (arraySize (typeof out) defArrSize) (SizeOf (Left $ baseType t) () ()) + -- baseType (ArrayType _ t) = baseType t + -- baseType t = t + _ -> Assign out inp () () + where + sameVariable (VarExpr v1 _) (VarExpr v2 _) | v1 == v2 = True + | otherwise = False + sameVariable (ArrayElem a1 i1 _ _) (ArrayElem a2 i2 _ _) | a1 == a2 && i1 == i2 = True + | otherwise = False + sameVariable _ _ = False + +makeProcedureCall :: Platform -> CPrimDesc -> [Expression ()] -> [Expression ()] -> Program () +makeProcedureCall pfm cd@(Proc _ _) inps outs = ProcedureCall (completeFunProcName pfm cd its ots) (inps' ++ outs') () () + where + inps' = map eToIn inps + outs' = map eToOut outs + its = map typeof inps + ots = map typeof outs + +makeProcedureCall _ cd _ _ = handlePrimitivesError $ "Wrong C pirmitive description in makeProcedureCall:\n" ++ show cd + + + + +matchTypes' :: [TypeDesc] -> [Expression ()] -> Bool +matchTypes' [] [] = True +matchTypes' [] (y:ys) = False +matchTypes' (x:xs) [] = False +matchTypes' (x:xs) (y:ys) = (machTypes x $ typeof y) && (matchTypes' xs ys) + + +completeFunProcName :: Platform -> CPrimDesc -> [Type] -> [Type] -> String +completeFunProcName pfm desc its ots + | funPf desc == noneFP = cName desc + | otherwise = cName desc ++ ifFun ++ apsToName + where + ifFun = case desc of + Fun _ _ -> "_fun" + Proc _ _ -> "" + apsToName = concatMap (("_"++) . (toFunName pfm)) apsToNameList + apsToNameList = (take (useInputs $ funPf desc) its) ++ (take (useOutputs $ funPf desc) ots) + + +toFunName :: Platform -> Type -> String +toFunName pfm (ArrayType _ t@(ArrayType _ _)) = toFunName pfm t +toFunName pfm (ArrayType _ t) = "arrayOf_" ++ toFunName pfm t +toFunName pfm t = case (find (\(t',_,_) -> t == t') $ types pfm) of + Just (_,_,s) -> map (\c -> if c == ' ' then '_' else c) $ s + Nothing -> handlePrimitivesError $ "Unhandled type in platform " ++ name pfm + + +-- arraySize :: Type -> Int -> Expression () +-- arraySize a@(ArrayType _ t) defaultArraySize = toExp $ arraySize' a + -- where + -- arraySize' :: Type -> (Int,Int) + -- arraySize' (ArrayType (LiteralLen n) t) = (n * fst at, snd at) where + -- at = arraySize' t + -- arraySize' (ArrayType UndefinedLen t) = (fst at, 1 + snd at) where + -- at = arraySize' t + -- arraySize' _ = (1,0) + -- toExp :: (Int,Int) -> Expression () + -- toExp (c, 0) = intToCe $ toInteger c + -- toExp (c, i) = prod_const (toExp (c, i-1)) (vToE $ Variable defaultArraySizeConstantName (NumType Unsigned S32) Value ()) + + +prod_const a b = FunctionCall "*" (NumType Unsigned S32) InfixOp [a,b] () () + +isInparam (In _ _) = True +isInparam (Out _ _) = False + + +aToE (In x ()) = x +aToE (Out x ()) = x + +eToIn x = In x () +eToOut x = Out x () + + +-- ceToInt (Expression (ConstantExpression (Constant (IntConstant (IntConstantType x _)) _)) _) = x +intToCe x = ConstExpr (IntConst x () ()) () + +vToE v = VarExpr v () + diff --git a/Feldspar/Compiler/Backend/C/Plugin/Locator.hs b/Feldspar/Compiler/Backend/C/Plugin/Locator.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Plugin/Locator.hs @@ -0,0 +1,192 @@ +{-# 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 Switch +----------------------------------------------------- + +data GetPrgSwitch = GetPrgSwitch + +instance Transformation GetPrgSwitch where + type From GetPrgSwitch = DebugToCSemanticInfo + type To GetPrgSwitch = DebugToCSemanticInfo + type Down GetPrgSwitch = (Int, Int) + type Up GetPrgSwitch = (Bool, Program DebugToCSemanticInfo) + type State GetPrgSwitch = () + + +instance Plugin GetPrgSwitch where + type ExternalInfo GetPrgSwitch = (Int, Int) + executePlugin GetPrgSwitch (line, col) procedure = + result $ transform GetPrgSwitch () (line, col) procedure + +getPrgSwitch :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo) +getPrgSwitch (line, col) procedure = up res where + res = transform GetPrgSwitch () (line, col) procedure + +instance Transformable GetPrgSwitch Program where + transform GetPrgSwitch () (line, col) sw@(Switch _ cases inf1 inf2) = Result sw () info where + info = case contains (line, col) inf1 of + True -> infoCr where + res = prgSwList (line, col) cases + infoCr = case (fst $ res) of + True -> res + _ -> (True, sw) + _ -> def + + transform t () (line, col) pr = defaultTransform t () (line, col) pr + +prgSwList:: (Int, Int) -> [SwitchCase DebugToCSemanticInfo] -> (Bool, Program DebugToCSemanticInfo) +prgSwList (line, col) [] = def +prgSwList (line, col) (x:xs) = combine info1 info2 where + info1 = up $ transform GetPrgSwitch () (line, col) x + info2 = prgSwList (line, col) xs + + +------------------------------------------------- +------ 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Plugin/PrettyPrint.hs @@ -0,0 +1,646 @@ +{-# 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.PrettyPrintHelp +import Feldspar.Compiler.Backend.C.Platforms +import Feldspar.Compiler.Backend.C.Options +import Feldspar.Compiler.Error + +import qualified Data.List as List (last,find) + + +-- =========================================================================== +-- == DebugToC plugin +-- =========================================================================== + + +data DebugToC = DebugToC + +data DebugToCSemanticInfo + +instance Annotation DebugToCSemanticInfo Module where + type Label DebugToCSemanticInfo Module = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Definition where + type Label DebugToCSemanticInfo Definition = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Struct where + type Label DebugToCSemanticInfo Struct = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Procedure where + type Label DebugToCSemanticInfo Procedure = ((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 UnionField where + type Label DebugToCSemanticInfo UnionField = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Cast where + type Label DebugToCSemanticInfo Cast = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo SwitchCase where + type Label DebugToCSemanticInfo SwitchCase = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Switch where + type Label DebugToCSemanticInfo Switch = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Comment where + type Label DebugToCSemanticInfo Comment = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo UnionMember where + type Label DebugToCSemanticInfo UnionMember = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo GlobalVar where + type Label DebugToCSemanticInfo GlobalVar = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Prototype where + type Label DebugToCSemanticInfo Prototype = ((Int, Int), (Int, Int)) + +instance Annotation DebugToCSemanticInfo Union where + type Label DebugToCSemanticInfo Union = ((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 t (line, col) (options, place, indent) x@(Variable name typ role inf) = Result (Variable name typ role newInf) (line, newCol) cRep where + newInf = ((line, col),(line, newCol)) + newCol = col + length cRep + cRep = toC options place x + +instance Transformable1 DebugToC [] Constant where + transform1 t (line, col) (options, place, indent) [] = 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) = Result1 ((result newX):(result1 newXs)) (state1 newXs) (up newX ++ ", " ++ up1 newXs) where + newX = transform t (line, col) (options, place, indent) x + (line2, col2) = state newX + newSt = (line2, col2 + length ", ") + newXs = transform1 t newSt (options, place, indent) xs + +instance Transformable DebugToC Constant where + transform t (line, col) (options, place, indent) (ArrayConst list inf1 inf2) = Result (ArrayConst (result1 newList) newInf newInf) (line2, newCol) cRep where + newList = transform1 t (line, col + length "{") (options, place, indent) list + (line2, col2) = state1 newList + newCol = col2 + length "}" + newInf = ((line, col),(line, newCol)) + cRep = "{" ++ up1 newList ++ "}" + + transform t (line, col) (options, place, indent) const@(IntConst c inf1 inf2) = Result (IntConst c newInf newInf) (line, newCol) cRep where + newInf = ((line, col),(line, newCol)) + newCol = col + length cRep + cRep = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of + Just (_,f) -> f const + Nothing -> show c + + transform t (line, col) (options, place, indent) const@(FloatConst c inf1 inf2) = Result (FloatConst c newInf newInf) (line, newCol) cRep where + newInf = ((line, col),(line, newCol)) + newCol = col + length cRep + cRep = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of + Just (_,f) -> f const + Nothing -> show c ++ "f" + + transform t (line, col) (options, place, indent) const@(BoolConst False inf1 inf2) = Result (BoolConst False newInf newInf) (line, newCol) cRep where + newInf = ((line, col),(line, newCol)) + newCol = col + length cRep + cRep = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of + Just (_,f) -> f const + Nothing -> "0" + + transform t (line, col) (options, place, indent) const@(BoolConst True inf1 inf2) = Result (BoolConst True newInf newInf) (line, newCol) cRep where + newInf = ((line, col),(line, newCol)) + newCol = col + length cRep + cRep = case (List.find (\(t',_) -> t' == typeof const) $ values $ platform options) of + Just (_,f) -> f const + Nothing -> "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) (line, newCol) cRep where + newInf = ((line, col),(line, newCol)) + newCol = col + length cRep + cRep = f const + newReal = transform t (line, col) (options, place, indent) real -- TODO: Is this case valid + newIm = transform t (line, col) (options, place, indent) im -- TODO: by ComplexConst ??? + Nothing -> + Result (ComplexConst (result newReal) (result newIm) newInf newInf) (line3, newCol) cRep where + newReal = transform t (line, col + length "complex(") (options, place, indent) real + (line2, col2) = state newReal + newIm = transform t (line2, col2 + length ",") (options, place, indent) im + (line3, col3) = state newIm + newCol = col3 + length ")" + newInf = ((line, col),(line, newCol)) + cRep = "complex(" ++ up newReal ++ "," ++ up newIm ++ ")" + + +instance Transformable DebugToC ActualParameter where + transform t (line, col) (options, place, indent) (In param@(VarExpr (Variable _ (StructType _) _ _) _) inf) = Result (In (result newParam) newInf) newSt cRep where + newParam = transform t (line, col) (options, AddressNeed_pl, indent) param + (line2, col2) = state newParam + newSt = (line2, col2) + newInf = ((line, col), newSt) + cRep = up newParam + + transform t (line, col) (options, place, indent) (In param inf) = Result (In (result newParam) newInf) newSt cRep where + newParam = transform t (line, col) (options, FunctionCallIn_pl, indent) param + (line2, col2) = state newParam + newSt = (line2, col2) + newInf = ((line, col), newSt) + cRep = up newParam + + transform t (line, col) (options, place, indent) (Out param inf) = Result (Out (result newParam) newInf) newSt cRep where + newParam = transform t (line, col) (options, AddressNeed_pl, indent) param + (line2, col2) = state newParam + newSt = (line2, col2) + newInf = ((line, col), newSt) + cRep = up newParam + +instance Transformable1 DebugToC [] Expression where + transform1 t (line, col) (options, place, indent) [] = 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) = Result1 ((result newX):(result1 newXs)) (state1 newXs) (up newX ++ ", " ++ up1 newXs) where + newX = transform t (line, col) (options, place, indent) x + (line2, col2) = state newX + newSt = (line2, col2 + length ", ") + newXs = transform1 t newSt (options, place, indent) xs + +instance Transformable DebugToC Expression where + transform t (line, col) (options, place, indent) (VarExpr val inf) = Result (VarExpr (result newVal) newInf) newSt cRep where + newVal = transform t (line, col) (options, place, indent) val + (line2, col2) = state newVal + newSt = (line2, col2) + newInf = ((line, col), newSt) + cRep = up newVal + + transform t (line, col) (options, place, indent) e@(ArrayElem name index inf1 inf2) = Result (ArrayElem (result newName) (result newIndex) newInf newInf) newSt cRep where + prefix = case place of + AddressNeed_pl -> "&" + _ -> "" + at = prefix ++ "at(" ++ show_type options MainParameter_pl (typeof e) NoRestrict ++ "," + newName = transform t (line, col + length at) (options, ValueNeed_pl, indent) name + (line2, col2) = state newName + newIndex = transform t (line2, col2 + length ",") (options, ValueNeed_pl, indent) index + (line3, col3) = state newIndex + newSt = (line3, col3 + length ")") + newInf = ((line, col), newSt) + cRep = at ++ up newName ++ "," ++ up newIndex ++ ")" + + transform t (line, col) (options, place, indent) (StructField str field inf1 inf2) = Result (StructField (result newStr) field newInf newInf) newSt cRep where + newStr = transform t (line, col) (options, ValueNeed_pl, indent) str + (line2, col2) = state newStr + newSt = (line2, col2 + length ("." ++ field)) + newInf = ((line, col), newSt) + cRep = up newStr ++ "." ++ field + + transform t (line, col) (options, place, indent) (UnionField targetUnion field inf1 inf2) = Result (StructField (result newTarget) field newInf newInf) newSt cRep where + newTarget = transform t (line, col) (options, ValueNeed_pl, indent) targetUnion + (line2, col2) = state newTarget + newSt = (line2, col2 + length ("." ++ field)) + newInf = ((line, col), newSt) + cRep = up newTarget ++ "." ++ field + + transform t (line, col) (options, place, indent) (ConstExpr val inf) = Result (ConstExpr (result newVal) newInf) newSt cRep where + newVal = transform t (line, col) (options, place, indent) val + (line2, col2) = state newVal + newSt = (line2, col2) + newInf = ((line, col), newSt) + cRep = up newVal + + transform t (line, col) (options, place, indent) (FunctionCall "!" typ role [a,b] inf1 inf2) = Result (FunctionCall "!" typ role [result newA, result newB] newInf newInf) newSt cRep where + newA = transform t (line, col+3) (options, place, indent) a + (line2, col2) = state newA + newB = transform t (line2, col2 + length ",") (options, place, indent) b + (line3, col3) = state newB + newSt = (line3, col3 + length ")") + newInf = ((line, col), newSt) + cRep = "at(" ++ up newA ++ "," ++ up newB ++ ")" + + transform t (line, col) (options, place, indent) (FunctionCall fun typ InfixOp [a,b] inf1 inf2) = Result (FunctionCall fun typ InfixOp [result newA, result newB] newInf newInf) newSt cRep where + newA = transform t (line, col + length "(") (options, place, indent) a + (line2, col2) = state newA + newB = transform t (line2, col2 + length (" " ++ fun ++ " ")) (options, place, indent) b + (line3, col3) = state newB + newSt = (line3, col3 + length ")") + newInf = ((line, col), newSt) + cRep = "(" ++ up newA ++ " " ++ fun ++ " " ++ up newB ++ ")" + + transform t (line, col) (options, place, indent) (FunctionCall fun typ role paramlist inf1 inf2) = Result (FunctionCall fun typ role (result1 newParamlist) newInf newInf) newSt cRep where + newParamlist = transform1 t (line, col + length (fun ++ "(")) (options, place, indent) paramlist + (line2, col2) = state1 newParamlist + newSt = (line2, col2 + length ")") + newInf = ((line, col), newSt) + cRep = fun ++ "(" ++ up1 newParamlist ++ ")" + + transform t (line, col) (options, place, indent) (Cast typ exp inf1 inf2) = Result (Cast typ (result newExp) newInf newInf) newSt cRep where + prefix = concat ["(", toC options place typ, ")("] + newExp = transform t (line, col + length prefix) (options, place, indent) exp + (line2, col2) = state newExp + newSt = (line2, col2 + length ")") + newInf = ((line, col), newSt) + cRep = prefix ++ up newExp ++ ")" + + transform t (line, col) (options, place, indent) (SizeOf (Left typ) inf1 inf2) = Result (SizeOf (Left typ) newInf newInf) newSt cRep where + col2 = col + length cRep + newSt = (line, col2) + newInf = ((line, col), newSt) + cRep = "sizeof(" ++ toC options place typ ++ ")" + + transform t (line, col) (options, place, indent) (SizeOf (Right exp) inf1 inf2) = Result (SizeOf (Right (result newExp)) newInf newInf) newSt cRep where + newExp = transform t (line, col + length "sizeof(") (options, place, indent) exp + (line2, col2) = state newExp + newSt = (line2, col2 + length ")") + newInf = ((line, col), newSt) + cRep = "sizeof(" ++ up newExp ++ ")" + +instance Transformable1 DebugToC [] Definition 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) (up newX ++ up1 newXs) where + newX = transform t (line, col) (options, place, indent) x + (line2, col2) = state newX + newSt = (line2, col2) + newXs = transform1 t newSt (options, place, indent) xs + + +instance Transformable DebugToC Module where + transform t (line, col) (options, place, indent) (Module defList inf) = Result (Module (result1 newDefList) newInf) newSt cRep where + newDefList = transform1 t (line, col) (options, place, indent) defList + (line2, col2) = state1 newDefList + newSt = (line2, col2) + newInf = ((line, col), newSt) + cRep = up1 newDefList + +instance Transformable1 DebugToC [] Variable where + transform1 t (line, col) (options, place, indent) [] = 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) = Result1 ((result newX):(result1 newXs)) (state1 newXs) (up newX ++ ", " ++ up1 newXs) where + newX = transform t (line, col) (options, place, indent) x + (line2, col2) = state newX + newSt = (line2, col2 + length ", ") + newXs = transform1 t newSt (options, place, indent) xs + + +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) ((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 Transformable1 DebugToC [] UnionMember 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 Definition where + transform t (line, col) (options, place, indent) (Struct name members inf1 inf2) = Result (Struct name (result1 newMembers) newInf newInf) newSt cRep where + newIndent = indent + 4 + newMembers = transform1 t (line + 1, newIndent) (options, place, newIndent) members + (line2, col2) = state1 newMembers + newSt = (line2 + 1, indent) + newInf = ((line, col), newSt) + cRep = name ++ " {\n" ++ up1 newMembers ++ putIndent indent ++ "};\n" + + transform t (line, col) (options, place, indent) (Union name members inf1 inf2) = Result (Union name (result1 newMembers) newInf newInf) newSt cRep where + newIndent = indent + 4 + newMembers = transform1 t (line + 1, newIndent) (options, place, newIndent) members + (line2, col2) = state1 newMembers + newSt = (line2 + 1, indent) + newInf = ((line, col), newSt) + cRep = name ++ " {\n" ++ up1 newMembers ++ putIndent indent ++ "};\n" + + + transform t (line, col) (options, place, indent) (Procedure name inParam outParam body inf1 inf2) = Result (Procedure name (result1 newInParam) (result1 newOutParam) (result newBody) newInf newInf) newSt cRep where + newInParam = transform1 t (line, col + length ("void " ++ name ++ "(")) (options, MainParameter_pl, indent) inParam + (line2, col2) = state1 newInParam + (newSt1, newInPStr) | up1 newInParam == "" = ((line2, col2), "") + | otherwise = ((line2, col2 + length ", "), up1 newInParam ++ ", ") + newOutParam = transform1 t newSt1 (options, MainParameter_pl, indent) outParam + (line3, col3) = state1 newOutParam + newIndent = indent + 4 + newBody = transform t (line3 + 2, newIndent) (options, Declaration_pl, newIndent) body + (line4, col4) = state newBody + newSt = (line4 + 1, indent) + newInf = ((line, col), newSt) + cRep = putIndent indent ++ "void "++ name ++ "(" ++ newInPStr ++ up1 newOutParam ++ ")\n" ++ putIndent indent ++ "{\n" ++ up newBody ++ putIndent indent ++ "}\n" + + transform t (line, col) (options, place, indent) (Prototype returnType name inParam outParam inf1 inf2) = Result (Prototype returnType name (result1 newInParam) (result1 newOutParam) newInf newInf) newSt cRep where + newInParam = transform1 t (line, col + length (" " ++ name ++ "(")) (options, MainParameter_pl, indent) inParam + (line2, col2) = state1 newInParam + (newSt1, newInPStr) | up1 newInParam == "" = ((line2, col2), "") + | otherwise = ((line2, col2 + length ", "), up1 newInParam ++ ", ") + newOutParam = transform1 t newSt1 (options, MainParameter_pl, indent) outParam + (line3, col3) = state1 newOutParam + newSt = (line3 + 1, indent) + newInf = ((line, col), newSt) + cRep = putIndent indent ++ " "++ name ++ "(" ++ newInPStr ++ up1 newOutParam ++ ");\n" + + transform t (line, col) (options, place, indent) (GlobalVar decl inf1 inf2) = Result (GlobalVar (result newDecl) newInf newInf) newSt cRep where + newDecl = transform t (line, col) (options, place, indent) decl + (line2, col2) = state newDecl + newSt = (line2 + 1, indent) + newInf = ((line, col), newSt) + cRep = up newDecl ++ ";\n" + +instance Transformable DebugToC StructMember where + transform t (line, col) (options, place, indent) dsm@(StructMember str typ inf) = Result (StructMember str typ newInf) newSt cRep where + col2 = col + length cRep + newSt = (line, col2) + newInf = ((line, col), newSt) + cRep = case structMemberType dsm of + ArrayType len innerType -> show_variable options place Value (structMemberType dsm) + (structMemberName dsm) ++ ";" + otherwise -> (toC options place $ structMemberType dsm) ++ " " ++ structMemberName dsm ++ ";" + +instance Transformable DebugToC UnionMember where + transform t (line, col) (options, place, indent) dsm@(UnionMember str typ inf) = Result (UnionMember str typ newInf) newSt cRep where + col2 = col + length cRep + newSt = (line, col2) + newInf = ((line, col), newSt) + cRep = case unionMemberType dsm of + ArrayType len innerType -> show_variable options place Value (unionMemberType dsm) + (unionMemberName dsm) ++ ";" + otherwise -> (toC options place $ unionMemberType dsm) ++ " " ++ unionMemberName dsm ++ ";" + +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) newSt cRep where + newLocs = transform1 t (line, col) (options, Declaration_pl, indent) locs + (line2, col2) = state1 newLocs + newSt1 | up1 newLocs == "" = (line2, col2) + | otherwise = (line2 + 1, indent) + newBody = transform t newSt1 (options, place, indent) body + (line3, col3) = state newBody + newSt = (line3, col3) + newInf = ((line, col), newSt) + --cRep = up1 newLocs ++ "\n" ++ up newBody + cRep = listprint id "\n" [up1 newLocs, up newBody] + +instance Transformable DebugToC Declaration where + transform t (line, col) (options, place, indent) (Declaration declVar Nothing inf) = Result (Declaration (result newDeclVar) Nothing newInf) newSt cRep where + newDeclVar = transform t (line, col) (options, Declaration_pl, indent) declVar + (line2, col2) = state newDeclVar + newSt = (line2, col2) + newInf = ((line, col), newSt) + cRep = up newDeclVar + + transform t (line, col) (options, place, indent) (Declaration declVar (Just expr) inf) = Result (Declaration (result newDeclVar) (Just (result newExpr)) newInf) newSt cRep where + newDeclVar = transform t (line, col) (options, Declaration_pl, indent) declVar + (line2, col2) = state newDeclVar + newExpr = transform t (line2, col2 + length " = ") (options, ValueNeed_pl, indent) expr + (line3, col3) = state newExpr + newSt = (line3, col3) + newInf = ((line, col), newSt) + cRep = up newDeclVar ++ " = " ++ up newExpr + +instance Transformable1 DebugToC [] ActualParameter where + transform1 t (line, col) (options, place, indent) [] = 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) = + Result1 ((result newX):(result1 newXs)) (state1 newXs) ((up newX ++ ", ") ++ up1 newXs) + where + newX = transform t (line, col) (options, place, indent) x + (line2, col2) = state newX + newSt = (line2 , col2 + length ", ") + newXs = transform1 t newSt (options, place, indent) xs + +instance Transformable1 DebugToC [] Program 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) (up newX ++ up1 newXs) where + newX = transform t (line, col) (options, place, indent) x + (line2, col2) = state newX + newSt = (line2, col2) + newXs = transform1 t newSt (options, place, indent) xs + +instance Transformable1 DebugToC [] SwitchCase 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) ((up newX ++"break;\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 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) newSt cRep where + lineNum = length $ lines $ comment ++ "a" + newSt = (lineNum + 1, indent) + newInf = ((line, col), newSt) + cRep = "/* " ++ comment ++ " */\n" + + transform t (line, col) (options, place, indent) (Comment False comment inf1 inf2) = Result (Comment False comment newInf newInf) newSt cRep where + newSt = (line + 1, indent) + newInf = ((line, col), newSt) + cRep = "// " ++ comment ++ "\n" + + transform t (line, col) (options, place, indent) (Assign lhs rhs inf1 inf2) = Result (Assign (result newLhs) (result newRhs) newInf newInf) newSt cRep where + newLhs = transform t (line, col) (options, ValueNeed_pl, indent) lhs + (line2, col2) = state newLhs + newRhs = transform t (line2, col2 + length " = ") (options, ValueNeed_pl, indent) rhs + (line3, col3) = state newRhs + newSt = (line3 + 1, indent) + newInf = ((line, col), newSt) + cRep = putIndent indent ++ up newLhs ++ " = " ++ up newRhs ++ ";\n" + + transform t (line, col) (options, place, indent) (ProcedureCall name param inf1 inf2) = Result (ProcedureCall name (result1 newParam) newInf newInf) newSt cRep where + newParam = transform1 t (line, col + length name + length "(") (options, place, indent) param + (line2, col2) = state1 newParam + newSt = (line2 +1, indent) + newInf = ((line, col), newSt) + cRep = putIndent indent ++ name ++ "(" ++ up1 newParam ++ ");\n" + + transform t (line, col) (options, place, indent) (Sequence prog inf1 inf2) = Result (Sequence (result1 newProg) newInf newInf) newSt cRep where + newProg = transform1 t (line, col) (options, place, indent) prog + (line2, col2) = state1 newProg + newSt = (line2, col2) + newInf = ((line, col), newSt) + cRep = up1 newProg + + transform t (line, col) (options, place, indent) (Branch con tPrg ePrg inf1 inf2) = Result (Branch (result newCon) (result newTPrg) (result newEPrg) newInf newInf) newSt cRep where + newCon = transform t (line, col + length "if(") (options, ValueNeed_pl, indent) con + (line2, col2) = state newCon + newTPrg = transform t (line2 + 2, indent + 4) (options, place, indent + 4) tPrg + (line3, col3) = state newTPrg + newEPrg = transform t (line3 + 3, indent + 4) (options, place, indent + 4) ePrg + (line4, col4) = state newEPrg + newSt = (line4 + 1, indent) + newInf = ((line, col), newSt) + cRep = putIndent indent ++ "if(" ++ up newCon ++ ")\n" ++ putIndent indent ++ "{\n" ++ + up newTPrg ++ putIndent indent ++ "}\n" ++ putIndent indent ++ "else\n" ++ putIndent indent + ++ "{\n" ++ up newEPrg ++ putIndent indent ++ "}\n" + + transform t (line, col) (options, place, indent) (Switch cond cases inf1 inf2) = Result (Switch (result newCond) (result1 newCases) newInf newInf) newSt cRep where + newCond = transform t (line, col + length "switch (") (options, ValueNeed_pl, indent) cond + (line2, col2) = state newCond + newCases = transform1 t (line + 2, indent + 4) (options, place, indent + 4) cases + (line3, col3) = state1 newCases + newSt = (line3 + 1, indent) + newInf = ((line, col), newSt) + cRep = "switch (" ++ up newCond ++")\n" ++ putIndent indent ++ "{\n" ++ up1 newCases ++ putIndent indent ++ "}\n" + + transform t (line, col) (options, place, indent) (SeqLoop con conPrg blockPrg inf1 inf2) = Result (SeqLoop (result newCon) (result newConPrg) (result newBlockPrg) newInf newInf) newSt cRep where + newConPrg = transform t (line + 1, indent + 4) (options, place, indent + 4) conPrg + (line2, col2) = state newConPrg + newCon = transform t (line2, indent + 4 + length "while(") (options, ValueNeed_pl, indent + 4) con + (line3, col3) = state newCon + newBlockPrg = transform t (line2 + 2, indent + 4 + length "{\n") (options, place, indent + 8) blockPrg + (line4, col4) = state newBlockPrg + loopEnd = transform t (line4, col4) (options, place, indent + 8) (blockBody conPrg) + (line5, col5) = state loopEnd + newSt = (line5 + 2, indent) + newInf = ((line, col), newSt) + cRep = putIndent indent ++ "{\n" ++ up newConPrg ++ putIndent (indent + 4) ++ "while(" ++ + up newCon ++ ")\n" ++ putIndent (indent + 4) ++ "{\n" ++ up newBlockPrg ++ up loopEnd ++ + putIndent (indent + 4) ++ "}\n" ++ putIndent indent ++ "}\n" + + 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) newSt cRep where + newCount = transform t (line + 1, indent + 4) (options, Declaration_pl, indent + 4) count + (line2, col2) = state newCount + for_init = transform t (line2 + 1, indent + 4 + length "for(") (options, ValueNeed_pl, indent + 4) count + (line3, col3) = state for_init + for_test = transform t (line3, col3 + length " = 0; ") (options, ValueNeed_pl, indent + 4) count + (line4, col4) = state for_test + newBound = transform t (line4, col4 + length " < ") (options, ValueNeed_pl, indent + 4) bound + (line5, col5) = state newBound + for_inc = transform t (line5, col5 + length "; ") (options, ValueNeed_pl, indent + 4) count + (line6, col6) = state for_inc + newProg = transform t (line6 + 2, indent + 8) (options, place, indent + 8) prog + (line7, col7) = state newProg + newSt = (line7 + 2, indent) + newInf = ((line, col), newSt) + cRep = putIndent indent ++ "{\n" ++ putIndent (indent + 4) ++ up newCount ++ ";\n" ++ putIndent (indent + 4) ++ + "for(" ++ up for_init ++ " = 0; " ++ up for_test ++ " < " ++ up newBound ++ "; " ++ up for_inc ++ + " += " ++ show step ++ ")\n" ++ putIndent (indent + 4) ++ "{\n" ++ up newProg ++ putIndent (indent + 4) ++ + "}\n" ++ putIndent indent ++ "}\n" + + transform t (line, col) (options, place, indent) (BlockProgram prog inf) = Result (BlockProgram (result newProg) newInf) newSt cRep where + newProg = transform t (line + 1, indent + 4) (options, place, indent + 4) prog + (line2, col2) = state newProg + newSt = (line2 + 1, indent) + newInf = ((line, col), newSt) + cRep = putIndent indent ++ "{\n" ++ up newProg ++ putIndent indent ++ "}\n" + +instance Transformable DebugToC SwitchCase where + transform t (line, col) (options, place, indent) (SwitchCase matcher impl inf) = Result (SwitchCase (result newMatcher) (result newImpl) newInf) newSt cRep where + newMatcher = transform t (line, indent + length "case ") (options, place, indent) matcher + (line2, col2) = state newMatcher + newImpl = transform t (line2 + 1, indent + 4) (options, place, indent + 4) impl + (line3, col3) = state newImpl + newSt = (line3, col3 + length "}") + newInf = ((line, col), newSt) + cRep = "case " ++ up newMatcher ++ ": {\n" ++ up newImpl ++ putIndent indent ++ "}" + + + +putIndent ind = concat $ replicate ind " " diff --git a/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs b/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Plugin/TypeCorrector.hs @@ -0,0 +1,170 @@ +{-# 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 definition generator plugin +-- =========================================================================== + +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 Definition where + transform t s d p@(GlobalVar v inf1 inf2) = defaultTransform t s True p + 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 Definition where + transform t s d p@(Procedure _ _ _ _ _ _) = 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 Definition where + transform t s d p@(Procedure 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'' (IndirectLen a) (IndirectLen b) = (a==b, (IndirectLen b)) + select'' _ _ = (False, undefined) + 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Plugin/TypeDefinitionGenerator.hs @@ -0,0 +1,66 @@ +{-# 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 -> [Definition ()] +getTypes options typ = {-trace ("DEBUG: "show typ) $-} case typ of + StructType members -> concatMap (getTypes options . snd) members + ++ [Struct { + structName = toC options Declaration_pl (StructType members), + structMembers = map (\(name,typ) -> StructMember name typ ()) members, + structLabel = (), + definitionLabel = () + }] + UnionType members -> concatMap (getTypes options . snd) members + ++ [Union { + unionName = toC options Declaration_pl (UnionType members), + unionMembers = map (\(name,typ) -> UnionMember name typ ()) members, + unionLabel = (), + 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 = [Definition ()] + +instance Transformable TypeDefinitionGenerator Module where + transform selfpointer origState fromAbove origModule = defaultTransformationResult { + result = (result defaultTransformationResult) { + definitions = (nub $ state defaultTransformationResult) + ++ (definitions $ 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Backend/C/Plugin/VariableRoleAssigner.hs @@ -0,0 +1,44 @@ +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) || + (isStruct v && (varName v `elem` inParametersVRA d)) + then Pointer else Value + , varLabel = () + } + +instance Transformable VariableRoleAssigner Definition where + transform t s d p@(Procedure 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 + +isStruct :: Variable () -> Bool +isStruct v = case varType v of + (StructType types) -> True + otherwise -> False diff --git a/Feldspar/Compiler/Compiler.hs b/Feldspar/Compiler/Compiler.hs --- a/Feldspar/Compiler/Compiler.hs +++ b/Feldspar/Compiler/Compiler.hs @@ -1,139 +1,131 @@ --- --- Copyright (c) 2009-2010, 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 - ( compile - , standaloneCompile - , icompile - , icompile' - , defaultOptions - , tic64xPlatformOptions - , unrollOptions - , noSimplification - , noPrimitiveInstructionHandling - , fixFunctionName - , c99Options - ) where +module Feldspar.Compiler.Compiler where import Data.Map -import Feldspar.Core.Reify (reify) -import Feldspar.Core.Reify as Reify -import Feldspar.Core.Graph -import qualified Feldspar.Core.Expr as Expr +import System.IO +import Data.Typeable as DT + import Feldspar.Core.Types -import Feldspar.Compiler.Options -import Feldspar.Compiler.Platforms -import Feldspar.Compiler.Transformation.GraphToImperative -import Feldspar.Compiler.Transformation.Lifting +import Feldspar.Transformation +import qualified Feldspar.NameExtractor as Precompiler -import Feldspar.Compiler.PluginArchitecture -import Feldspar.Compiler.Plugins.BackwardPropagation -import Feldspar.Compiler.Plugins.ForwardPropagation -import Feldspar.Compiler.Plugins.Precompilation -import Feldspar.Compiler.Plugins.HandlePrimitives -import Feldspar.Compiler.Plugins.PrettyPrint -import Feldspar.Compiler.Plugins.Unroll ---import Feldspar.Compiler.Plugins.ConstantFolding +import Feldspar.Compiler.Imperative.Representation +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.HandlePrimitives +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 . Compilable a => SomeCompilable a + deriving (DT.Typeable) -import Feldspar.Compiler.Transformation.GraphUtils -import Feldspar.Compiler.Imperative.Semantics -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Imperative.CodeGeneration -import qualified Feldspar.Compiler.Precompiler.Precompiler as Precompiler -import System.IO +-- ================================================================================================ +-- == Compiler core +-- ================================================================================================ -type Writer t = (CompilationMode -> t -> FilePath -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> IO ()) +compileToC :: (Compilable t) => + CompilationMode -> t -> Precompiler.OriginalFunctionSignature -> Options -> Int -> (String, (Int, Int)) +compileToC compilationMode prg originalFunctionSignature coreOptions lineNum = + compToC ((coreOptions, Declaration_pl), lineNum) $ executePluginChain compilationMode prg originalFunctionSignature { + Precompiler.originalFunctionName = fixFunctionName $ Precompiler.originalFunctionName originalFunctionSignature + } coreOptions -------------------------- --- Core compiler -- -------------------------- +compileToCWithInfos :: (Compilable t) => + CompilationMode -> t -> Precompiler.OriginalFunctionSignature -> Options -> Int -> (Module DebugToCSemanticInfo, (String, (Int, Int))) +compileToCWithInfos compilationMode prg originalFunctionSignature coreOptions lineNum = + compToCWithInfos ((coreOptions, Declaration_pl), lineNum) $ executePluginChain compilationMode prg originalFunctionSignature { + Precompiler.originalFunctionName = fixFunctionName $ Precompiler.originalFunctionName originalFunctionSignature + } coreOptions -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) +compileToCWithHeaders :: (Compilable t) => + CompilationMode -> t -> Precompiler.OriginalFunctionSignature -> Options -> (String, (Int, Int)) +compileToCWithHeaders compilationMode prg originalFunctionSignature coreOptions = + (headers ++ cSource, endPos) where + (cSource, endPos) = compileToC compilationMode prg originalFunctionSignature coreOptions lineNum + (headers, lineNum) = genHeaders coreOptions -fixFunctionName :: String -> String -fixFunctionName functionName = replace (replace functionName "_" "__") "'" "_prime" +compileToCWithHeaders_Infos :: (Compilable t) => + CompilationMode -> t -> Precompiler.OriginalFunctionSignature -> Options -> (Module DebugToCSemanticInfo, (String, (Int, Int))) +compileToCWithHeaders_Infos compilationMode prg originalFunctionSignature coreOptions = + (debugModule, (headers ++ cSource, endPos)) where + (debugModule, (cSource, endPos)) = compileToCWithInfos compilationMode prg originalFunctionSignature coreOptions lineNum + (headers, lineNum) = genHeaders coreOptions -coreCompile :: (Reify.Program t) => - Writer t -> CompilationMode -> t -> FilePath -> FilePath -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> IO () -coreCompile write compilationMode prg inputFileName outputFileName originalFeldsparFunctionSignature opts = - write compilationMode prg outputFileName originalFeldsparFunctionSignature { - Precompiler.originalFeldsparFunctionName = fixFunctionName $ Precompiler.originalFeldsparFunctionName originalFeldsparFunctionSignature - } opts -------------------------- --- Standalone compiler -- -------------------------- +-- ================================================================================================ +-- == Standalone compilation +-- ================================================================================================ -standaloneWrite :: (Reify.Program t) => Writer t -standaloneWrite compilationMode prg outFileName originalFeldsparFunctionSignature opts - = appendFile outFileName $ compToC (platform opts) $ executePluginChain compilationMode prg originalFeldsparFunctionSignature opts +standaloneCompile :: (Compilable t) => + t -> FilePath -> FilePath -> Precompiler.OriginalFunctionSignature -> Options -> IO () +standaloneCompile prg inputFileName outputFileName originalFunctionSignature opts = + appendFile outputFileName $ fst $ compileToCWithHeaders Standalone prg originalFunctionSignature opts -standaloneCompile :: (Reify.Program t) => t -> FilePath -> FilePath -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> IO () -standaloneCompile prg inputFileName outputFileName originalFeldsparFunctionSignature opts - = coreCompile standaloneWrite Standalone prg inputFileName outputFileName originalFeldsparFunctionSignature opts +-- ================================================================================================ +-- == Interactive compilation +-- ================================================================================================ ------------------------------------------------- --- Invoking the compiler from the interpreter -- ------------------------------------------------- +data PrgType = ForType | AssignType | IfType | SwitchType -fileWrite :: (Reify.Program t) => Writer t -fileWrite compilationMode prg fileName originalFeldsparFunctionSignature opts - = writeFile fileName $ (incList $ includes $ platform $ opts) ++ (compToC (platform opts) $ executePluginChain compilationMode prg originalFeldsparFunctionSignature opts) +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 + SwitchType -> getPrgSwitch (line, col) prg + -compile :: (Reify.Program t) => t -> FilePath -> String -> Options -> IO () -compile prg fileName functionName opts - = coreCompile fileWrite Interactive prg "" fileName (Precompiler.OriginalFeldsparFunctionSignature functionName []) opts +compile :: (Compilable t) => t -> FilePath -> String -> Options -> IO () +compile prg fileName functionName opts = writeFile fileName $ + fst $ compileToCWithHeaders Interactive prg (Precompiler.OriginalFunctionSignature functionName []) opts -writeOut :: (Reify.Program t) => Writer t -writeOut compilationMode prg fileName functionName opts - = putStrLn $ (incList $ includes $ platform $ opts) ++ (compToC (platform opts) $ executePluginChain compilationMode prg functionName opts) +icompile :: (Compilable t) => t -> IO () +icompile prg = putStrLn $ + fst $ compileToCWithHeaders Interactive prg (Precompiler.OriginalFunctionSignature "test" []) defaultOptions -icompile :: (Reify.Program t) => t -> IO () -icompile prg - = coreCompile writeOut Interactive prg "" "" (Precompiler.OriginalFeldsparFunctionSignature "test" []) defaultOptions +icompile' :: (Compilable t) => t -> String -> Options -> IO () +icompile' prg functionName opts = putStrLn $ + fst $ compileToCWithHeaders Interactive prg (Precompiler.OriginalFunctionSignature functionName []) opts -icompile' :: (Reify.Program t) => t -> String -> Options -> IO () -icompile' prg functionName opts - = coreCompile writeOut Interactive prg "" "" (Precompiler.OriginalFeldsparFunctionSignature functionName []) opts +icompileWithInfos_ :: (Compilable t) => t -> String -> Options -> (Module DebugToCSemanticInfo, (String, (Int, Int))) +icompileWithInfos_ prg functionName opts = compileToCWithHeaders_Infos Interactive prg (Precompiler.OriginalFunctionSignature functionName []) opts -incList :: [String] -> String -incList [] = "\n" -incList (x:xs) = "#include " ++ x ++ "\n" ++ (incList xs) +genIncludeLines :: [String] -> (String, Int) +genIncludeLines [] = ("", 1) +genIncludeLines (x:xs) = ("#include " ++ x ++ "\n" ++ str, linenum + 1) where + (str, linenum) = genIncludeLines xs +genHeaders :: Options -> (String, Int) +genHeaders coreOptions = (str ++ "\n\n", linenum + 2) where + (str, linenum) = genIncludeLines (includes $ platform coreOptions) +-- genHeaders coreOptions = (str ++ "#define " ++ defaultArraySizeConstantName ++ " (" ++ (show $ defaultArraySize coreOptions) ++ ")\n\n", linenum + 2) where + -- (str, linenum) = genIncludeLines (includes $ platform coreOptions) + ------------------------ -- Predefined options -- ------------------------ +forPrg = ForType +ifPrg = IfType +assignPrg = AssignType +switchPrg = SwitchType + + defaultOptions = Options { platform = c99 @@ -142,59 +134,49 @@ , defaultArraySize = 16 } -c99Options = defaultOptions - -tic64xPlatformOptions - = defaultOptions { platform = tic64x } - -unrollOptions - = defaultOptions { unroll = Unroll 8 } - -noSimplification - = defaultOptions { debug = NoSimplification } - -noPrimitiveInstructionHandling - = defaultOptions { debug = NoPrimitiveInstructionHandling } +c99PlatformOptions = defaultOptions +tic64xPlatformOptions = defaultOptions { platform = tic64x } +unrollOptions = defaultOptions { unroll = Unroll 8 } +noPrimitiveInstructionHandling = defaultOptions { debug = NoPrimitiveInstructionHandling } -- =========================================================================== -- == Plugin system -- =========================================================================== -pluginChain :: ExternalInfoCollection -> Procedure InitSemInf -> Procedure PrettyPrintSemanticInfo +pluginChain :: ExternalInfoCollection -> Module () -> Module () pluginChain externalInfo - = (executePlugin PrettyPrint (prettyPrintExternalInfo externalInfo)) --- . (executePlugin ConstantFolding ()) + = (executePlugin AllocationEliminator ()) + . (executePlugin TypeDefinitionGenerator (typeDefinitionGeneratorExternalInfo externalInfo)) + . (executePlugin ConstantFolding ()) . (executePlugin UnrollPlugin (unrollExternalInfo externalInfo)) . (executePlugin Precompilation (precompilationExternalInfo externalInfo)) - . (executePlugin ForwardPropagation (forwardPropagationExternalInfo externalInfo)) + . (executePlugin VariableRoleAssigner (variableRoleAssignerExternalInfo externalInfo)) . (executePlugin HandlePrimitives (handlePrimitivesExternalInfo externalInfo)) - . (executePlugin BackwardPropagation (backwardPropagationExternalInfo externalInfo)) - - + . (executePlugin TypeCorrector (typeCorrectorExternalInfo externalInfo)) + . (executePlugin BlockProgramHandler ()) + data ExternalInfoCollection = ExternalInfoCollection { - precompilationExternalInfo :: ExternalInfo Precompilation, - prettyPrintExternalInfo :: ExternalInfo PrettyPrint, - unrollExternalInfo :: ExternalInfo UnrollPlugin, - handlePrimitivesExternalInfo :: ExternalInfo HandlePrimitives, - forwardPropagationExternalInfo :: ExternalInfo ForwardPropagation, - backwardPropagationExternalInfo :: ExternalInfo BackwardPropagation + precompilationExternalInfo :: ExternalInfo Precompilation + , unrollExternalInfo :: ExternalInfo UnrollPlugin + , handlePrimitivesExternalInfo :: ExternalInfo HandlePrimitives + , typeDefinitionGeneratorExternalInfo :: ExternalInfo TypeDefinitionGenerator + , variableRoleAssignerExternalInfo :: ExternalInfo VariableRoleAssigner + , typeCorrectorExternalInfo :: ExternalInfo TypeCorrector } -executePluginChain :: (Reify.Program p) => CompilationMode -> p -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> [Procedure PrettyPrintSemanticInfo] -executePluginChain compilationMode prg originalFeldsparFunctionSignatureParam opt = - Prelude.map (pluginChain ExternalInfoCollection { +executePluginChain :: (Compilable p) => + CompilationMode -> p -> Precompiler.OriginalFunctionSignature -> Options -> Module () +executePluginChain compilationMode prg originalFunctionSignatureParam opt = + (pluginChain ExternalInfoCollection { precompilationExternalInfo = PrecompilationExternalInfo { - originalFeldsparFunctionSignature = originalFeldsparFunctionSignatureParam, - graphInputInterfaceType = interfaceInputType $ hierGraphInterface hierarchicalGraph, - numberOfFunctionArguments = Reify.numArgs (mkT prg), + originalFunctionSignature = originalFunctionSignatureParam, + inputParametersDescriptor = buildInParamDescriptor prg, + numberOfFunctionArguments = numArgs prg, compilationMode = compilationMode - }, - prettyPrintExternalInfo = (platform opt, defaultArraySize opt), - unrollExternalInfo = unroll opt, - handlePrimitivesExternalInfo = (defaultArraySize opt, debug opt, platform opt), - forwardPropagationExternalInfo = debug opt, - backwardPropagationExternalInfo = debug opt - }) - (graphToImperative hierarchicalGraph) - where - hierarchicalGraph = replaceNoInlines $ makeHierarchical $ reify prg + } + , unrollExternalInfo = unroll opt + , handlePrimitivesExternalInfo = (defaultArraySize opt, debug opt, platform opt) + , typeDefinitionGeneratorExternalInfo = opt + , variableRoleAssignerExternalInfo = () + , typeCorrectorExternalInfo = False + }) $ fromCore "PLACEHOLDER" prg diff --git a/Feldspar/Compiler/CompilerMain.hs b/Feldspar/Compiler/CompilerMain.hs deleted file mode 100644 --- a/Feldspar/Compiler/CompilerMain.hs +++ /dev/null @@ -1,242 +0,0 @@ --- --- Copyright (c) 2009-2010, 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 Main where - -import Feldspar.Compiler.Precompiler.Precompiler -import qualified Feldspar.Compiler.Compiler as CompilerCore -import qualified Feldspar.Compiler.Options as CoreOptions -import qualified Feldspar.Compiler.Standalone.Options as StandaloneOptions -import Feldspar.Compiler.Standalone.Constants -import Feldspar.Compiler.Standalone.Library as StandaloneLib - -import System.Exit -import System.Environment -import System.IO -import System.Process -import System.Info -import System.Directory - -import Control.Monad -import Control.Monad.Error -import Control.Monad.CatchIO -import Control.Exception - -import Data.List -import System.Console.GetOpt -import System.Console.ANSI -import System.FilePath - -import Language.Haskell.Interpreter - -serializeOriginalFeldsparFunctionSignature originalFeldsparFunctionSignature = - "(OriginalFeldsparFunctionSignature \"" ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ - "\" " ++ (show $ originalFeldsparParameterNames originalFeldsparFunctionSignature) ++ ")" - -generateCompileCode :: String -> String -> CoreOptions.Options -> OriginalFeldsparFunctionSignature -> String -generateCompileCode inputFileName outputFileName coreOptions originalFeldsparFunctionSignature = - "standaloneCompile " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ - " \"" ++ inputFileName ++ "\" " ++ " \"" ++ outputFileName ++ "\" " ++ - (serializeOriginalFeldsparFunctionSignature originalFeldsparFunctionSignature) ++ - " (Options " ++ - "{ platform = " ++ (CoreOptions.name $ CoreOptions.platform coreOptions) ++ - ", unroll = " ++ (show $ CoreOptions.unroll coreOptions) ++ - ", debug = " ++ (show $ CoreOptions.debug coreOptions) ++ - ", defaultArraySize = " ++ (show $ CoreOptions.defaultArraySize coreOptions) ++ - "})" - -compileFunction :: String -> String -> CoreOptions.Options -> OriginalFeldsparFunctionSignature -> Interpreter () -compileFunction inFileName outFileName options originalFeldsparFunctionSignature = do - iPutStr $ StandaloneLib.rpadWith 50 '.' $ - "Compiling function " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) - --result <- catchError ( interpret (generateCompileCode outputFileName options functionName) (as::IO()) ) (\_->error "error") - result <- interpret (generateCompileCode inFileName outFileName options originalFeldsparFunctionSignature) (as::IO()) - lift result - liftIO $ withColor Green (putStrLn "[OK]") - -compileAllFunctions :: String -> String -> CoreOptions.Options -> [OriginalFeldsparFunctionSignature] -> Interpreter () -compileAllFunctions inFileName outFileName options [] = return() -compileAllFunctions inFileName outFileName options (x:xs) = do - (catchError (compileFunction inFileName outFileName options x) - (const $ liftIO $ withColor Red (putStrLn "[FAILED]"))) - `Control.Monad.CatchIO.catch` - (\msg -> liftIO $ withColor Red $ putStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)) - compileAllFunctions inFileName outFileName options xs - -buildIncludeString :: [String] -> String -buildIncludeString includes = concatMap (\x -> "#include " ++ x ++ "\n") includes - -includeGeneration :: FilePath -> CoreOptions.Options -> IO () -includeGeneration fileName coreOptions - = appendFile fileName $ buildIncludeString (CoreOptions.includes $ CoreOptions.platform coreOptions) - --- | Interpreter body for single-function compilation -singleFunctionCompilationBody :: String -> String -> CoreOptions.Options -> OriginalFeldsparFunctionSignature -> Interpreter (IO ()) -singleFunctionCompilationBody inFileName outFileName coreOptions originalFeldsparFunctionSignature = do - iPutStrLn $ "Output file: " ++ outFileName - iPutStrLn $ "Compiling function " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ "..." - liftIO $ includeGeneration outFileName coreOptions - -- iPutStrLn $ generateCompileCode inFileName outFileName coreOptions originalFeldsparFunctionSignature - result <- interpret (generateCompileCode inFileName outFileName coreOptions originalFeldsparFunctionSignature) (as::IO()) - return result - --- | Interpreter body for multi-function compilation -multiFunctionCompilationBody :: String -> String -> CoreOptions.Options -> [OriginalFeldsparFunctionSignature] -> Interpreter (IO ()) -multiFunctionCompilationBody inFileName outFileName coreOptions declarationList = do - iPutStrLn $ "Output file: " ++ outFileName - liftIO $ includeGeneration outFileName coreOptions - compileAllFunctions inFileName outFileName coreOptions declarationList - return(return()) - --- | A general interpreter body for interpreting an expression -generalInterpreterBody :: String -- ^ the expression to interpret - -> Interpreter (IO ()) -generalInterpreterBody expression = do - result <- interpret expression (as::IO()) - return result - --- | A high-level interface for calling the interpreter -highLevelInterpreter :: String -- ^ the module name (for example My.Module) - -> String -- ^ the input file name (for example "My/Module.hs") - -> Interpreter (IO ()) -- ^ an interpreter body - -> IO () -highLevelInterpreter moduleName inputFileName interpreterBody = do - actionToExecute <- runInterpreter $ do - set [ languageExtensions := (glasgowExtensions ++ - [NoMonomorphismRestriction, OverlappingInstances, Rank2Types, UndecidableInstances]) ] - iPutStrLn $ "Loading module " ++ moduleName ++ "..." -#ifdef RELEASE - loadModules [inputFileName] -- globalImportList modules are package modules and shouldn't be loaded, only imported -#else - loadModules $ [inputFileName] ++ globalImportList -- in normal mode, we need to load them before importing them -#endif - setTopLevelModules [moduleName] - setImports globalImportList - interpreterBody - either printInterpreterError id actionToExecute - - -printGhcError (GhcError {errMsg=s}) = putStrLn s - -printInterpreterError :: InterpreterError -> IO () -printInterpreterError (WontCompile []) = return() -printInterpreterError (WontCompile (x:xs)) = do - printGhcError x - printInterpreterError (WontCompile xs) -printInterpreterError e = putStrLn $ "Code generation failed: " ++ (show e) - --- | Calculates the output file name. -convertOutputFileName :: String -> Maybe String -> String -convertOutputFileName inputFileName maybeOutputFileName = case maybeOutputFileName of - Nothing -> takeFileName $ replaceExtension inputFileName ".c" -- remove takeFileName to return the full path - Just overriddenFileName -> overriddenFileName - -main = do - args <- getArgs - - when (length args == 0) (do - putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors - exitWith ExitSuccess) - - -- Parse options, getting a list of option actions - let (actions, nonOptions, errors) = getOpt Permute StandaloneOptions.optionDescriptors args - - when (length errors > 0) (do - putStrLn $ concat errors - putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors - exitWith (ExitFailure 1)) - - -- Here we thread startOptions through all supplied option actions - opts <- foldl (>>=) (return StandaloneOptions.startOptions) actions - - when (length nonOptions /= 1) (do - putStrLn "ERROR: Exactly one input file expected." - exitWith (ExitFailure 1)) - - let StandaloneOptions.Options { - StandaloneOptions.optSingleFunction = functionMode - , StandaloneOptions.optOutputFileName = maybeOutputFileName - , StandaloneOptions.optDotGeneration = dotGeneration - , StandaloneOptions.optDotFileName = dotFileName - , StandaloneOptions.optCompilerMode = compilerMode } = opts - let inputFileName = head nonOptions -- change it for multi-file operation - let outputFileName = convertOutputFileName inputFileName maybeOutputFileName - - compilationCore functionMode inputFileName outputFileName opts dotGeneration dotFileName compilerMode - -compilationCore functionMode inputFileName outputFileName commandLineOptions dotGeneration dotFileName compilerMode = do - putStrLn $ "Starting the Standalone Feldspar Compiler..." - -- -- -- Input file preparations -- -- -- - removeFile (replaceExtension inputFileName ".hi") `Prelude.catch` (const $ return()) - removeFile (replaceExtension inputFileName ".o" ) `Prelude.catch` (const $ return()) - -- -- -- Output file preparations -- -- -- - renameFile outputFileName (outputFileName ++ ".bak") `Prelude.catch` (const $ return()) - -- -- -- -- -- -- - fileDescriptor <- openFile inputFileName ReadMode - fileContents <- hGetContents fileDescriptor - putStrLn $ "Parsing source file with the precompiler..." - let declarationList = getExtendedDeclarationList fileContents - let moduleName = getModuleName fileContents - - let highLevelInterpreterWithModuleInfo = highLevelInterpreter moduleName inputFileName - - -- Dot generation - case commandLineOptions of - StandaloneOptions.Options { StandaloneOptions.optDotGeneration = True} -> do - putStrLn "Dot generation enabled" - case functionMode of - StandaloneOptions.SingleFunction funName -> case dotFileName of - Just fileName -> highLevelInterpreterWithModuleInfo - (generalInterpreterBody $ "writeDot \"" ++ fileName ++ "\" " ++ funName) - Nothing -> highLevelInterpreterWithModuleInfo - (generalInterpreterBody $ "putStr $ fs2dot " ++ funName) - StandaloneOptions.MultiFunction -> - putStrLn $ "ERROR: Dot generation requested, but not supported in multi-function mode\n"++ - "(use the \"-f function\" option to enable single-function mode)" - _ -> putStrLn "Dot generation disabled" - - -- C code generation - case functionMode of - StandaloneOptions.MultiFunction - | length declarationList == 0 -> putStrLn "Multi-function mode: Nothing to do." - | otherwise -> do - if length declarationList > 1 - then putStrLn $ "Multi-function mode, compiling " ++ (show $ length declarationList) ++ " functions..." - else putStrLn $ "Multi-function mode, compiling the only function (" ++ (originalFeldsparFunctionName $ head declarationList) ++ ")..." - highLevelInterpreterWithModuleInfo (multiFunctionCompilationBody inputFileName outputFileName compilerMode declarationList) - StandaloneOptions.SingleFunction funName -> do - putStrLn $ "Single-function mode, compiling function " ++ funName ++ "..." - let originalFeldsparFunctionSignatureNeeded = case filter ((==funName).originalFeldsparFunctionName) declarationList of - [a] -> a - [] -> error $ "Function " ++ funName ++ " not found" - _ -> error "Unexpected error SC/01" - highLevelInterpreterWithModuleInfo - (singleFunctionCompilationBody inputFileName outputFileName compilerMode originalFeldsparFunctionSignatureNeeded) - - diff --git a/Feldspar/Compiler/Error.hs b/Feldspar/Compiler/Error.hs --- a/Feldspar/Compiler/Error.hs +++ b/Feldspar/Compiler/Error.hs @@ -1,34 +1,6 @@ --- --- Copyright (c) 2009-2010, 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 +data ErrorClass = InvariantViolation | InternalError | Warning deriving (Show, Eq) handleError :: String -> ErrorClass -> String -> a diff --git a/Feldspar/Compiler/Frontend/CommandLine/API.hs b/Feldspar/Compiler/Frontend/CommandLine/API.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Frontend/CommandLine/API.hs @@ -0,0 +1,59 @@ +module Feldspar.Compiler.Frontend.CommandLine.API where + +import Feldspar.Compiler.Frontend.CommandLine.API.Library +import Feldspar.Compiler.Backend.C.Library +import System.IO +import Language.Haskell.Interpreter +import qualified Data.Typeable as T + +data CompilationResult + = CompilationSuccess + | CompilationFailure + deriving (Eq, Show, T.Typeable) + + -- 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 load global modules? + -> Bool -- need to import global modules qualified? + -> Interpreter (IO a) -- ^ an interpreter body + -> IO CompilationResult +highLevelInterpreter moduleName inputFileName importList needGlobal needQualify interpreterBody = do + actionToExecute <- runInterpreter $ do + set [ languageExtensions := [GADTs, ScopedTypeVariables, TypeSynonymInstances, StandaloneDeriving, + DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + FunctionalDependencies, ExistentialQuantification, Rank2Types, TypeOperators, + EmptyDataDecls, GeneralizedNewtypeDeriving, TypeFamilies] + ] + loadModules $ [inputFileName] ++ if needGlobal 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 diff --git a/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs b/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Frontend/CommandLine/API/Constants.hs @@ -0,0 +1,12 @@ +module Feldspar.Compiler.Frontend.CommandLine.API.Constants where + +globalImportList = ["Feldspar.Compiler.Compiler"] + +warningPrefix = "[WARNING]: " +errorPrefix = "[ERROR ]: " + +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" diff --git a/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs b/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Frontend/CommandLine/API/Library.hs @@ -0,0 +1,36 @@ +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 + +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 diff --git a/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs b/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Frontend/CommandLine/API/Options.hs @@ -0,0 +1,112 @@ +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 FunctionMode = SingleFunction String | MultiFunction + +data Options = Options { optSingleFunction :: FunctionMode + , optOutputFileName :: Maybe String + , optCompilerMode :: CompilerCoreOptions.Options + } + +-- | Default options +startOptions :: Options +startOptions = Options { optSingleFunction = MultiFunction + , optOutputFileName = Nothing + , optCompilerMode = CompilerCore.defaultOptions + } + +-- | Option descriptions for getOpt +optionDescriptors :: [ OptDescr (Options -> IO Options) ] +optionDescriptors = + [ Option "f" ["singlefunction"] + (ReqArg + (\arg opt -> return opt { optSingleFunction = SingleFunction arg }) + "FUNCTION") + "Enables single-function compilation" + + , Option "o" ["output"] + (ReqArg + (\arg opt -> return opt { optOutputFileName = Just arg }) + "outputfile.c") + "Overrides the file name 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 "a" ["defaultArraySize"] + (ReqArg + (\arg opt -> return opt { + optCompilerMode = (optCompilerMode opt) { + CompilerCoreOptions.defaultArraySize = parseInt arg "Invalid default array size" + } + }) + "") + "Overrides default array size" + + , 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Frontend/CommandLine/Main.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE CPP #-} +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 qualified 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.ANSI +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 -> Int -> OriginalFunctionSignature + -> Interpreter ((String, Either (Module ()) CompilationError), Int) +compileFunction inFileName outFileName coreOptions linenum originalFunctionSignature = do + let functionName = originalFunctionName originalFunctionSignature + (SomeCompilable prg) <- interpret ("SomeCompilable " ++ functionName) (as::SomeCompilable) + let compilationUnit = executePluginChain Standalone prg originalFunctionSignature { + originalFunctionName = fixFunctionName $ originalFunctionName 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 (cCode, (resultLinenum, resultCol)) = compToC ((coreOptions, Declaration_pl), linenum) compilationUnit + Control.Exception.finally (hPutStrLn temph cCode) + (do hClose temph + removeFileIfPossible tempfile) + return $ ((functionName, Left compilationUnit), resultLinenum) + return result + +compileAllFunctions :: String -> String -> CoreOptions.Options -> Int -> [OriginalFunctionSignature] + -> Interpreter [(String, Either (Module ()) CompilationError)] +compileAllFunctions inFileName outFileName options linenum [] = return [] +compileAllFunctions inFileName outFileName options linenum (x:xs) = do + let functionName = originalFunctionName x + (compilationUnit, resultLinenum) <- (catchError (compileFunction inFileName outFileName options linenum x) + (\(e::InterpreterError) -> return $ ((functionName, Right $ InterpreterError e), linenum))) + `Control.Monad.CatchIO.catch` + (\msg -> return $ ((functionName, + Right $ InternalErrorCall $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)), + linenum)) + result <- compileAllFunctions inFileName outFileName options (resultLinenum + 1) xs + return $ compilationUnit : result + +-- | Interpreter body for single-function compilation +singleFunctionCompilationBody :: String -> String -> CoreOptions.Options -> OriginalFunctionSignature + -> Interpreter (IO CompilationResult) +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 CompilationSuccess + +mergeCompilationUnits :: [Module ()] -> Module () +mergeCompilationUnits [] = handleError "Standalone" InvariantViolation "Called mergeCompilationUnits with an empty list" +mergeCompilationUnits [x] = x +mergeCompilationUnits l@(x:xs) = Module { + definitions = nub $ definitions x ++ (definitions $ mergeCompilationUnits 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 CompilationResult) +multiFunctionCompilationBody inFileName outFileName coreOptions declarationList = do + let (headers, linenum) = genHeaders coreOptions + liftIO $ appendFile outFileName $ headers + compilationUnits <- compileAllFunctions inFileName outFileName coreOptions linenum declarationList + liftIO $ do + mapM writeErrors compilationUnits + withColor Blue $ putStrLn "\n================= [ Summary of compilation results ] =================\n" + mapM writeSummary compilationUnits + let mergedCompilationUnits = mergeCompilationUnits $ filterLefts compilationUnits + (appendFile outFileName $ fst $ compToC ((coreOptions, Declaration_pl), linenum) mergedCompilationUnits) + `Control.Exception.catch` + (\msg -> withColor Red $ putStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)) + return $ return CompilationSuccess + +-- | Calculates the output file name. +convertOutputFileName :: String -> Maybe String -> String +convertOutputFileName inputFileName maybeOutputFileName = case maybeOutputFileName of + Nothing -> takeFileName $ replaceExtension inputFileName ".c" -- remove takeFileName to return the full path + Just overriddenFileName -> overriddenFileName + +removeFileIfPossible :: String -> IO () +removeFileIfPossible filename = removeFile filename `Prelude.catch` (const $ return()) + +fancyWrite :: String -> IO () +fancyWrite s = do + withColor Blue $ putStr "=== [ " + withColor Cyan $ putStr $ rpad 70 s + withColor Blue $ putStrLn " ] ===" + +main = do + args <- getArgs + + when (length args == 0) (do + putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors + exitWith ExitSuccess) + + -- Parse options, getting a list of option actions + let (actions, nonOptions, errors) = getOpt Permute StandaloneOptions.optionDescriptors args + + when (length errors > 0) (do + putStrLn $ concat errors + putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors + exitWith (ExitFailure 1)) + + -- Here we thread startOptions through all supplied option actions + opts <- foldl (>>=) (return StandaloneOptions.startOptions) actions + + when (length nonOptions /= 1) (do + putStrLn "ERROR: Exactly one input file expected." + exitWith (ExitFailure 1)) + + let StandaloneOptions.Options { + StandaloneOptions.optSingleFunction = functionMode + , StandaloneOptions.optOutputFileName = maybeOutputFileName + , StandaloneOptions.optCompilerMode = compilerMode } = opts + let inputFileName = replace (head nonOptions) "\\" "/" -- change it for multi-file operation + let outputFileName = convertOutputFileName inputFileName maybeOutputFileName + + -- -- -- Input file preparations -- -- -- + removeFileIfPossible $ replaceExtension inputFileName ".hi" + removeFileIfPossible $ replaceExtension inputFileName ".o" + -- -- -- Output file preparations -- -- -- + renameFile outputFileName (outputFileName ++ ".bak") `Prelude.catch` (const $ return()) + -- -- -- -- -- -- + fileDescriptor <- openFile inputFileName ReadMode + fileContents <- hGetContents fileDescriptor + + let declarationList = getExtendedDeclarationList fileContents + let moduleName = getModuleName fileContents + fancyWrite $ "Compilation target: module " ++ moduleName + fancyWrite $ "Output file: " ++ outputFileName + +#ifdef RELEASE + let needGlobal = False -- globalImportList modules are package modules and shouldn't be loaded, only imported +#else + let needGlobal = True -- in normal mode, we need to load them before importing them +#endif + + let highLevelInterpreterWithModuleInfo body = + highLevelInterpreter moduleName inputFileName globalImportList needGlobal False body + + -- C code generation + case functionMode of + StandaloneOptions.MultiFunction + | length declarationList == 0 -> putStrLn "No functions to compile." + | otherwise -> do + fancyWrite $ "Number of functions to compile: " ++ (show $ length declarationList) + highLevelInterpreterWithModuleInfo + (multiFunctionCompilationBody inputFileName outputFileName compilerMode declarationList) + return () + StandaloneOptions.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 compilerMode originalFunctionSignatureNeeded) + return () + + diff --git a/Feldspar/Compiler/Imperative/CodeGeneration.hs b/Feldspar/Compiler/Imperative/CodeGeneration.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/CodeGeneration.hs +++ /dev/null @@ -1,341 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Imperative.CodeGeneration where - -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Imperative.Semantics -import Feldspar.Compiler.Error -import Feldspar.Compiler.Options - -import qualified Data.List as List (last,find) - ------------------------- --- C code generation -- ------------------------- - -codeGenerationError = handleError "CodeGeneration" - -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) - -compToC :: ToC a => Platform -> a -> String -compToC m = toC m Declaration_pl - -class ToC a where - toC :: Platform -> Place -> a -> String - -instance ToC Type where - toC m _ t = case (List.find (\(t',_,_) -> t == t') $ types m) of - Just (_,s,_) -> s - Nothing -> codeGenerationError InternalError $ "Unhandled type in platform " ++ name m - --arraytype handled in variable - -instance ToC (Variable PrettyPrintSemanticInfo) where - toC m p a@(Variable r t n _) = show_variable m p r t n NoRestrict - -show_variable :: Platform -> Place -> VariableRole -> Type -> String -> IsRestrict -> String -show_variable m p r t n restr = listprint (id) " " [variableType, show_name r p t n ++ arrLn] --concat [addSpace $ variableType, show_name r p t n, arrLn] - where - (variableType,arrLn) = show_type p t restr - show_type :: Place -> Type -> IsRestrict -> (String,String) - show_type MainParameter_pl (ImpArrayType s t@(ImpArrayType s2 t2)) restr = decl_matr_type s t2 s2 restr - show_type Declaration_pl (ImpArrayType s t) restr = decl_arr_type t s ("","") - show_type MainParameter_pl (ImpArrayType s t) restr = decl_arr_type_0 t s restr - show_type Declaration_pl t _ = (toC m p t,"") - show_type MainParameter_pl t _ = (toC m p t,"") - show_type _ _ _ = ("","") - - decl_arr_type_0 :: Type -> Length -> IsRestrict -> (String,String) - decl_arr_type_0 t s Restrict = ((toC m Declaration_pl t) ++ " * const restrict", "") - decl_arr_type_0 t s _ = ((toC m Declaration_pl t) ++ " *", "") - - decl_matr_type :: Length -> Type -> Length -> IsRestrict -> (String,String) - decl_matr_type mb t2 s2 Restrict = decl_arr_type t2 s2 (" (* const restrict", ")") - decl_matr_type mb t2 s2 _ = decl_arr_type t2 s2 (" (*", ")") - - decl_arr_type :: Type -> Length -> (String,String) -> (String,String) - decl_arr_type (ImpArrayType s2 t2) mb (st1,st2) = decl_arr_type t2 s2 (st1,st2 ++ (show_brackets mb)) - decl_arr_type t mb (st1,st2) = ((toC m Declaration_pl t) ++ st1, st2 ++ show_brackets mb) - - show_brackets :: Length -> String - show_brackets Undefined = codeGenerationError InternalError $ "Unattended unknown array size" - show_brackets (Norm i) = concat["[",show i,"]"] - show_brackets (Defined i) = concat["[", show i, defaultArraySizeWarning, "]"] - - defaultArraySizeWarning :: String - defaultArraySizeWarning = " /* WARNING: Default size used!! */" - - show_name :: VariableRole -> Place-> Type -> String -> String - show_name _ FunctionCallIn_pl t@(ImpArrayType _ _) n = concat["&(",n,genIndex t,")"] - show_name _ AddressNeed_pl t@(ImpArrayType _ _) n = concat["&(",n,genIndex t,")"] - show_name _ _ (ImpArrayType _ _) n = n - show_name Value place t n - | place == AddressNeed_pl = "&" ++ n - | otherwise = n - show_name FunOut place t n - | place == AddressNeed_pl && List.last n == ']' = "&" ++ n - | place == AddressNeed_pl && List.last n /= ']' = n - | place == Declaration_pl = codeGenerationError InternalError $ "You can't declare output variable of the function" - | place == MainParameter_pl = "* " ++ n - | List.last n == ']' = n - | otherwise = "(* " ++ n ++ ")" - - genIndex :: Type -> String - genIndex (ImpArrayType _ t) = "[0]" ++ genIndex t - genIndex _ = "" - -instance ToC (Constant PrettyPrintSemanticInfo) where - toC m p c = toC m p $ constantData c - -instance ToC (ConstantData PrettyPrintSemanticInfo) where - toC m p a@(ArrayConstant l) = "{" ++ (toCArray m p a) ++ "}" - toC m _ c = case (List.find (\(t',_) -> t' == typeof c) $ values m) of - Just (_,f) -> f c - Nothing -> case c of - (IntConstant i) -> show (intConstantValue i) - (FloatConstant i) -> show (floatConstantValue i) ++ "f" - (BoolConstant (BoolConstantType True _)) -> "1" - (BoolConstant (BoolConstantType False _)) -> "0" - _ -> codeGenerationError InternalError $ "Unhandled constant in platform " ++ name m - -toCArray :: Platform -> Place -> ConstantData PrettyPrintSemanticInfo -> String -toCArray m p (ArrayConstant l) = listprint (toCArray m p) "," (map constantData $ arrayConstantValue l) -toCArray m p i = toC m p i - -instance ToC (LeftValue PrettyPrintSemanticInfo) where - toC m p lv = toC m p $ leftValueData lv - -instance ToC (LeftValueData PrettyPrintSemanticInfo) where - toC m p (VariableLeftValue v) = toC m p v - toC m p (ArrayElemReferenceLeftValue leftArrayElemReference) = toC m p $ insertIndex (arrayName leftArrayElemReference) where - insertIndex :: LeftValue PrettyPrintSemanticInfo -> LeftValue PrettyPrintSemanticInfo - insertIndex (LeftValue (VariableLeftValue variable) semInf) = LeftValue (VariableLeftValue $ - variable { - variableType = decrArrayDepth (variableType variable), - variableName = (concat[variableName variable,"[", - toC m ValueNeed_pl (arrayIndex leftArrayElemReference), "]"]) - }) semInf - insertIndex (LeftValue (ArrayElemReferenceLeftValue leftArrayElemReference) semInf) = LeftValue ( - ArrayElemReferenceLeftValue $ leftArrayElemReference { - arrayName = (insertIndex (arrayName leftArrayElemReference)), - arrayIndex = (arrayIndex leftArrayElemReference) - }) semInf -instance ToC (ActualParameter PrettyPrintSemanticInfo) where - toC m p ap = toC m p $ actualParameterData ap - -instance ToC (ActualParameterData PrettyPrintSemanticInfo) where - toC m p (InputActualParameter e) = toC m FunctionCallIn_pl e - toC m p (OutputActualParameter l) = toC m AddressNeed_pl l - -instance ToC (Expression PrettyPrintSemanticInfo) where - toC m p expr = toC m p (expressionData expr) - -instance ToC (ExpressionData PrettyPrintSemanticInfo) where - toC m p (LeftValueExpression lv) = toC m p lv - toC m p (ConstantExpression c) = toC m p c - toC m p (FunctionCallExpression (FunctionCall InfixOp _ f [a,b] _)) = concat["(",toC m p a," ",f," ",toC m p b,")"] - toC m p (FunctionCallExpression (FunctionCall _ t f x _)) = concat [f,"(",listprint (toC m p) ", " x,")"] - -instance ToC (Procedure PrettyPrintSemanticInfo) where - toC m p (Procedure n il ol pr semInf) = concat ["void ",n,"(",param,")\n{\n",prog,"}\n"] - where - param = listprint (toC m MainParameter_pl) ", " (il ++ ol) - prog = ind (toC m Declaration_pl) pr - -instance ToC (Block PrettyPrintSemanticInfo) where - toC m p (Block d pr semInf) = listprint id "\n" [decl,toC m p pr] - where - decl = concat $ map (\a->toC m Declaration_pl a ++ ";\n") d - -instance ToC (FormalParameter PrettyPrintSemanticInfo) where - toC m p (FormalParameter v restr) = (helper p v restr) - where - helper :: Place -> Variable PrettyPrintSemanticInfo -> IsRestrict -> String - helper MainParameter_pl (Variable r t n _) restr - = show_variable m MainParameter_pl r t n restr - helper _ (Variable r t n _) restr - = show_variable m Declaration_pl r t n restr - -instance ToC (LocalDeclaration PrettyPrintSemanticInfo) where - toC m p (LocalDeclaration v i isDefArrSize) = (helper p v i) - where - helper :: Place -> Variable PrettyPrintSemanticInfo -> (Maybe (Expression PrettyPrintSemanticInfo)) -> String - helper MainParameter_pl v i = concat [toC m MainParameter_pl v,init i] - helper _ v i = concat [toC m Declaration_pl v,init i] - init :: Maybe (Expression PrettyPrintSemanticInfo) -> String - init Nothing = "" - init (Just e) = " = " ++ toC m ValueNeed_pl e - -instance ToC (Instruction PrettyPrintSemanticInfo) where - toC m p instruction = toC m p $ instructionData instruction - -instance ToC (InstructionData PrettyPrintSemanticInfo) where - toC m p (AssignmentInstruction assignment) = - concat [toC m ValueNeed_pl (assignmentLhs assignment)," = ",toC m ValueNeed_pl (assignmentRhs assignment),";\n"] - toC m p (ProcedureCallInstruction procedureCall) = - concat [nameOfProcedureToCall procedureCall,"(", - listprint (toC m p) ", " (actualParametersOfProcedureToCall procedureCall),");\n"] - -instance ToC (Program PrettyPrintSemanticInfo) where - toC m p (Program (EmptyProgram (Empty i)) seminf) = "" - toC m p (Program (PrimitiveProgram (Primitive i seminf)) psi) = toC m p i - toC m p (Program (SequenceProgram (Sequence ps _)) psi) = listprint (toC m p) "" ps - toC m p (Program (BranchProgram (Branch con tPrg ePrg _)) psi) - = concat ["if(",toC m ValueNeed_pl con,")\n{\n", ind (toC m p) tPrg,"}\nelse\n{\n",ind (toC m p) ePrg,"}\n"] - toC m p (Program (SequentialLoopProgram (SequentialLoop condVar condCalc loopBody _)) psi) = concat["{\n",ind id whereBody,"}\n"] - where - whereBody = concat [toC m p condCalc,"while(",toC m ValueNeed_pl condVar,")\n", - "{\n",ind (toC m p) loopBody,ind (toC m p) (blockInstructions condCalc),"}\n"] - toC m p (Program (ParallelLoopProgram (ParallelLoop v num step prg _)) psi) = concat ["{\n",ind id for_seq,"}\n"] - where - for_seq = concat [toC m Declaration_pl v,";\nfor(",for_init,for_test,for_inc,")\n{\n",ind (toC m p) prg,"}\n"] - for_init = concat [toC m ValueNeed_pl v," = 0; "] - for_test = concat [toC m ValueNeed_pl v," < ",toC m ValueNeed_pl num,"; "] - for_inc = concat [toC m ValueNeed_pl v," += ",show step] - -instance ToC a => ToC (Maybe a) where - toC _ p Nothing = "" - toC m p (Just a) = toC m p a - -instance (ToC a) => ToC [a] where - toC m p xs = listprint (toC m p) "\n" xs - ----------------------- --- Type -- ----------------------- - -class HasType a where - typeof :: a -> Type - -instance (SemanticInfo t) => HasType (Variable t) where - typeof (Variable r t s _) = t - -instance (SemanticInfo t) => HasType (LeftValue t) where - typeof lv = typeof $ leftValueData lv - -instance (SemanticInfo t) => HasType (LeftValueData t) where - typeof (VariableLeftValue v) = typeof v - typeof (ArrayElemReferenceLeftValue arrayElemReference) = - decrArrayDepth (typeof (arrayName arrayElemReference)) - -instance (SemanticInfo t) => HasType (Constant t) where - typeof c = typeof $ constantData c - -instance (SemanticInfo t) => HasType (ConstantData t) where - typeof (IntConstant _) = Numeric ImpSigned S32 - typeof (FloatConstant _) = FloatType - typeof (BoolConstant _) = BoolType - typeof arr@(ArrayConstant l) = ImpArrayType (Norm $ length innerConstList) elemtype - where - elemtype = case innerConstList of - [] -> codeGenerationError InternalError $ "Const array with 0 elements: " ++ show arr - _ -> checktype (typeof $ head innerConstList) (map typeof innerConstList) - innerConstList = arrayConstantValue l - checktype :: Type -> [Type] -> Type - checktype t [] = t - checktype t (x:xs) - | t == x = checktype t xs - | otherwise = codeGenerationError InternalError $ "Different element types in constant array: " ++ show arr - -instance (SemanticInfo t) => HasType (Expression t) where - typeof e = typeof $ expressionData e - -instance (SemanticInfo t) => HasType (ExpressionData t) where - typeof (LeftValueExpression lve) = typeof lve - typeof (ConstantExpression c) = typeof c - typeof (FunctionCallExpression functionCallExpression) = typeOfFunctionToCall functionCallExpression - -instance (SemanticInfo t) => HasType (ActualParameter t) where - typeof ap = typeof $ actualParameterData ap - -instance (SemanticInfo t) => HasType (ActualParameterData t) where - typeof (InputActualParameter e) = typeof e - typeof (OutputActualParameter l) = typeof l - ----------------------- --- 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:y:xs) = x ++ s ++ listprint' s (y:xs) - -parameterToExpression :: (SemanticInfo t) => ActualParameter t -> Expression t -parameterToExpression (ActualParameter (InputActualParameter e) _) = e -parameterToExpression (ActualParameter (OutputActualParameter lv) _) = Expression (LeftValueExpression lv) undefined -- TODO undefined - -decrArrayDepth :: Type -> Type -decrArrayDepth (ImpArrayType _ t) = t -decrArrayDepth _ = codeGenerationError InternalError $ "A variable is indexed, but not array!" - -simpleType :: Type -> Bool -simpleType BoolType = True -simpleType (Numeric _ _) = True -simpleType FloatType = True -simpleType (ImpArrayType _ _) = False -simpleType (UserType _) = True - -toLeftValue :: (SemanticInfo t) => Expression t -> LeftValue t -toLeftValue (Expression (LeftValueExpression lv) _) = lv -toLeftValue e = codeGenerationError InternalError $ show e ++ " is not a left value." - -contains :: (SemanticInfo t) => String -> Expression t -> Bool -contains n (Expression (LeftValueExpression lv) _) = contains' n (leftValueData lv) where - contains' n (VariableLeftValue (Variable _ _ n' _) ) = n == n' - contains' n (ArrayElemReferenceLeftValue arrayElemReference) = contains' n (leftValueData $ arrayName arrayElemReference) || - contains n (arrayIndex arrayElemReference) -contains _ (Expression (ConstantExpression _) _) = False -contains n (Expression (FunctionCallExpression functionCallExpression) _)= - any (contains n) (actualParametersOfFunctionToCall functionCallExpression) - -getVarName :: (SemanticInfo t) => LeftValue t -> String -getVarName (LeftValue (VariableLeftValue ( Variable _ _ n _ )) _) = n -getVarName (LeftValue (ArrayElemReferenceLeftValue arrayElemReference) _) = getVarName (arrayName arrayElemReference) diff --git a/Feldspar/Compiler/Imperative/FromCore.hs b/Feldspar/Compiler/Imperative/FromCore.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/FromCore.hs @@ -0,0 +1,576 @@ +{-# LANGUAGE OverlappingInstances, PatternGuards, UndecidableInstances #-} +module Feldspar.Compiler.Imperative.FromCore + ( + Compilable(..) + , numArgs + , fromCore + ) where + +import Control.Monad.State +import Control.Monad.Writer + +import Data.List +import Data.String +import Data.Bits + +import qualified Feldspar.DSL.Expression as Lang +import qualified Feldspar.DSL.Lambda as Lang +import Feldspar.DSL.Lambda hiding (Value, Variable) +import Feldspar.DSL.Network +import Feldspar.Set (universal) +import qualified Feldspar.Core.Types as Lang +import Feldspar.Core.Representation hiding (variable) +import qualified Feldspar.Core.Representation as Lang +import qualified Feldspar.Core.Functions.Array as Lang +import qualified Feldspar.Core.Functions.Tuple as Lang +import Feldspar.Core.Functions.Num () +import Feldspar.Range (Range(..),BoundedInt) +import Data.Typeable (Typeable, typeOf) + +import Feldspar.Compiler.Imperative.Representation hiding (blockProgram) +import Feldspar.Compiler.Imperative.Frontend +import Feldspar.Compiler.Backend.C.CodeGeneration +import Feldspar.Compiler.Error +import Feldspar.Compiler.Backend.C.Library + +type Transformer a = StateT Integer (Writer [Definition ()]) a + +-- | Path of a matching variable +type Path = [Int] + +type MultiVar = [(Path, Lang.TypeRep)] + +indexType :: Type +indexType = NumType Unsigned S32 + +-- | Where to place the result of a single-edge +data SingleLoc a + = Shifted (Expression (), FeldNetwork (Out ()) Lang.Length) (SingleLoc a) + -- ^ A shifted location + | SingleLoc + { singleLV :: Expression () + , feedback :: FeldNetwork (Out ()) a + } + -- ^ A location represented by a 'LeftValue ()' and a corresponding + -- expression. The expression is used for feedback. + +-- | Container of a SingleLoc +getSingleLV :: SingleLoc a -> Expression () +getSingleLV (SingleLoc lv _) = lv +getSingleLV (Shifted _ sl) = getSingleLV sl + +-- | Where to place the result of a general program +data Location ra a + where + S :: { single :: SingleLoc a } -> Location (Out ()) a + M :: { multi :: Ident } -> Location ra a + +-- | Append a path to an identifier +pathIdent :: Ident -> Path -> Ident +pathIdent ident path = concat $ intersperse "_" $ (ident :) $ map show path + +toSingle :: Type -> Location (Out ()) a -> SingleLoc a +toSingle typ (S loc) = loc +toSingle typ (M ident) = SingleLoc expr fb + where + expr = varExpr $ variable ident typ + fb = Lang.Variable ident + +getIx :: Lang.Type a + => FeldNetwork (Out ()) [a] + -> FeldNetwork (Out ()) Lang.Index + -> FeldNetwork (Out ()) a +getIx a ix + = undoEdge + $ unData + $ Lang.getIx (fromOutEdge universal a) (fromOutEdge universal ix) + -- TODO Think about size + +addExpr + :: FeldNetwork (Out ()) Lang.DefaultWord + -> FeldNetwork (Out ()) Lang.DefaultWord + -> FeldNetwork (Out ()) Lang.DefaultWord +addExpr a b = undoEdge $ unData (fromOutEdge universal a + fromOutEdge universal b) + -- TODO Think about size + +add :: Expression () -> Expression () -> Expression () +add a b = FunctionCall "(+)" indexType InfixOp [a,b] () () + +indexLocSingle + :: Lang.Type a + => [(Expression (), FeldNetwork (Out ()) Lang.Length)] -- ^ Accumulated shifts + -> SingleLoc [a] -- ^ Original location + -> Expression () -- ^ Index variable + -> FeldNetwork (Out ()) Lang.Index -- ^ Index expression + -> SingleLoc a +indexLocSingle ls (Shifted l loc) ixVar ixExpr = + indexLocSingle (l:ls) loc ixVar ixExpr +indexLocSingle ls (SingleLoc lv fb) ixVar ixExpr = SingleLoc lv' fb' + where + lv' = arrayElem lv $ foldl add ixVar (map fst ls) + ixExpr' = foldl addExpr ixExpr (map snd ls) + fb' = getIx fb ixExpr' + +-- | Sum the shifts of a shifted location +sumShifts :: SingleLoc a -> Expression () +sumShifts (SingleLoc _ _) = createConstantExpression $ intConst 0 +sumShifts (Shifted (e,_) l) = add e $ sumShifts l + +-- | Indexing into a location +indexLoc + :: Lang.Type a + => SingleLoc [a] -- ^ Original location + -> Expression () -- ^ Index variable + -> FeldNetwork (Out ()) Lang.Index -- ^ Index expression + -> SingleLoc a +indexLoc loc ixVar ixExpr = indexLocSingle [] loc ixVar ixExpr + +selectFst :: (Lang.Type a, Lang.Type b) + => SingleLoc (a,b) + -> SingleLoc a +selectFst (SingleLoc e fb) = SingleLoc (StructField e member () ()) fb' + where + member = fst $ head $ s + (StructType s) = typeof e + fb' = undoEdge $ unData $ Lang.getFst $ fromOutEdge universal fb + +selectSnd :: (Lang.Type a, Lang.Type b) + => SingleLoc (a,b) + -> SingleLoc b +selectSnd (SingleLoc e fb) = SingleLoc (StructField e member () ()) fb' + where + member = fst $ head $ tail $ s + (StructType s) = typeof e + fb' = undoEdge $ unData $ Lang.getSnd $ fromOutEdge universal fb + +locToNode :: Location (Out ra) a -> FeldNetwork (Out ra) a +locToNode (S (SingleLoc _ fb)) = fb +locToNode (M ident) = Lang.Variable ident + -- TODO Ingoring shift + +multiVarIn :: FeldNetwork (In ra) a -> MultiVar +multiVarIn = listEdge $ \path a -> (path, edgeType (edgeInfo a)) + +simpleExpr :: Expression () -> Transformer ([Program ()], Expression ()) +simpleExpr expr = return ([],expr) + +isComplex :: FeldNetwork (Out ra) a -> Bool +isComplex (Inject (Node Condition) :$: _ :$: _ :$: _) = True +isComplex (Inject (Node Parallel) :$: _ :$: _ :$: _) = True +isComplex (Inject (Node Sequential) :$: _ :$: _ :$: _ :$: _) = True +isComplex (Inject (Node ForLoop) :$: _ :$: _ :$: _) = True +isComplex (Inject (Node (NoInline _)) :$: _ :$: _) = True +isComplex (Inject (Node SetLength) :$: _ :$: _) = True +isComplex (Inject (Node Pair) :$: _ :$: _) = True +isComplex (Inject (Node SetIx) :$: _ :$: _ :$: _) = True +isComplex a = isArrayLit a + +genLiteralExpression :: + Lang.Type a => a -> Transformer ([Program ()], Expression ()) +genLiteralExpression = simpleExpr . flip ConstExpr () . compileDataRep . Lang.dataRep + +genVarExpression :: + Type -> FeldNetwork (Out ()) a -> Transformer ([Program ()], Expression ()) +genVarExpression typ a = simpleExpr (varExpr var) + where + Just ident = traceVar a + var = variable (pathIdent ident $ matchPath a) typ + +genApplyExpression + :: Type -> String -> FeldNetwork (In ra) a + -> Transformer ([Program ()], Expression ()) +genApplyExpression typ fun a = do + (progs,exprs) <- liftM unzip $ sequence $ listEdge (const genExpressionIn) a + return (concat progs, FunctionCall fun typ SimpleFun exprs () ()) + +-- | Generate an expression that is not a literal, function call or a variable +genComplexExpression :: + Type -> FeldNetwork (Out ()) a -> Transformer ([Program ()], Expression ()) +genComplexExpression typ a = do + ident <- newName "w" + let var = variable ident typ + decl = Declaration var Nothing () + prog <- genNode (M ident) a + return ([BlockProgram (block [decl] prog) ()], VarExpr var ()) + +genExpressionIn + :: FeldNetwork (In ()) a + -> Transformer ([Program ()], Expression ()) +genExpressionIn a = genExpression typ (undoEdge a) + where + typ = compileTypeRep $ edgeType $ edgeInfo a + + + +-- | Generate an expression plus support code +genExpression + :: Type + -> FeldNetwork (Out ()) a + -> Transformer ([Program ()], Expression ()) + +genExpression _ a@(Inject (Node (Literal lit))) + | not (isArrayLit a) = genLiteralExpression lit + +genExpression typ (Inject (Node (Function fun _)) :$: a) = + genApplyExpression typ fun a + +genExpression typ a + | Just _ <- traceVar a = genVarExpression typ a + +genExpression typ (Inject m :$: _) + | isMatch m = localError InvariantViolation "matching on non-variable" + +genExpression typ a = genComplexExpression typ a + + + +genDeclarations :: Ident -> MultiVar -> [Declaration ()] + -- TODO Would be nice to have (Out ra) +genDeclarations ident vars = + [ Declaration var Nothing () + | (path,typ) <- vars + , let ident' = pathIdent ident path + , let var = variable ident' $ compileTypeRep typ + ] + +genMultiCopy :: MultiVar -> Location ra a -> Location rb a -> [Program ()] +genMultiCopy [(_,typ)] (S (SingleLoc lv _)) (M rIdent) = [copyProg lv rhs] + where + rhs = varExpr $ variable rIdent $ compileTypeRep typ +genMultiCopy _ (S (SingleLoc lhs _)) (S (SingleLoc rhs _)) = [copyProg lhs rhs] +genMultiCopy vars (M ident) (M rIdent) = + [ copyProg (varExpr lVar) (varExpr rVar) + | (path,typ) <- vars + , let ident' = pathIdent ident path + , let rIdent' = pathIdent rIdent path + , let typ' = compileTypeRep typ + , let lVar = variable ident' typ' + , let rVar = variable rIdent' typ' + ] + -- TODO Ingoring shift +genMultiCopy [(_,typ)] (M ident) (S (SingleLoc rhs _)) = [copyProg lhs rhs] + where + lhs = varExpr $ variable ident $ compileTypeRep typ + + +-- | Generate code for a 'Let' expression +genLet + :: ([Program ()] -> FeldNetwork ra a -> Transformer b) + -- ^ Generator for the body + -> FeldNetwork ra a + -> Transformer b +genLet gen (Let base :$: a :$: Lambda f) = do + aIdent <- newName base + aProg <- genNode (M aIdent) a + let aBlock = block (genDeclarations aIdent (resTypes a)) aProg + letProg = f (Lang.Variable aIdent) + gen [BlockProgram aBlock ()] letProg + +genNodeExpression :: + SingleLoc a -> Type -> FeldNetwork (Out ()) a -> Transformer [Program ()] +genNodeExpression loc typ a = do + (prog,rhs) <- genExpression typ a + return $ prog ++ case loc of + SingleLoc l _ -> [copyProg l rhs] + l@(Shifted _ _) -> [copyProgPos (getSingleLV l) (sumShifts l) rhs] + +genNodeSingle + :: SingleLoc a + -> Type + -> FeldNetwork (Out ()) a + -> Transformer [Program ()] +genNodeSingle loc _ a | isComplex a = genNode (S loc) a +genNodeSingle loc typ a = genNodeExpression loc typ a + + + +-- | TODO network must be a 'Node' or a (nested) 'Let' resulting in a 'Node' +genNode :: forall ra a + . Location ra a + -> FeldNetwork ra a -- TODO Would be nice to have (Out ra) + -> Transformer [Program ()] + +genNode loc a | isLet a = genLet genBody a + where + genBody letProg body = liftM (letProg++) $ genNode loc body + +genNode loc (Inject (Node Condition) :$: cond :$: t :$: e) = do + (condProg,condExpr) <- genExpressionIn cond + thenProg <- genEdge loc t + elseProg <- genEdge loc e + let branchProg = Branch condExpr (block [] thenProg) (block [] elseProg) () () + return (condProg ++ [branchProg]) + +genNode loc a@(Inject (Node Parallel) :$: len :$: Lambda ixf :$: cont) = do + (lenProg,lenExpr) <- genExpressionIn len + ixIdent <- newName "i" + let bodyExpr = ixf (Lang.Variable ixIdent) + ixVar = variable ixIdent indexType + ixExpr = Lang.Variable ixIdent + loc' = toSingle typ loc + locBody = indexLoc loc' (varExpr ixVar) ixExpr + locCont = Shifted (lenExpr, undoEdge len) loc' + setLen = case loc' of + SingleLoc _ _ -> setLength (singleLV loc') lenExpr + Shifted _ l -> increaseLength (getSingleLV l) lenExpr + bodyProg <- genEdge (S locBody) bodyExpr + contProg <- genEdge (S locCont) cont + return (lenProg ++ [setLen,ParLoop ixVar lenExpr 1 (block [] bodyProg) () ()] ++ contProg) + -- TODO Should use \"default size\" for index type + where + [(_, Lang.ArrayType _ t)] = resTypes a + typ = compileTypeRep t + +genNode loc a@(Inject (Node Sequential) :$: len :$: init :$: Lambda step :$: Lambda cont) = do + (lenProg,lenExpr) <- genExpressionIn len + stepIdent <- newName "x" + let stIdent = stepIdent ++ "_2" + tempIdent <- newName "temp" + ixIdent <- newName "i" + initProg <- genEdge (M stIdent) init + let step' = step (Lang.Variable ixIdent) + stepExpr = shallowApply step' (Lang.Variable stIdent) + tempVarElem = variable (tempIdent ++ "_1") elemTyp + ixVar = variable ixIdent indexType + ixExpr = Lang.Variable ixIdent + loc' = toSingle arrTyp loc + locElem = indexLoc loc' (varExpr ixVar) ixExpr + locCont = Shifted (lenExpr, undoEdge len) loc' + tempDeclElem = genDeclarations tempIdent [([1],tElem)] + tempDeclsSt = genDeclarations (tempIdent ++ "_2") (multiVarIn init) + stDecls = genDeclarations stIdent (multiVarIn init) + elemCopy = copyProg (singleLV locElem) (varExpr tempVarElem) + stCopy = genMultiCopy (multiVarIn init) (M stIdent) (M $ tempIdent ++ "_2") + apa = cont (Lang.Variable stIdent) + setLen = setLength (singleLV loc') lenExpr + stepProg <- genEdge (M tempIdent) stepExpr + contProg <- genEdge (S locCont) apa + return $ + [BlockProgram (block stDecls (initProg ++ lenProg ++ [setLen, ParLoop ixVar lenExpr 1 (block (tempDeclElem++tempDeclsSt) (stepProg ++ stCopy ++ [elemCopy])) () ()] ++ contProg)) ()] + where + [(_, tArr@(Lang.ArrayType _ tElem))] = resTypes a + arrTyp = compileTypeRep tArr + elemTyp = compileTypeRep tElem + +genNode loc a@(Inject (Node ForLoop) :$: len :$: init :$: Lambda body) = do + (lenProg,lenExpr) <- genExpressionIn len + tempIdent <- newName "temp" + ixIdent <- newName "i" + initProg <- genEdge loc init + let body' = body (Lang.Variable ixIdent) + bodyExpr = shallowApply body' (locToNode loc) + ixVar = variable ixIdent indexType + tempDecls = genDeclarations tempIdent (resTypes a) + bodyProg <- genEdge (M tempIdent) bodyExpr + let copyProg = genMultiCopy (resTypes a) loc (M tempIdent) + return [BlockProgram (block tempDecls (lenProg ++ initProg ++ [ParLoop ixVar lenExpr 1 (block [] (bodyProg ++ copyProg)) () ()])) ()] + +genNode (S (Shifted _ _)) a@(Inject (Node (Literal _))) | isArrayLit a && isEmpty a = return [] + +genNode loc a@(Inject (Node (Literal b))) | isArrayLit a = return [initialize (getSingleLV l) (sumShifts l) v] + where + l = toSingle typ loc + v = compileDataRep $ Lang.dataRep b + typ = compileTypeRep $ Lang.typeRep' b + +genNode loc a@(Inject (Node (NoInline name)) :$: Lambda body :$: x) = do + param <- newName "in" + result <- newName "out" + prolog <- sequence $ listEdge (const genExpressionIn) x + let prologProgs = concatMap fst prolog + prologArgs = map (flip In () . snd) prolog + argVars = genVars param x + resVars = genVars result (body $ Lang.Variable param) + outArgs = map (flip Out ()) $ genLocExprs loc a + + prog <- genEdge (M result) (body $ Lang.Variable param) + + tell [procedure name argVars resVars (block [] prog)] + return $ prologProgs ++ [procedureCall name prologArgs outArgs] + where + typ = undefined + nodeType = compileTypeRep . snd . head . resTypes + +genNode (S loc) (Inject (Node SetLength) :$: len :$: (Inject (Edge edge) :$: a)) + | not (isComplex a), Just name <- traceVar a = do + (lenProg,lenExpr) <- genExpressionIn len + let typ = compileTypeRep $ edgeType edge + let arrProg = [copyProgLen (singleLV loc) (varExpr $ createVariable name typ) lenExpr] + return $ lenProg ++ arrProg + +genNode (S loc) a@(Inject (Node SetLength) :$: len :$: arr) = do + (lenProg,lenExpr) <- genExpressionIn len + arrProg <- genEdge (S loc) arr + return $ lenProg ++ arrProg ++ [setLength (singleLV loc) lenExpr] + +genNode loc a@(Inject (Node SetIx) :$: ix :$: val :$: e) = do + (ixProg,ixExpr) <- genExpressionIn ix + copy <- genEdge loc e + let + updLoc = indexLoc (toSingle elemType loc) ixExpr $ undoEdge ix + update <- genEdge (S updLoc) val + return $ copy ++ ixProg ++ update + where + [(_, (Lang.ArrayType _ tElem))] = resTypes a + elemType = compileTypeRep tElem + +genNode loc a@(Inject (Node Pair) :$: x :$: y) = do + prog1 <- genEdge (S $ selectFst $ toSingle (nodeType a) loc) x + prog2 <- genEdge (S $ selectSnd $ toSingle (nodeType a) loc) y + return $ prog1 ++ prog2 + where + nodeType = compileTypeRep . snd . head . resTypes + +genNode loc a@(Inject (Node (Literal _))) = genNodeSingle (toSingle (nodeType a) loc) (nodeType a) a + where + nodeType = compileTypeRep . snd . head . resTypes + +genNode loc a@(Inject (Node (Function _ _)) :$: _) = genNodeSingle (toSingle (nodeType a) loc) (nodeType a) a + where + nodeType = compileTypeRep . snd . head . resTypes + +genLocExprs :: Location ra a -> FeldNetwork ra a -> [Expression ()] +genLocExprs (S loc) _ = [singleLV loc] +genLocExprs (M ident) a = + [ varExpr $ variable (pathIdent ident path) (compileTypeRep typ) + | (path,typ) <- resTypes a + ] + + +viewGroup2 :: FeldNetwork (In (ra,rb)) (a,b) -> (FeldNetwork (In ra) a, FeldNetwork (In rb) b) +viewGroup2 (Inject Group2 :$: a :$: b) = (a,b) + -- TODO: Move somewhere else + + + +genEdgeSingle + :: Ident + -> Path + -> FeldNetwork (In ()) a + -> Transformer [Program ()] +genEdgeSingle ident path a = + genNodeSingle (toSingle typ $ M ident') typ (undoEdge a) + where + ident' = pathIdent ident path + typ = compileTypeRep $ edgeType $ edgeInfo a + +-- | Generate code for a multi-edge +genEdge :: Location (Out ra) a -> FeldNetwork (In ra) a -> Transformer [Program ()] +genEdge loc a | isLet a = genLet genBody a + where + genBody letProg body = liftM (letProg++) $ genEdge loc body +genEdge loc (Inject (Edge edge) :$: a) = genNodeSingle (toSingle typ loc) typ a + where + typ = compileTypeRep $ edgeType edge +genEdge (M ident) a = liftM concat $ sequence $ listEdge (genEdgeSingle ident) a + +-- | Generate a variable of the same type as the given single-edge +genVar :: Ident -> Path -> FeldNetwork (In ()) a -> Variable () +genVar ident path a = variable (pathIdent ident path) typ + where + typ = compileTypeRep $ edgeType $ edgeInfo a + +genVars :: Ident -> FeldNetwork (In ra) a -> [Variable ()] +genVars ident (Let _ :$: a :$: Lambda f) = + genVars ident (f (Lang.Variable "TODO")) +genVars ident a = listEdge (genVar ident) a + + + +class Compilable t where + toImperativeM + :: String -- ^ Name of procedure + -> [Variable ()] -- ^ Free variables + -> t -- ^ Program to compile + -> Transformer () + + -- | Returns a list containing the number of edges in each curried argument + buildInParamDescriptor :: t -> [Int] + +instance Syntactic a => Compilable a where + toImperativeM procName freeVars prog = do + ident <- newName "out" + body <- genEdge (M ident) prog' + let resVars = genVars ident prog' + tell [Procedure procName freeVars resVars (block [] body) () ()] + where + prog' = feldSharing (toEdge prog) + + buildInParamDescriptor _ = [] + +instance (Syntactic a, Compilable t) => Compilable (a -> t) where + toImperativeM procName freeVars prog = do + ident <- newName "in" + let arg = Lang.variable universal ident + let vars = genVars ident (toEdge arg) + toImperativeM procName (freeVars ++ vars) (prog arg) + + buildInParamDescriptor prog = + countEdges (toEdge arg) : buildInParamDescriptor (prog arg) + where + arg = Lang.variable universal "argument" + +numArgs :: Compilable a => a -> Int +numArgs = length . buildInParamDescriptor + +fromCore :: Compilable t => String -> t -> Module () +fromCore procName prog = Module (execWriter $ evalStateT (toImperativeM procName [] prog) 0) () + +initialize :: Expression () -> Expression () -> Constant () -> Program () +initialize loc shift (ArrayConst vs _ _) = createProgramSequence $ + (setLength loc $ shift `add` intConstExpr (toInteger $ length vs)) : + (map (\(v,i) -> initialize (arrayElem loc $ shift `add` i) (intConstExpr 0) v) $ + zip vs $ map intConstExpr [0..]) +initialize loc _ v = copyProg loc $ createConstantExpression v + +-- | Compilation of a data representation to an imperative constant +compileDataRep :: Lang.DataRep -> Constant () +compileDataRep (Lang.BoolData x) = BoolConst x () () +compileDataRep (Lang.IntData x) = IntConst x () () +compileDataRep (Lang.FloatData x) = FloatConst (fromRational $ toRational x) () () +compileDataRep (Lang.ComplexData r i) = ComplexConst (compileDataRep r) (compileDataRep i) () () +compileDataRep (Lang.ArrayData xs) = ArrayConst (map compileDataRep xs) () () +compileDataRep (Lang.StructData sd) = localError InternalError "Struct constants not supported yet." + +-- | Compilation of a type representation to an imperative type +compileTypeRep :: Lang.TypeRep -> Type +compileTypeRep typ = case typ of + Lang.BoolType -> BoolType + Lang.IntType r -> compileNumericType r + Lang.FloatType -> FloatType + Lang.ComplexType typ -> ComplexType (compileTypeRep typ) + Lang.UserType userTypeName -> UserType userTypeName + Lang.ArrayType dim elemTyp -> ArrayType (getLength dim) $ compileTypeRep elemTyp + Lang.StructType memberTypes -> StructType $ zip (map ((defaultMemberName++).show) [1..]) $ map compileTypeRep memberTypes + +-- | Numeric type based on a range +compileNumericType :: (BoundedInt a, Typeable a) => Range a -> Type +compileNumericType r = NumType (intSign r) (intSize r) + +-- | Sign based on a range +intSign :: BoundedInt a => Range a -> Signedness +intSign r + | isSigned (upperBound r) = Signed + | otherwise = Unsigned + +-- | Size based on a range +intSize :: (BoundedInt a, Typeable a) => Range a -> Size +intSize r = case bitSize i of + 8 -> S8 + 16 -> S16 + 32 -> S32 + 64 -> S64 + _ -> localError InvariantViolation $ "unknown integer type: " ++ show (typeOf i) + where + i = upperBound r + +-- | Compilation of a length +getLength :: Range Lang.Length -> Length +getLength l + | u == maxBound = UndefinedLen + | otherwise = LiteralLen (fromIntegral u) + where + u = upperBound l + +-- | Customized error function +localError = handleError "Backends :: C :: ConstTransformation" diff --git a/Feldspar/Compiler/Imperative/Frontend.hs b/Feldspar/Compiler/Imperative/Frontend.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/Frontend.hs @@ -0,0 +1,157 @@ +module Feldspar.Compiler.Imperative.Frontend where + +import Feldspar.Compiler.Imperative.Representation +import qualified Feldspar.Compiler.Imperative.Representation as Representation + +import Feldspar.Core.Types + +-- =========================================================================== +-- == Program generator tools +-- =========================================================================== +emptyPrg :: Program () +emptyPrg = Representation.Empty + { emptyLabel = () + , programLabel = () + } + +genCopy :: Expression () -> Expression () -> Program () +genCopy lhs rhs = ProcedureCall + { procCallName = copy + , procCallParams = + [ In + { inParam = rhs + , actParamLabel = () + } + , Out + { outParam = lhs + , actParamLabel = () + } + ] + , procCallLabel = () + , programLabel = () + } + +createConstantExpression c = ConstExpr + { constExpr = c + , exprLabel = () + } + +createLoopVariable :: String -> Representation.Variable () +createLoopVariable name = Representation.Variable + { varName = name + , varType = NumType Signed S32 + , varRole = Representation.Value + , varLabel = () + } + +createVariable :: String -> Representation.Type -> Representation.Variable () +createVariable name typ = Representation.Variable + { varName = name + , varType = typ -- compileTypeRep typ + , varRole = Representation.Value + , varLabel = () + } + +createVariableLeftValue :: String -> Representation.Type -> Expression () +createVariableLeftValue name typ = VarExpr + { var = createVariable name typ + , exprLabel = () + } + +createProgramSequence :: [Program ()] -> Program () +createProgramSequence programs = Sequence + { sequenceProgs = programs + , sequenceLabel = () + , programLabel = () + } + +createDeclaration :: String -> Representation.Type -> Declaration () +createDeclaration name typ = Declaration + { declVar = createVariable name typ + , initVal = Nothing + , declLabel = () + } + +programToBlock :: Program () -> Block () +programToBlock p = Block + { locals = [] + , blockBody = p + , blockLabel = () + } + +procedure symbol inArgs outArgs block = Procedure symbol inArgs outArgs block () () +procedureCall symbol inArgs outArgs = ProcedureCall symbol (inArgs ++ outArgs) () () +seqLoop cond condcalcblock core = SeqLoop cond condcalcblock core () () +condBranch cond bt be = Branch cond bt be () () +switch cond cases = Switch cond cases () () +switchCase pattern impl = SwitchCase pattern impl () +parLoop index length step block = ParLoop index length step block () () +comment isblockcomment str = Comment isblockcomment str () () +globalVar decl = GlobalVar decl () () + +intConstExpr :: Integer -> Expression () +intConstExpr val = ConstExpr (intConst val) () + +intConstExprConv :: Int -> Expression () +intConstExprConv val = ConstExpr (intConstConv val) () + + +intConst :: Integer -> Constant () +intConst val = IntConst val () () + +intConstConv :: Int -> Constant () +intConstConv val = IntConst (toInteger val) () () + + +functionCall :: String -> Representation.Type -> [Expression ()] -> Expression () +functionCall symbol typ args = FunctionCall symbol typ SimpleFun args () () + +arrayElem :: Expression () -> Expression () -> Expression () +arrayElem lv ix = ArrayElem lv ix () () + +blockProgram :: Block () -> Program () +blockProgram = flip BlockProgram () + +declaration :: Variable () -> Maybe (Expression ()) -> Declaration () +declaration var initval = Declaration var initval () + +varExpr :: Variable () -> Expression () +varExpr var = VarExpr var () + +varActualParam :: Variable () -> (Expression () -> () -> ActualParameter ()) -> ActualParameter () +varActualParam v role = role (varExpr v) () + +block :: [Declaration ()] -> [Program ()] -> Block () +block decls actions = Block decls prog () + where + prog = case actions of + [] -> Empty () () + _ -> Sequence (concatMap act actions) () () + + act (Empty _ _) = [] + act (Sequence seq _ _) = seq + act a = [a] + + +variable :: String -> Representation.Type -> Variable () +variable name typ = Variable name typ Value () + -- Using 'Value' for all variables; the correct role will be set in a later + -- stage + +copy :: String +copy = "copy" + +setLength :: Expression () -> Expression () -> Program () +setLength arr len = procedureCall "setLength" [Out arr ()] [In len ()] + +increaseLength :: Expression () -> Expression () -> Program () +increaseLength arr len = procedureCall "increaseLength" [Out arr ()] [In len ()] + +copyProg :: Expression () -> Expression () -> Program () +copyProg outExp inExp = ProcedureCall copy [Out outExp (), In inExp ()] () () + +copyProgPos :: Expression () -> Expression () -> Expression () -> Program () +copyProgPos outExp shift inExp = ProcedureCall "copyArrayPos" [Out outExp (), In shift (), In inExp ()] () () + +copyProgLen :: Expression () -> Expression () -> Expression () -> Program () +copyProgLen outExp inExp len = ProcedureCall "copyArrayLen" [Out outExp (), In inExp (), In len ()] () () diff --git a/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs b/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/Plugin/ConstantFolding.hs @@ -0,0 +1,40 @@ +{-# 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 funRole f' of + InfixOp -> case funCallName 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 _ _ InfixOp (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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/Plugin/Naming.hs @@ -0,0 +1,133 @@ +{-# 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 Definition where + transform t s d x@(Procedure 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/Plugin/Unroll.hs @@ -0,0 +1,258 @@ +{-# 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 Definition where + type Label UnrollSemInf Definition = () + +instance Annotation UnrollSemInf Struct where + type Label UnrollSemInf Struct = () + +instance Annotation UnrollSemInf StructMember where + type Label UnrollSemInf StructMember = () + +instance Annotation UnrollSemInf Union where + type Label UnrollSemInf Union = () + +instance Annotation UnrollSemInf UnionMember where + type Label UnrollSemInf UnionMember = () + +instance Annotation UnrollSemInf Procedure where + type Label UnrollSemInf Procedure = () + +instance Annotation UnrollSemInf Prototype where + type Label UnrollSemInf Prototype = () + +instance Annotation UnrollSemInf GlobalVar where + type Label UnrollSemInf GlobalVar = () + +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 Switch where + type Label UnrollSemInf Switch = () + +instance Annotation UnrollSemInf SeqLoop where + type Label UnrollSemInf SeqLoop = () + +instance Annotation UnrollSemInf ParLoop where + type Label UnrollSemInf ParLoop = () + +instance Annotation UnrollSemInf SwitchCase where + type Label UnrollSemInf SwitchCase = () + +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 UnionField where + type Label UnrollSemInf UnionField = () + +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 + { funCallName = "+" + , returnType = NumType Signed S32 + , funRole = InfixOp + , funCallParams = + [ result tr + , ConstExpr (IntConst (toInteger $ position x) () ()) () + ] + , 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 --- a/Feldspar/Compiler/Imperative/Representation.hs +++ b/Feldspar/Compiler/Imperative/Representation.hs @@ -1,238 +1,504 @@ --- --- Copyright (c) 2009-2010, 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 TypeFamilies, UndecidableInstances, OverlappingInstances #-} module Feldspar.Compiler.Imperative.Representation where -import Feldspar.Compiler.Imperative.Semantics +-- =============================================================================================== +-- == Class defining semantic information attached to different nodes in the imperative program == +-- =============================================================================================== --- ==================================================================================================== --- == Representation of imperative programs --- ==================================================================================================== -data (SemanticInfo t) => Procedure t = Procedure { - procedureName :: String, - inParameters :: [FormalParameter t], - outParameters :: [FormalParameter t], - procedureBody :: Block t, - procedureSemInf :: ProcedureInfo t -} deriving (Eq, Show) +class Annotation t s where + type Label t s -data (SemanticInfo t) => Block t = Block { - blockDeclarations :: [LocalDeclaration t], - blockInstructions :: Program t, - blockSemInf :: BlockInfo t -} deriving (Eq, Show) +instance Annotation () s where + type Label () s = () -data (SemanticInfo t) => Program t = Program { - programConstruction :: ProgramConstruction t, - programSemInf :: ProgramInfo t -} deriving (Eq, Show) +-- ================================================= +-- == Data stuctures to store imperative programs == +-- ================================================= -data (SemanticInfo t) => ProgramConstruction t = - EmptyProgram (Empty t) - | PrimitiveProgram (Primitive t) - | SequenceProgram (Sequence t) - | BranchProgram (Branch t) - | SequentialLoopProgram (SequentialLoop t) - | ParallelLoopProgram (ParallelLoop t) - deriving (Eq, Show) +data Module t = Module + { definitions :: [Definition t] + , moduleLabel :: Label t Module + } -data (SemanticInfo t) => Empty t = Empty { - emptySemInf :: EmptyInfo t -} deriving (Eq, Show) +deriving instance (ShowLabel t) => Show (Module t) +deriving instance (EqLabel t) => Eq (Module t) -data (SemanticInfo t) => Primitive t = Primitive { - primitiveInstruction :: Instruction t, - primitiveSemInf :: PrimitiveInfo t -} deriving (Eq, Show) +data Definition t + = Struct + { structName :: String + , structMembers :: [StructMember t] + , structLabel :: Label t Struct + , definitionLabel :: Label t Definition + } + | Union + { unionName :: String + , unionMembers :: [UnionMember t] + , unionLabel :: Label t Union + , definitionLabel :: Label t Definition + } + | Procedure + { procName :: String + , inParams :: [Variable t] + , outParams :: [Variable t] + , procBody :: Block t + , procLabel :: Label t Procedure + , definitionLabel :: Label t Definition + } + | Prototype + { protoReturnType :: Type + , protoName :: String + , inParams :: [Variable t] + , outParams :: [Variable t] + , protoLabel :: Label t Prototype + , definitionLabel :: Label t Definition + } + | GlobalVar + { globalVarDecl :: Declaration t + , globalVarDeclLabel :: Label t GlobalVar + , definitionLabel :: Label t Definition + } + -data (SemanticInfo t) => Sequence t = Sequence { - sequenceProgramList :: [Program t], - sequenceSemInf :: SequenceInfo t -} deriving (Eq, Show) +deriving instance (ShowLabel t) => Show (Definition t) +deriving instance (EqLabel t) => Eq (Definition t) -data (SemanticInfo t) => Branch t = Branch { - branchConditionVariable :: Variable t, - thenBlock :: Block t, - elseBlock :: Block t, - branchSemInf :: BranchInfo t -} deriving (Eq, Show) +data StructMember t = StructMember + { structMemberName :: String + , structMemberType :: Type + , structMemberLabel :: Label t StructMember + } -data (SemanticInfo t) => SequentialLoop t = SequentialLoop { - sequentialLoopCondition :: Expression t, - conditionCalculation :: Block t, - sequentialLoopCore :: Block t, - sequentialLoopSemInf :: SequentialLoopInfo t -} deriving (Eq, Show) +data UnionMember t = UnionMember + { unionMemberName :: String + , unionMemberType :: Type + , unionMemberLabel :: Label t UnionMember + } -data (SemanticInfo t) => ParallelLoop t = ParallelLoop { - parallelLoopConditionVariable :: Variable t, - numberOfIterations :: Expression t, - parallelLoopStep :: Int, - parallelLoopCore :: Block t, - parallelLoopSemInf :: ParallelLoopInfo t -} deriving (Eq, Show) -data (SemanticInfo t) => FormalParameter t = FormalParameter { - formalParameterVariable :: Variable t, - formalParameterSemInf :: FormalParameterInfo t -} deriving (Eq, Show) - -data (SemanticInfo t) => LocalDeclaration t = LocalDeclaration { - localVariable :: Variable t, - localInitValue :: Maybe (Expression t), - localDeclarationSemInf :: LocalDeclarationInfo t -} deriving (Eq, Show) - -data (SemanticInfo t) => Expression t = Expression { - expressionData :: ExpressionData t, - expressionSemInf :: ExpressionInfo t -} deriving (Eq, Show) - -data (SemanticInfo t) => ExpressionData t = - LeftValueExpression (LeftValue t) - | ConstantExpression (Constant t) - | FunctionCallExpression (FunctionCall t) - deriving (Eq, Show) - -data (SemanticInfo t) => Constant t = Constant { - constantData :: ConstantData t, - constantSemInf :: ConstantInfo t -} deriving (Eq, Show) - -data (SemanticInfo t) => FunctionCall t = FunctionCall { - roleOfFunctionToCall :: FunctionRole, - typeOfFunctionToCall :: Type, - nameOfFunctionToCall :: String, - actualParametersOfFunctionToCall :: [Expression t], - functionCallSemInf :: FunctionCallInfo t -} deriving (Eq, Show) +deriving instance (ShowLabel t) => Show (StructMember t) +deriving instance (EqLabel t) => Eq (StructMember t) +deriving instance (ShowLabel t) => Show (UnionMember t) +deriving instance (EqLabel t) => Eq (UnionMember t) -data (SemanticInfo t) => LeftValue t = LeftValue { - leftValueData :: LeftValueData t, - leftValueSemInf :: LeftValueInfo t -} deriving (Eq, Show) +data Block t = Block + { locals :: [Declaration t] + , blockBody :: Program t + , blockLabel :: Label t Block + } -data (SemanticInfo t) => LeftValueData t = - VariableLeftValue (Variable t) - | ArrayElemReferenceLeftValue (ArrayElemReference t) - deriving (Eq, Show) +deriving instance (ShowLabel t) => Show (Block t) +deriving instance (EqLabel t) => Eq (Block t) -data (SemanticInfo t) => ArrayElemReference t = ArrayElemReference { - arrayName :: LeftValue t, - arrayIndex :: Expression t, - arrayElemReferenceSemInf :: ArrayElemReferenceInfo t -} deriving (Eq, Show) +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 + } + | Switch + { switchCond :: Expression t + , switchCases :: [SwitchCase t] + , switchLabel :: Label t Switch + , 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 + } -data (SemanticInfo t) => Instruction t = Instruction { - instructionData :: InstructionData t, - instructionSemInf :: InstructionInfo t -} deriving (Eq, Show) +deriving instance (ShowLabel t) => Show (Program t) +deriving instance (EqLabel t) => Eq (Program t) -data (SemanticInfo t) => InstructionData t = - AssignmentInstruction (Assignment t) - | ProcedureCallInstruction (ProcedureCall t) - deriving (Eq, Show) +data SwitchCase t = SwitchCase + { switchCasePattern :: Constant t + , switchCaseImpl :: Block t + , switchCaseLabel :: Label t SwitchCase + } -data (SemanticInfo t) => Assignment t = Assignment { - assignmentLhs :: LeftValue t, - assignmentRhs :: Expression t, - assignmentSemInf :: AssignmentInfo t -} deriving (Eq, Show) +deriving instance (ShowLabel t) => Show (SwitchCase t) +deriving instance (EqLabel t) => Eq (SwitchCase t) -data (SemanticInfo t) => ProcedureCall t = ProcedureCall { - nameOfProcedureToCall :: String, - actualParametersOfProcedureToCall :: [ActualParameter t], - procedureCallSemInf :: ProcedureCallInfo t -} deriving (Eq, Show) +data ActualParameter t + = In + { inParam :: Expression t + , actParamLabel :: Label t ActualParameter + } + | Out + { outParam :: Expression t + , actParamLabel :: Label t ActualParameter + } -data (SemanticInfo t) => ActualParameter t = ActualParameter { - actualParameterData :: ActualParameterData t, - actualParameterSemInf :: ActualParameterInfo t -} deriving (Eq, Show) +deriving instance (ShowLabel t) => Show (ActualParameter t) +deriving instance (EqLabel t) => Eq (ActualParameter t) -data (SemanticInfo t) => ActualParameterData t = - InputActualParameter (Expression t) - | OutputActualParameter (LeftValue t) - deriving (Eq, Show) +data Declaration t = Declaration + { declVar :: Variable t + , initVal :: Maybe (Expression t) + , declLabel :: Label t Declaration + } -data (SemanticInfo t) => ConstantData t = - IntConstant (IntConstantType t) - | FloatConstant (FloatConstantType t) - | BoolConstant (BoolConstantType t) - | ArrayConstant (ArrayConstantType t) - deriving (Eq, Show) +deriving instance (ShowLabel t) => Show (Declaration t) +deriving instance (EqLabel t) => Eq (Declaration t) -data (SemanticInfo t) => IntConstantType t = IntConstantType { - intConstantValue :: Int, - intConstantSemInf :: IntConstantInfo t -} deriving (Eq, Show) +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 + } + | UnionField + { union :: Expression t + , fieldName :: String + , unionFieldLabel :: Label t UnionField + , exprLabel :: Label t Expression + } + | ConstExpr + { constExpr :: Constant t + , exprLabel :: Label t Expression + } + | FunctionCall + { funCallName :: String + , returnType :: Type + , funRole :: FunctionRole + , 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 + } -data (SemanticInfo t) => FloatConstantType t = FloatConstantType { - floatConstantValue :: Float, - floatConstantSemInf :: FloatConstantInfo t -} deriving (Eq, Show) +deriving instance (ShowLabel t) => Show (Expression t) +deriving instance (EqLabel t) => Eq (Expression t) -data (SemanticInfo t) => BoolConstantType t = BoolConstantType { - boolConstantValue :: Bool, - boolConstantSemInf :: BoolConstantInfo t -} deriving (Eq, Show) +data Constant t + = IntConst + { intValue :: Integer + , 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 + } -data (SemanticInfo t) => ArrayConstantType t = ArrayConstantType { - arrayConstantValue :: [Constant t], - arrayConstantSemInf :: ArrayConstantInfo t -} deriving (Eq, Show) +deriving instance (ShowLabel t) => Show (Constant t) +deriving instance (EqLabel t) => Eq (Constant t) -data (SemanticInfo t) => Variable t = Variable { - variableRole :: VariableRole, - variableType :: Type, - variableName :: String, - variableSemInf :: VariableInfo t -} deriving (Eq, Show) +data Variable t = Variable + { varName :: String + , varType :: Type + , varRole :: VariableRole + , varLabel :: Label t Variable + } +deriving instance (ShowLabel t) => Show (Variable t) +deriving instance (EqLabel t) => Eq (Variable t) --- ========================= [ Basic structures ] ============================ +-- ====================== +-- == Basic structures == +-- ====================== -data Length = Norm Int | Defined Int | Undefined +data Length = + LiteralLen Int + | IndirectLen String + | UndefinedLen deriving (Eq,Show) data Size = S8 | S16 | S32 | S40 | S64 deriving (Eq,Show) -data Signedness = ImpSigned | ImpUnsigned +data Signedness = Signed | Unsigned deriving (Eq,Show) -data Type = BoolType | FloatType | Numeric Signedness Size | ImpArrayType Length Type | UserType String +data Type = + VoidType + | BoolType + | BitType + | FloatType + | NumType Signedness Size + | ComplexType Type + | UserType String + | ArrayType Length Type + | StructType [(String, Type)] + | UnionType [(String, Type)] deriving (Eq,Show) - + data FunctionRole = SimpleFun | InfixOp | PrefixOp deriving (Eq,Show) -data VariableRole = Value {- input of main & local -} | FunOut {- output of main -} +data VariableRole = + Value + | Pointer deriving (Eq,Show) + +-- ===================== +-- == Technical types == +-- ===================== + +data Struct t +data Union t +data Procedure t +data Prototype t +data GlobalVar t +data Empty t +data Comment t +data Assign t +data ProcedureCall t +data Sequence t +data Branch t +data Switch t +data SeqLoop t +data ParLoop t +data FunctionCall t +data Cast t +data SizeOf t +data ArrayElem t +data StructField t +data UnionField 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 Definition) + , Show (Label t Struct) + , Show (Label t Union) + , Show (Label t Procedure) + , Show (Label t Prototype) + , Show (Label t GlobalVar) + , Show (Label t StructMember) + , Show (Label t UnionMember) + , 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 Switch) + , Show (Label t SeqLoop) + , Show (Label t ParLoop) + , Show (Label t SwitchCase) + , 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 UnionField) + , 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 Definition) + , Show (Label t Struct) + , Show (Label t Union) + , Show (Label t Procedure) + , Show (Label t Prototype) + , Show (Label t GlobalVar) + , Show (Label t StructMember) + , Show (Label t UnionMember) + , 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 Switch) + , Show (Label t SeqLoop) + , Show (Label t ParLoop) + , Show (Label t SwitchCase) + , 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 UnionField) + , 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 Definition) + , Eq (Label t Struct) + , Eq (Label t Union) + , Eq (Label t Procedure) + , Eq (Label t Prototype) + , Eq (Label t GlobalVar) + , Eq (Label t StructMember) + , Eq (Label t UnionMember) + , 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 Switch) + , Eq (Label t SeqLoop) + , Eq (Label t ParLoop) + , Eq (Label t SwitchCase) + , 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 UnionField) + , 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 Definition) + , Eq (Label t Struct) + , Eq (Label t Union) + , Eq (Label t Procedure) + , Eq (Label t Prototype) + , Eq (Label t GlobalVar) + , Eq (Label t StructMember) + , Eq (Label t UnionMember) + , 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 Switch) + , Eq (Label t SeqLoop) + , Eq (Label t ParLoop) + , Eq (Label t SwitchCase) + , 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 UnionField) + , 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 diff --git a/Feldspar/Compiler/Imperative/Semantics.hs b/Feldspar/Compiler/Imperative/Semantics.hs deleted file mode 100644 --- a/Feldspar/Compiler/Imperative/Semantics.hs +++ /dev/null @@ -1,177 +0,0 @@ --- --- Copyright (c) 2009-2010, 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, EmptyDataDecls, FlexibleContexts #-} -module Feldspar.Compiler.Imperative.Semantics where - -data InitSemInf -data PrettyPrintSemanticInfo - -data IsRestrict = Restrict | NoRestrict - deriving (Show,Eq) - -data IsDefaultArraySize = DefaultArraySize | NoDefaultArraySize - deriving (Show,Eq) - --- ==================================================================================================== --- == Semantic info class --- ==================================================================================================== -class ( - Show(ProcedureInfo t), Eq(ProcedureInfo t), - Show(BlockInfo t), Eq(BlockInfo t), - Show(ProgramInfo t), Eq(ProgramInfo t), - Show(EmptyInfo t), Eq(EmptyInfo t), - Show(PrimitiveInfo t), Eq(PrimitiveInfo t), - Show(SequenceInfo t), Eq(SequenceInfo t), - Show(BranchInfo t), Eq(BranchInfo t), - Show(SequentialLoopInfo t), Eq(SequentialLoopInfo t), - Show(ParallelLoopInfo t), Eq(ParallelLoopInfo t), - Show(FormalParameterInfo t), Eq(FormalParameterInfo t), - Show(LocalDeclarationInfo t), Eq(LocalDeclarationInfo t), - Show(ExpressionInfo t), Eq(ExpressionInfo t), - Show(ConstantInfo t), Eq(ConstantInfo t), - Show(FunctionCallInfo t), Eq(FunctionCallInfo t), - Show(LeftValueInfo t), Eq(LeftValueInfo t), - Show(ArrayElemReferenceInfo t), Eq(ArrayElemReferenceInfo t), - Show(InstructionInfo t), Eq(InstructionInfo t), - Show(AssignmentInfo t), Eq(AssignmentInfo t), - Show(ProcedureCallInfo t), Eq(ProcedureCallInfo t), - Show(ActualParameterInfo t), Eq(ActualParameterInfo t), - Show(IntConstantInfo t), Eq(IntConstantInfo t), - Show(FloatConstantInfo t), Eq(FloatConstantInfo t), - Show(BoolConstantInfo t), Eq(BoolConstantInfo t), - Show(ArrayConstantInfo t), Eq(ArrayConstantInfo t), - Show(VariableInfo t), Eq(VariableInfo t) - ) => SemanticInfo t where - type ProcedureInfo t - type BlockInfo t - type ProgramInfo t - type EmptyInfo t - type PrimitiveInfo t - type SequenceInfo t - type BranchInfo t - type SequentialLoopInfo t - type ParallelLoopInfo t - type FormalParameterInfo t - type LocalDeclarationInfo t - type ExpressionInfo t - type ConstantInfo t - type FunctionCallInfo t - type LeftValueInfo t - type ArrayElemReferenceInfo t - type InstructionInfo t - type AssignmentInfo t - type ProcedureCallInfo t - type ActualParameterInfo t - type IntConstantInfo t - type FloatConstantInfo t - type BoolConstantInfo t - type ArrayConstantInfo t - type VariableInfo t - -instance SemanticInfo () where - type ProcedureInfo () = () - type BlockInfo () = () - type ProgramInfo () = () - type EmptyInfo () = () - type PrimitiveInfo () = () - type SequenceInfo () = () - type BranchInfo () = () - type SequentialLoopInfo () = () - type ParallelLoopInfo () = () - type FormalParameterInfo () = () - type LocalDeclarationInfo () = () - type ExpressionInfo () = () - type ConstantInfo () = () - type FunctionCallInfo () = () - type LeftValueInfo () = () - type ArrayElemReferenceInfo () = () - type InstructionInfo () = () - type AssignmentInfo () = () - type ProcedureCallInfo () = () - type ActualParameterInfo () = () - type IntConstantInfo () = () - type FloatConstantInfo () = () - type BoolConstantInfo () = () - type ArrayConstantInfo () = () - type VariableInfo () = () - -instance SemanticInfo InitSemInf where - type ProcedureInfo InitSemInf = () - type BlockInfo InitSemInf = () - type ProgramInfo InitSemInf = () - type EmptyInfo InitSemInf = () - type PrimitiveInfo InitSemInf = Bool - type SequenceInfo InitSemInf = () - type BranchInfo InitSemInf = () - type SequentialLoopInfo InitSemInf = () - type ParallelLoopInfo InitSemInf = () - type FormalParameterInfo InitSemInf = () - type LocalDeclarationInfo InitSemInf = () - type ExpressionInfo InitSemInf = () - type ConstantInfo InitSemInf = () - type FunctionCallInfo InitSemInf = () - type LeftValueInfo InitSemInf = () - type ArrayElemReferenceInfo InitSemInf = () - type InstructionInfo InitSemInf = () - type AssignmentInfo InitSemInf = () - type ProcedureCallInfo InitSemInf = () - type ActualParameterInfo InitSemInf = () - type IntConstantInfo InitSemInf = () - type FloatConstantInfo InitSemInf = () - type BoolConstantInfo InitSemInf = () - type ArrayConstantInfo InitSemInf = () - type VariableInfo InitSemInf = () - -instance SemanticInfo PrettyPrintSemanticInfo where - type ProcedureInfo PrettyPrintSemanticInfo = () - type BlockInfo PrettyPrintSemanticInfo = () - type ProgramInfo PrettyPrintSemanticInfo = () - type EmptyInfo PrettyPrintSemanticInfo = () - type PrimitiveInfo PrettyPrintSemanticInfo = () - type SequenceInfo PrettyPrintSemanticInfo = () - type BranchInfo PrettyPrintSemanticInfo = () - type SequentialLoopInfo PrettyPrintSemanticInfo = () - type ParallelLoopInfo PrettyPrintSemanticInfo = () - type FormalParameterInfo PrettyPrintSemanticInfo = IsRestrict - type LocalDeclarationInfo PrettyPrintSemanticInfo = () - type ExpressionInfo PrettyPrintSemanticInfo = () - type ConstantInfo PrettyPrintSemanticInfo = () - type FunctionCallInfo PrettyPrintSemanticInfo = () - type LeftValueInfo PrettyPrintSemanticInfo = () - type ArrayElemReferenceInfo PrettyPrintSemanticInfo = () - type InstructionInfo PrettyPrintSemanticInfo = () - type AssignmentInfo PrettyPrintSemanticInfo = () - type ProcedureCallInfo PrettyPrintSemanticInfo = () - type ActualParameterInfo PrettyPrintSemanticInfo = () - type IntConstantInfo PrettyPrintSemanticInfo = () - type FloatConstantInfo PrettyPrintSemanticInfo = () - type BoolConstantInfo PrettyPrintSemanticInfo = () - type ArrayConstantInfo PrettyPrintSemanticInfo = () - type VariableInfo PrettyPrintSemanticInfo = () - diff --git a/Feldspar/Compiler/Imperative/TransformationInstance.hs b/Feldspar/Compiler/Imperative/TransformationInstance.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Imperative/TransformationInstance.hs @@ -0,0 +1,156 @@ +{-# 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 [] Definition, 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 [] UnionMember, Transformable1 t [] Variable, Transformable t Block, Transformable t Declaration, Conversion t Definition, Conversion t Struct, Conversion t Union, Conversion t Procedure, Conversion t Prototype, Conversion t GlobalVar) + => DefaultTransformable t Definition where + defaultTransform t s d (Struct n m inf1 inf2) = Result (Struct n (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where + tr = transform1 t s d m + defaultTransform t s d (Union n m inf1 inf2) = Result (Union n (result1 tr) (convert inf1) $ convert inf2) (state1 tr) (up1 tr) where + tr = transform1 t s d m + defaultTransform t s d (Procedure n i o p inf1 inf2) = Result (Procedure 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 (Prototype r n i o inf1 inf2) = Result (Prototype r n (result1 tr1) (result1 tr2) (convert inf1) $ convert inf2) (state1 tr2) (combine (up1 tr1) (up1 tr2)) where + tr1 = transform1 t s d i + tr2 = transform1 t (state1 tr1) d o + defaultTransform t s d (GlobalVar v inf1 inf2) = Result (GlobalVar (result tr) (convert inf1) $ convert inf2) (state tr) (up tr) where + tr = transform t s d v + +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 (Conversion t UnionMember, Default (Up t)) + => DefaultTransformable t UnionMember where + defaultTransform t s d (UnionMember n typ inf) = Result (UnionMember 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, Transformable1 t [] SwitchCase, Conversion t Program, Conversion t Empty, Conversion t Comment, Conversion t Assign, Conversion t ProcedureCall, Conversion t Sequence, Conversion t Branch, Conversion t Switch, 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 (Switch c cs inf1 inf2) = Result (Switch (result tr1) (result1 tr2) (convert inf1) $ convert inf2) (state1 tr2) (combine (up tr1) (up1 tr2)) where + tr1 = transform t s d c + tr2 = transform1 t (state tr1) d cs + 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 Constant, Transformable t Block, Conversion t SwitchCase) + => DefaultTransformable t SwitchCase where + defaultTransform t s d (SwitchCase c b inf) = Result (SwitchCase (result tr1) (result tr2) $ convert inf) (state tr2) (combine (up tr1) (up tr2)) where + tr1 = transform t s d c + tr2 = transform t (state tr1) 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 UnionField, 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 (UnionField l n inf1 inf2) = Result (UnionField (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 typ rol par inf1 inf2) = Result (FunctionCall f typ rol (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 inf1 inf2) = Result (IntConst c (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/Compiler/Options.hs b/Feldspar/Compiler/Options.hs deleted file mode 100644 --- a/Feldspar/Compiler/Options.hs +++ /dev/null @@ -1,141 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Options where - - -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Imperative.Semantics(IsRestrict, PrettyPrintSemanticInfo) - - - -data Options = - Options - { platform :: Platform - , unroll :: UnrollStrategy - , debug :: DebugOption - , defaultArraySize :: Int - } deriving (Eq, Show) - - -data UnrollStrategy = NoUnroll | Unroll Int - deriving (Eq, Show) - - -data DebugOption = NoDebug | NoSimplification | NoPrimitiveInstructionHandling - deriving (Eq, Show) - - - -data Platform = Platform { - name :: String, - types :: [(Type, String, String)], - values :: [(Type, ShowValue)], - primitives :: [(FeldPrimDesc, Either CPrimDesc TransformPrim)], - includes :: [String], - isRestrict :: IsRestrict -} deriving (Eq, Show) - - -data FeldPrimDesc = FeldPrimDesc { - fName :: String, - inputs :: [TypeDesc] -} deriving (Eq, Show) - - -data CPrimDesc = Op1 { - cOp :: String -} | Op2 { - cOp :: String -} | Fun { - cName :: String, - funPf :: FunPostfixDescr -} | Proc { - cName :: String, - funPf :: FunPostfixDescr -} | Assig - | InvalidDesc - deriving (Eq, Show) - - -data TypeDesc - = AllT - | BoolT - | FloatT - | IntT | IntTS | IntTU | IntTS_ Size | IntTU_ Size | IntT_ Size - | UserT String - deriving (Eq, Show) - - -data FunPostfixDescr = FunPostfixDescr { - useInputs :: Int, - useOutputs :: Int -} deriving (Eq, Show) - -noneFP = FunPostfixDescr 0 0 -firstInFP = FunPostfixDescr 1 0 -firstOutFP = FunPostfixDescr 0 1 - - -type ShowValue = (ConstantData PrettyPrintSemanticInfo -> String) - -instance Eq ShowValue where - (==) _ _ = True - -instance Show ShowValue where - show _ = "<>" - - -type TransformPrim - = FeldPrimDesc - -> [Expression ()] - -> [LeftValue ()] - -> [(CPrimDesc, [Expression ()], [LeftValue ()])] - -instance Eq TransformPrim where - (==) _ _ = True - -instance Show TransformPrim where - show _ = "<>" - - - -machTypes :: TypeDesc -> Type -> Bool -machTypes AllT _ = True -machTypes BoolT BoolType = True -machTypes FloatT FloatType = True -machTypes IntT (Numeric _ _) = True -machTypes IntTS (Numeric ImpSigned _) = True -machTypes IntTU (Numeric ImpUnsigned _) = True -machTypes (IntTS_ s) (Numeric ImpSigned s') = s == s' -machTypes (IntTU_ s) (Numeric ImpUnsigned s') = s == s' -machTypes (IntT_ s) (Numeric _ s') = s == s' -machTypes (UserT s) (UserType s') = s == s' -machTypes _ _ = False - - diff --git a/Feldspar/Compiler/Platforms.hs b/Feldspar/Compiler/Platforms.hs deleted file mode 100644 --- a/Feldspar/Compiler/Platforms.hs +++ /dev/null @@ -1,223 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Platforms - ( availablePlatforms - , c99 - , tic64x - ) where - - -import Feldspar.Compiler.Options -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Imperative.Semantics(IsRestrict(..)) -import Feldspar.Compiler.Imperative.CodeGeneration (typeof) - - - -availablePlatforms :: [Platform] -availablePlatforms = [ c99, tic64x ] - - --- ansiC = Platform "ansiC" undefined [] [] ["\"feldspar.h\""] NoRestrict - - -c99 = Platform { - name = "c99", - types = - [ (Numeric ImpSigned S8, "int8_t", "int8") - , (Numeric ImpSigned S16, "int16_t", "int16") - , (Numeric ImpSigned S32, "int32_t", "int32") - , (Numeric ImpSigned S64, "int64_t", "int64") - , (Numeric ImpUnsigned S8, "uint8_t", "uint8") - , (Numeric ImpUnsigned S16, "uint16_t", "uint16") - , (Numeric ImpUnsigned S32, "uint32_t", "uint32") - , (Numeric ImpUnsigned S64, "uint64_t", "uint64") - , (BoolType, "int", "int") - , (FloatType, "float", "float") - ] , - values = [] , - primitives = - [ (FeldPrimDesc "(==)" [AllT, AllT], Left $ Op2 "==") - , (FeldPrimDesc "(/=)" [AllT, AllT], Left $ Op2 "!=") - , (FeldPrimDesc "(<)" [AllT, AllT], Left $ Op2 "<") - , (FeldPrimDesc "(>)" [AllT, AllT], Left $ Op2 ">") - , (FeldPrimDesc "(<=)" [AllT, AllT], Left $ Op2 "<=") - , (FeldPrimDesc "(>=)" [AllT, AllT], Left $ Op2 ">=") - , (FeldPrimDesc "not" [BoolT], Left $ Op1 "!") - , (FeldPrimDesc "(&&)" [BoolT, BoolT], Left $ Op2 "&&") - , (FeldPrimDesc "(||)" [BoolT, BoolT], Left $ Op2 "||") - - , (FeldPrimDesc "quot" [AllT, AllT], Right optimizedDivide) - , (FeldPrimDesc "rem" [AllT, AllT], Left $ Op2 "%") - , (FeldPrimDesc "(^)" [AllT, AllT], Left $ Fun "pow" firstInFP) - , (FeldPrimDesc "negate" [AllT], Left $ Op1 "-") - , (FeldPrimDesc "abs" [IntTU], Left Assig) - , (FeldPrimDesc "abs" [FloatT], Left $ Fun "fabsf" noneFP) - , (FeldPrimDesc "abs" [AllT], Left $ Fun "abs" firstInFP) - , (FeldPrimDesc "signum" [AllT], Left $ Fun "signum" firstInFP) - , (FeldPrimDesc "(+)" [AllT, AllT], Left $ Op2 "+") - , (FeldPrimDesc "(-)" [AllT, AllT], Left $ Op2 "-") - , (FeldPrimDesc "(*)" [AllT, AllT], Right optimizedMultiply) - , (FeldPrimDesc "(/)" [AllT, AllT], Left $ Op2 "/") - - , (FeldPrimDesc "(.&.)" [IntT, IntT], Left $ Op2 "&") - , (FeldPrimDesc "(.|.)" [IntT, IntT], Left $ Op2 "|") - , (FeldPrimDesc "xor" [IntT, IntT], Left $ Op2 "^") - , (FeldPrimDesc "complement" [IntT], Left $ Op1 "~") - , (FeldPrimDesc "bit" [IntT], Right bitFunToShift) - , (FeldPrimDesc "setBit" [IntT, IntT], Left $ Fun "setBit" firstInFP) - , (FeldPrimDesc "clearBit" [IntT, IntT], Left $ Fun "clearBit" firstInFP) - , (FeldPrimDesc "complementBit" [IntT, IntT], Left $ Fun "complementBit" firstInFP) - , (FeldPrimDesc "testBit" [IntT, IntT], Left $ Fun "testBit" firstInFP) - , (FeldPrimDesc "shiftL" [IntT, IntT], Left $ Op2 "<<") - , (FeldPrimDesc "shiftR" [IntT, IntT], Left $ Op2 ">>") - , (FeldPrimDesc "rotateL" [IntT, IntT], Left $ Fun "rotateL" firstInFP) - , (FeldPrimDesc "rotateR" [IntT, IntT], Left $ Fun "rotateR" firstInFP) - , (FeldPrimDesc "reverseBits" [IntT], Left $ Fun "reverseBits" firstInFP) - , (FeldPrimDesc "bitScan" [IntT], Left $ Fun "bitScan" firstInFP) - , (FeldPrimDesc "bitCount" [IntT], Left $ Fun "bitCount" firstInFP) - , (FeldPrimDesc "bitSize" [IntT], Right bitSizeFunToConst) - , (FeldPrimDesc "isSigned" [IntT], Right isSignedFunToConst) - ] , - includes = ["\"feldspar_c99.h\"", "", ""], - isRestrict = NoRestrict -} - - -tic64x = Platform { - name = "tic64x", - types = - [ (Numeric ImpSigned S8, "char", "char") - , (Numeric ImpSigned S16, "short", "short") - , (Numeric ImpSigned S32, "int", "int") - , (Numeric ImpSigned S40, "long", "long") - , (Numeric ImpSigned S64, "long long","llong") - , (Numeric ImpUnsigned S8, "unsigned char", "uchar") - , (Numeric ImpUnsigned S16, "unsigned short", "ushort") - , (Numeric ImpUnsigned S32, "unsigned", "uint") - , (Numeric ImpUnsigned S40, "unsigned long", "ulong") - , (Numeric ImpUnsigned S64, "unsigned long long", "ullong") - , (BoolType, "int", "int") - , (FloatType, "float", "float") - ] , - values = [] , - primitives = - [ (FeldPrimDesc "abs" [IntTS_ S32], Left $ Fun "_abs" noneFP) - , (FeldPrimDesc "abs" [FloatT], Left $ Fun "_fabsf" noneFP) - , (FeldPrimDesc "rotateL" [IntTU_ S32, IntT], Left $ Fun "_rotl" noneFP) - , (FeldPrimDesc "reverseBits" [IntTU_ S32], Left $ Fun "_bitr" noneFP) - , (FeldPrimDesc "bitCount" [IntTU_ S32], Right optimizedBitCount) - ] - ++ primitives c99, - includes = ["\"feldspar_tic64x.h\"", ""], - isRestrict = Restrict -} - - -optimizedMultiply :: TransformPrim -optimizedMultiply _ [x, y] [o] = case (x,y) of - (_, (Expression (ConstantExpression (Constant (IntConstant _) _)) _)) -> optimizedMultiply' x y - ((Expression (ConstantExpression (Constant (IntConstant _) _)) _), _) -> optimizedMultiply' y x - (_, _) -> [(Op2 "*", [x, y], [o])] - where - optimizedMultiply' int con - | (machTypes IntT $ typeof int) - && (con' >= 0) - && (2 ^ (numberOfTwoPrimeFactors con') == con') - = [ (Op2 "<<", [int, (intToCe $ numberOfTwoPrimeFactors con')], [o]) ] - | (machTypes IntT $ typeof int) - && (con' < 0) - && (2 ^ (numberOfTwoPrimeFactors $ con'*(-1)) == con'*(-1)) - = [ (Op2 "<<", [int, (intToCe $ numberOfTwoPrimeFactors $ con'*(-1))], [o]) - , (Op1 "-", [lToe o], [o]) - ] - | otherwise = [(Op2 "*", [x, y], [o])] - where - con' = ceToInt con - - -optimizedDivide :: TransformPrim -optimizedDivide _ [x, y] [o] = case (x,y) of - (_, (Expression (ConstantExpression (Constant (IntConstant _) _)) _)) -> optimizedDivide' x y - (_, _) -> [(Op2 "/", [x, y], [o])] - where - optimizedDivide' int con - | (machTypes IntT $ typeof int) - && (con' >= 0) - && (2 ^ (numberOfTwoPrimeFactors con') == con') - = [ (Op2 ">>", [int, (intToCe $ numberOfTwoPrimeFactors con')], [o]) ] - | (machTypes IntT $ typeof int) - && (con' < 0) - && (2 ^ (numberOfTwoPrimeFactors $ con'*(-1)) == con'*(-1)) - = [ (Op2 ">>", [int, (intToCe $ numberOfTwoPrimeFactors $ con'*(-1))], [o]) - , (Op1 "-", [lToe o], [o]) - ] - | otherwise = [(Op2 "/", [x, y], [o])] - where - con' = ceToInt con - - -bitFunToShift _ [i] [o] = [ (Op2 "<<", [intToCe 1, i], [o]) ] - - -bitSizeFunToConst :: TransformPrim -bitSizeFunToConst _ [i] [o] = case (typeof i) of - (Numeric _ S8) -> [ (Assig, [intToCe 8], [o]) ] - (Numeric _ S16) -> [ (Assig, [intToCe 16], [o]) ] - (Numeric _ S32) -> [ (Assig, [intToCe 32], [o]) ] - (Numeric _ S40) -> [ (Assig, [intToCe 40], [o]) ] - (Numeric _ S64) -> [ (Assig, [intToCe 64], [o]) ] - - -isSignedFunToConst :: TransformPrim -isSignedFunToConst _ [i] [o] = case (typeof i) of - (Numeric ImpSigned _) -> [ (Assig, [boolToCe True], [o]) ] - (Numeric ImpUnsigned _) -> [ (Assig, [boolToCe False], [o]) ] - - -optimizedBitCount :: TransformPrim -optimizedBitCount _ [i] [o] - = [ (Fun "_bitc4" noneFP, [i], [o]) - , (Fun "_dotpu4" noneFP, [lToe o, intToCe 0x01010101], [o]) - ] - - -numberOfTwoPrimeFactors 2 = 1 -numberOfTwoPrimeFactors x | x `mod` 2 == 0 = (numberOfTwoPrimeFactors $ x `div` 2) + 1 - | otherwise = 0 - - - -ceToInt (Expression (ConstantExpression (Constant (IntConstant (IntConstantType x _)) _)) _) = x -intToCe x = Expression (ConstantExpression $ Constant (IntConstant $ IntConstantType x ()) ()) () -boolToCe x = Expression (ConstantExpression $ Constant (BoolConstant $ BoolConstantType x ()) ()) () - -lToe x = Expression (LeftValueExpression x) () - - diff --git a/Feldspar/Compiler/PluginArchitecture.hs b/Feldspar/Compiler/PluginArchitecture.hs deleted file mode 100644 --- a/Feldspar/Compiler/PluginArchitecture.hs +++ /dev/null @@ -1,1026 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Compiler.PluginArchitecture ( - module Feldspar.Compiler.PluginArchitecture, - module Feldspar.Compiler.Imperative.Representation, - module Feldspar.Compiler.Imperative.Semantics, - module Feldspar.Compiler.PluginArchitecture.DefaultConvert -) where - -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Imperative.Semantics -import Feldspar.Compiler.PluginArchitecture.DefaultConvert - -foldlist :: (Default a, Combine a) => [a] -> a -foldlist ul = case ul of - [] -> defaultValue - otherwise -> foldl combine (head ul) (tail ul) - -convertMaybeList :: Maybe [a] -> [a] -convertMaybeList ul = case ul of - Nothing -> [] - Just x -> x - -convertMaybe :: Maybe a -> [a] -convertMaybe ul = case ul of - Nothing -> [] - Just x -> [x] - - --- ================================================================================================================================== --- == Plugin class --- ================================================================================================================================== - -type Walker t construction = (TransformationPhase t) => t -> Downwards t -> construction (From t) -> (construction (To t), Upwards t) - -class (TransformationPhase t) => Plugin t where - type ExternalInfo t - executePlugin :: t -> ExternalInfo t -> Procedure (From t) -> Procedure (To t) - -class (SemanticInfo (From t), SemanticInfo (To t) - , ConvertAllInfos (From t) (To t) - , Combine (Upwards t), Default (Upwards t)) => TransformationPhase t where - type From t - type To t - type Downwards t - type Upwards t - - executeTransformationPhase :: Walker t Procedure - executeTransformationPhase = walkProcedure - --- ==================================================================================================== --- == Node transformers (downwards-transform-upwards) --- ==================================================================================================== - -- ==================================================================================================== - -- == Node transformers for Procedure - -- ==================================================================================================== - downwardsProcedure :: t -> Downwards t -> Procedure (From t) -> Downwards t - downwardsProcedure self = const - transformProcedure :: t -> Downwards t -> Procedure (From t) -> InfoFromProcedureParts t -> Procedure (To t) - transformProcedure self fromAbove originalProcedure fromBelow = originalProcedure { - inParameters = recursivelyTransformedInParameters fromBelow, - outParameters = recursivelyTransformedOutParameters fromBelow, - procedureBody = recursivelyTransformedProcedureBody fromBelow, - procedureSemInf = convert $ procedureSemInf originalProcedure - } - upwardsProcedure :: t -> Downwards t -> Procedure (From t) -> InfoFromProcedureParts t -> Procedure (To t) -> Upwards t - upwardsProcedure self fromAbove originalProcedure fromBelow transformedProcedure = foldlist ((upwardsInfoFromInParameters fromBelow) ++ (upwardsInfoFromOutParameters fromBelow) ++ [(upwardsInfoFromProcedureBody fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for Block - -- ==================================================================================================== - downwardsBlock :: t -> Downwards t -> Block (From t) -> Downwards t - downwardsBlock self = const - transformBlock :: t -> Downwards t -> Block (From t) -> InfoFromBlockParts t -> Block (To t) - transformBlock self fromAbove originalBlock fromBelow = originalBlock { - blockDeclarations = recursivelyTransformedBlockDeclarations fromBelow, - blockInstructions = recursivelyTransformedBlockInstructions fromBelow, - blockSemInf = convert $ blockSemInf originalBlock - } - upwardsBlock :: t -> Downwards t -> Block (From t) -> InfoFromBlockParts t -> Block (To t) -> Upwards t - upwardsBlock self fromAbove originalBlock fromBelow transformedBlock = foldlist ((upwardsInfoFromBlockDeclarations fromBelow) ++ [(upwardsInfoFromBlockInstructions fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for Program - -- ==================================================================================================== - downwardsProgram :: t -> Downwards t -> Program (From t) -> Downwards t - downwardsProgram self = const - transformProgram :: t -> Downwards t -> Program (From t) -> InfoFromProgramParts t -> Program (To t) - transformProgram self fromAbove originalProgram fromBelow = originalProgram { - programConstruction = recursivelyTransformedProgramConstruction fromBelow, - programSemInf = convert $ programSemInf originalProgram - } - upwardsProgram :: t -> Downwards t -> Program (From t) -> InfoFromProgramParts t -> Program (To t) -> Upwards t - upwardsProgram self fromAbove originalProgram fromBelow transformedProgram = foldlist ([(upwardsInfoFromProgramConstruction fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for Empty(current basetype: ProgramConstruction) - -- ==================================================================================================== - transformEmptyProgramInProgram :: t -> Downwards t -> Empty (From t) -> ProgramConstruction (To t) - transformEmptyProgramInProgram self fromAbove originalEmpty = EmptyProgram $ originalEmpty { - emptySemInf = convert $ emptySemInf originalEmpty - } - upwardsEmptyProgramInProgram :: t -> Downwards t -> Empty (From t) -> ProgramConstruction (To t) -> Upwards t - upwardsEmptyProgramInProgram self fromAbove originalEmpty transformedEmpty = defaultValue - -- ==================================================================================================== - -- == Node transformers for Primitive(current basetype: ProgramConstruction) - -- ==================================================================================================== - downwardsPrimitiveProgramInProgram :: t -> Downwards t -> Primitive (From t) -> Downwards t - downwardsPrimitiveProgramInProgram self = const - transformPrimitiveProgramInProgram :: t -> Downwards t -> Primitive (From t) -> InfoFromPrimitiveParts t -> ProgramConstruction (To t) - transformPrimitiveProgramInProgram self fromAbove originalPrimitive fromBelow = PrimitiveProgram $ originalPrimitive { - primitiveInstruction = recursivelyTransformedPrimitiveInstruction fromBelow, - primitiveSemInf = convert $ primitiveSemInf originalPrimitive - } - upwardsPrimitiveProgramInProgram :: t -> Downwards t -> Primitive (From t) -> InfoFromPrimitiveParts t -> ProgramConstruction (To t) -> Upwards t - upwardsPrimitiveProgramInProgram self fromAbove originalPrimitive fromBelow transformedPrimitive = foldlist ([(upwardsInfoFromPrimitiveInstruction fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for Sequence(current basetype: ProgramConstruction) - -- ==================================================================================================== - downwardsSequenceProgramInProgram :: t -> Downwards t -> Sequence (From t) -> Downwards t - downwardsSequenceProgramInProgram self = const - transformSequenceProgramInProgram :: t -> Downwards t -> Sequence (From t) -> InfoFromSequenceParts t -> ProgramConstruction (To t) - transformSequenceProgramInProgram self fromAbove originalSequence fromBelow = SequenceProgram $ originalSequence { - sequenceProgramList = recursivelyTransformedSequenceProgramList fromBelow, - sequenceSemInf = convert $ sequenceSemInf originalSequence - } - upwardsSequenceProgramInProgram :: t -> Downwards t -> Sequence (From t) -> InfoFromSequenceParts t -> ProgramConstruction (To t) -> Upwards t - upwardsSequenceProgramInProgram self fromAbove originalSequence fromBelow transformedSequence = foldlist ((upwardsInfoFromSequenceProgramList fromBelow)) - -- ==================================================================================================== - -- == Node transformers for Branch(current basetype: ProgramConstruction) - -- ==================================================================================================== - downwardsBranchProgramInProgram :: t -> Downwards t -> Branch (From t) -> Downwards t - downwardsBranchProgramInProgram self = const - transformBranchProgramInProgram :: t -> Downwards t -> Branch (From t) -> InfoFromBranchParts t -> ProgramConstruction (To t) - transformBranchProgramInProgram self fromAbove originalBranch fromBelow = BranchProgram $ originalBranch { - branchConditionVariable = recursivelyTransformedBranchConditionVariable fromBelow, - thenBlock = recursivelyTransformedThenBlock fromBelow, - elseBlock = recursivelyTransformedElseBlock fromBelow, - branchSemInf = convert $ branchSemInf originalBranch - } - upwardsBranchProgramInProgram :: t -> Downwards t -> Branch (From t) -> InfoFromBranchParts t -> ProgramConstruction (To t) -> Upwards t - upwardsBranchProgramInProgram self fromAbove originalBranch fromBelow transformedBranch = foldlist ([(upwardsInfoFromBranchConditionVariable fromBelow)] ++ [(upwardsInfoFromThenBlock fromBelow)] ++ [(upwardsInfoFromElseBlock fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for SequentialLoop(current basetype: ProgramConstruction) - -- ==================================================================================================== - downwardsSequentialLoopProgramInProgram :: t -> Downwards t -> SequentialLoop (From t) -> Downwards t - downwardsSequentialLoopProgramInProgram self = const - transformSequentialLoopProgramInProgram :: t -> Downwards t -> SequentialLoop (From t) -> InfoFromSequentialLoopParts t -> ProgramConstruction (To t) - transformSequentialLoopProgramInProgram self fromAbove originalSequentialLoop fromBelow = SequentialLoopProgram $ originalSequentialLoop { - sequentialLoopCondition = recursivelyTransformedSequentialLoopCondition fromBelow, - conditionCalculation = recursivelyTransformedConditionCalculation fromBelow, - sequentialLoopCore = recursivelyTransformedSequentialLoopCore fromBelow, - sequentialLoopSemInf = convert $ sequentialLoopSemInf originalSequentialLoop - } - upwardsSequentialLoopProgramInProgram :: t -> Downwards t -> SequentialLoop (From t) -> InfoFromSequentialLoopParts t -> ProgramConstruction (To t) -> Upwards t - upwardsSequentialLoopProgramInProgram self fromAbove originalSequentialLoop fromBelow transformedSequentialLoop = foldlist ([(upwardsInfoFromSequentialLoopCondition fromBelow)] ++ [(upwardsInfoFromConditionCalculation fromBelow)] ++ [(upwardsInfoFromSequentialLoopCore fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for ParallelLoop(current basetype: ProgramConstruction) - -- ==================================================================================================== - downwardsParallelLoopProgramInProgram :: t -> Downwards t -> ParallelLoop (From t) -> Downwards t - downwardsParallelLoopProgramInProgram self = const - transformParallelLoopProgramInProgram :: t -> Downwards t -> ParallelLoop (From t) -> InfoFromParallelLoopParts t -> ProgramConstruction (To t) - transformParallelLoopProgramInProgram self fromAbove originalParallelLoop fromBelow = ParallelLoopProgram $ originalParallelLoop { - parallelLoopConditionVariable = recursivelyTransformedParallelLoopConditionVariable fromBelow, - numberOfIterations = recursivelyTransformedNumberOfIterations fromBelow, - parallelLoopCore = recursivelyTransformedParallelLoopCore fromBelow, - parallelLoopSemInf = convert $ parallelLoopSemInf originalParallelLoop - } - upwardsParallelLoopProgramInProgram :: t -> Downwards t -> ParallelLoop (From t) -> InfoFromParallelLoopParts t -> ProgramConstruction (To t) -> Upwards t - upwardsParallelLoopProgramInProgram self fromAbove originalParallelLoop fromBelow transformedParallelLoop = foldlist ([(upwardsInfoFromParallelLoopConditionVariable fromBelow)] ++ [(upwardsInfoFromNumberOfIterations fromBelow)] ++ [(upwardsInfoFromParallelLoopCore fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for FormalParameter - -- ==================================================================================================== - downwardsFormalParameter :: t -> Downwards t -> FormalParameter (From t) -> Downwards t - downwardsFormalParameter self = const - transformFormalParameter :: t -> Downwards t -> FormalParameter (From t) -> InfoFromFormalParameterParts t -> FormalParameter (To t) - transformFormalParameter self fromAbove originalFormalParameter fromBelow = originalFormalParameter { - formalParameterVariable = recursivelyTransformedFormalParameterVariable fromBelow, - formalParameterSemInf = convert $ formalParameterSemInf originalFormalParameter - } - upwardsFormalParameter :: t -> Downwards t -> FormalParameter (From t) -> InfoFromFormalParameterParts t -> FormalParameter (To t) -> Upwards t - upwardsFormalParameter self fromAbove originalFormalParameter fromBelow transformedFormalParameter = foldlist ([(upwardsInfoFromFormalParameterVariable fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for LocalDeclaration - -- ==================================================================================================== - downwardsLocalDeclaration :: t -> Downwards t -> LocalDeclaration (From t) -> Downwards t - downwardsLocalDeclaration self = const - transformLocalDeclaration :: t -> Downwards t -> LocalDeclaration (From t) -> InfoFromLocalDeclarationParts t -> LocalDeclaration (To t) - transformLocalDeclaration self fromAbove originalLocalDeclaration fromBelow = originalLocalDeclaration { - localVariable = recursivelyTransformedLocalVariable fromBelow, - localInitValue = recursivelyTransformedLocalInitValue fromBelow, - localDeclarationSemInf = convert $ localDeclarationSemInf originalLocalDeclaration - } - upwardsLocalDeclaration :: t -> Downwards t -> LocalDeclaration (From t) -> InfoFromLocalDeclarationParts t -> LocalDeclaration (To t) -> Upwards t - upwardsLocalDeclaration self fromAbove originalLocalDeclaration fromBelow transformedLocalDeclaration = foldlist ([(upwardsInfoFromLocalVariable fromBelow)] ++ convertMaybe (upwardsInfoFromLocalInitValue fromBelow)) - -- ==================================================================================================== - -- == Node transformers for Expression - -- ==================================================================================================== - downwardsExpression :: t -> Downwards t -> Expression (From t) -> Downwards t - downwardsExpression self = const - transformExpression :: t -> Downwards t -> Expression (From t) -> InfoFromExpressionParts t -> Expression (To t) - transformExpression self fromAbove originalExpression fromBelow = originalExpression { - expressionData = recursivelyTransformedExpressionData fromBelow, - expressionSemInf = convert $ expressionSemInf originalExpression - } - upwardsExpression :: t -> Downwards t -> Expression (From t) -> InfoFromExpressionParts t -> Expression (To t) -> Upwards t - upwardsExpression self fromAbove originalExpression fromBelow transformedExpression = foldlist ([(upwardsInfoFromExpressionData fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for LeftValue(current basetype: ExpressionData) - -- ==================================================================================================== - downwardsLeftValueExpressionInExpression :: t -> Downwards t -> LeftValue (From t) -> Downwards t - downwardsLeftValueExpressionInExpression self = const - transformLeftValueExpressionInExpression :: t -> Downwards t -> LeftValue (From t) -> InfoFromLeftValueParts t -> ExpressionData (To t) - transformLeftValueExpressionInExpression self fromAbove originalLeftValue fromBelow = LeftValueExpression $ originalLeftValue { - leftValueData = recursivelyTransformedLeftValueData fromBelow, - leftValueSemInf = convert $ leftValueSemInf originalLeftValue - } - upwardsLeftValueExpressionInExpression :: t -> Downwards t -> LeftValue (From t) -> InfoFromLeftValueParts t -> ExpressionData (To t) -> Upwards t - upwardsLeftValueExpressionInExpression self fromAbove originalLeftValue fromBelow transformedLeftValue = foldlist ([(upwardsInfoFromLeftValueData fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for Constant(current basetype: ExpressionData) - -- ==================================================================================================== - downwardsConstantExpressionInExpression :: t -> Downwards t -> Constant (From t) -> Downwards t - downwardsConstantExpressionInExpression self = const - transformConstantExpressionInExpression :: t -> Downwards t -> Constant (From t) -> InfoFromConstantParts t -> ExpressionData (To t) - transformConstantExpressionInExpression self fromAbove originalConstant fromBelow = ConstantExpression $ originalConstant { - constantData = recursivelyTransformedConstantData fromBelow, - constantSemInf = convert $ constantSemInf originalConstant - } - upwardsConstantExpressionInExpression :: t -> Downwards t -> Constant (From t) -> InfoFromConstantParts t -> ExpressionData (To t) -> Upwards t - upwardsConstantExpressionInExpression self fromAbove originalConstant fromBelow transformedConstant = foldlist ([(upwardsInfoFromConstantData fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for FunctionCall(current basetype: ExpressionData) - -- ==================================================================================================== - downwardsFunctionCallExpressionInExpression :: t -> Downwards t -> FunctionCall (From t) -> Downwards t - downwardsFunctionCallExpressionInExpression self = const - transformFunctionCallExpressionInExpression :: t -> Downwards t -> FunctionCall (From t) -> InfoFromFunctionCallParts t -> ExpressionData (To t) - transformFunctionCallExpressionInExpression self fromAbove originalFunctionCall fromBelow = FunctionCallExpression $ originalFunctionCall { - actualParametersOfFunctionToCall = recursivelyTransformedActualParametersOfFunctionToCall fromBelow, - functionCallSemInf = convert $ functionCallSemInf originalFunctionCall - } - upwardsFunctionCallExpressionInExpression :: t -> Downwards t -> FunctionCall (From t) -> InfoFromFunctionCallParts t -> ExpressionData (To t) -> Upwards t - upwardsFunctionCallExpressionInExpression self fromAbove originalFunctionCall fromBelow transformedFunctionCall = foldlist ((upwardsInfoFromActualParametersOfFunctionToCall fromBelow)) - -- ==================================================================================================== - -- == Node transformers for Constant - -- ==================================================================================================== - downwardsConstant :: t -> Downwards t -> Constant (From t) -> Downwards t - downwardsConstant self = const - transformConstant :: t -> Downwards t -> Constant (From t) -> InfoFromConstantParts t -> Constant (To t) - transformConstant self fromAbove originalConstant fromBelow = originalConstant { - constantData = recursivelyTransformedConstantData fromBelow, - constantSemInf = convert $ constantSemInf originalConstant - } - upwardsConstant :: t -> Downwards t -> Constant (From t) -> InfoFromConstantParts t -> Constant (To t) -> Upwards t - upwardsConstant self fromAbove originalConstant fromBelow transformedConstant = foldlist ([(upwardsInfoFromConstantData fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for IntConstantType(current basetype: ConstantData) - -- ==================================================================================================== - transformIntConstantInConstant :: t -> Downwards t -> IntConstantType (From t) -> ConstantData (To t) - transformIntConstantInConstant self fromAbove originalIntConstantType = IntConstant $ originalIntConstantType { - intConstantSemInf = convert $ intConstantSemInf originalIntConstantType - } - upwardsIntConstantInConstant :: t -> Downwards t -> IntConstantType (From t) -> ConstantData (To t) -> Upwards t - upwardsIntConstantInConstant self fromAbove originalIntConstantType transformedIntConstantType = defaultValue - -- ==================================================================================================== - -- == Node transformers for FloatConstantType(current basetype: ConstantData) - -- ==================================================================================================== - transformFloatConstantInConstant :: t -> Downwards t -> FloatConstantType (From t) -> ConstantData (To t) - transformFloatConstantInConstant self fromAbove originalFloatConstantType = FloatConstant $ originalFloatConstantType { - floatConstantSemInf = convert $ floatConstantSemInf originalFloatConstantType - } - upwardsFloatConstantInConstant :: t -> Downwards t -> FloatConstantType (From t) -> ConstantData (To t) -> Upwards t - upwardsFloatConstantInConstant self fromAbove originalFloatConstantType transformedFloatConstantType = defaultValue - -- ==================================================================================================== - -- == Node transformers for BoolConstantType(current basetype: ConstantData) - -- ==================================================================================================== - transformBoolConstantInConstant :: t -> Downwards t -> BoolConstantType (From t) -> ConstantData (To t) - transformBoolConstantInConstant self fromAbove originalBoolConstantType = BoolConstant $ originalBoolConstantType { - boolConstantSemInf = convert $ boolConstantSemInf originalBoolConstantType - } - upwardsBoolConstantInConstant :: t -> Downwards t -> BoolConstantType (From t) -> ConstantData (To t) -> Upwards t - upwardsBoolConstantInConstant self fromAbove originalBoolConstantType transformedBoolConstantType = defaultValue - -- ==================================================================================================== - -- == Node transformers for ArrayConstantType(current basetype: ConstantData) - -- ==================================================================================================== - downwardsArrayConstantInConstant :: t -> Downwards t -> ArrayConstantType (From t) -> Downwards t - downwardsArrayConstantInConstant self = const - transformArrayConstantInConstant :: t -> Downwards t -> ArrayConstantType (From t) -> InfoFromArrayConstantParts t -> ConstantData (To t) - transformArrayConstantInConstant self fromAbove originalArrayConstantType fromBelow = ArrayConstant $ originalArrayConstantType { - arrayConstantValue = recursivelyTransformedArrayConstantValue fromBelow, - arrayConstantSemInf = convert $ arrayConstantSemInf originalArrayConstantType - } - upwardsArrayConstantInConstant :: t -> Downwards t -> ArrayConstantType (From t) -> InfoFromArrayConstantParts t -> ConstantData (To t) -> Upwards t - upwardsArrayConstantInConstant self fromAbove originalArrayConstantType fromBelow transformedArrayConstantType = foldlist ((upwardsInfoFromArrayConstantValue fromBelow)) - -- ==================================================================================================== - -- == Node transformers for LeftValue - -- ==================================================================================================== - downwardsLeftValue :: t -> Downwards t -> LeftValue (From t) -> Downwards t - downwardsLeftValue self = const - transformLeftValue :: t -> Downwards t -> LeftValue (From t) -> InfoFromLeftValueParts t -> LeftValue (To t) - transformLeftValue self fromAbove originalLeftValue fromBelow = originalLeftValue { - leftValueData = recursivelyTransformedLeftValueData fromBelow, - leftValueSemInf = convert $ leftValueSemInf originalLeftValue - } - upwardsLeftValue :: t -> Downwards t -> LeftValue (From t) -> InfoFromLeftValueParts t -> LeftValue (To t) -> Upwards t - upwardsLeftValue self fromAbove originalLeftValue fromBelow transformedLeftValue = foldlist ([(upwardsInfoFromLeftValueData fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for Variable(current basetype: LeftValueData) - -- ==================================================================================================== - transformVariableLeftValueInLeftValue :: t -> Downwards t -> Variable (From t) -> LeftValueData (To t) - transformVariableLeftValueInLeftValue self fromAbove originalVariable = VariableLeftValue $ originalVariable { - variableSemInf = convert $ variableSemInf originalVariable - } - upwardsVariableLeftValueInLeftValue :: t -> Downwards t -> Variable (From t) -> LeftValueData (To t) -> Upwards t - upwardsVariableLeftValueInLeftValue self fromAbove originalVariable transformedVariable = defaultValue - -- ==================================================================================================== - -- == Node transformers for ArrayElemReference(current basetype: LeftValueData) - -- ==================================================================================================== - downwardsArrayElemReferenceLeftValueInLeftValue :: t -> Downwards t -> ArrayElemReference (From t) -> Downwards t - downwardsArrayElemReferenceLeftValueInLeftValue self = const - transformArrayElemReferenceLeftValueInLeftValue :: t -> Downwards t -> ArrayElemReference (From t) -> InfoFromArrayElemReferenceParts t -> LeftValueData (To t) - transformArrayElemReferenceLeftValueInLeftValue self fromAbove originalArrayElemReference fromBelow = ArrayElemReferenceLeftValue $ originalArrayElemReference { - arrayName = recursivelyTransformedArrayName fromBelow, - arrayIndex = recursivelyTransformedArrayIndex fromBelow, - arrayElemReferenceSemInf = convert $ arrayElemReferenceSemInf originalArrayElemReference - } - upwardsArrayElemReferenceLeftValueInLeftValue :: t -> Downwards t -> ArrayElemReference (From t) -> InfoFromArrayElemReferenceParts t -> LeftValueData (To t) -> Upwards t - upwardsArrayElemReferenceLeftValueInLeftValue self fromAbove originalArrayElemReference fromBelow transformedArrayElemReference = foldlist ([(upwardsInfoFromArrayName fromBelow)] ++ [(upwardsInfoFromArrayIndex fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for Instruction - -- ==================================================================================================== - downwardsInstruction :: t -> Downwards t -> Instruction (From t) -> Downwards t - downwardsInstruction self = const - transformInstruction :: t -> Downwards t -> Instruction (From t) -> InfoFromInstructionParts t -> Instruction (To t) - transformInstruction self fromAbove originalInstruction fromBelow = originalInstruction { - instructionData = recursivelyTransformedInstructionData fromBelow, - instructionSemInf = convert $ instructionSemInf originalInstruction - } - upwardsInstruction :: t -> Downwards t -> Instruction (From t) -> InfoFromInstructionParts t -> Instruction (To t) -> Upwards t - upwardsInstruction self fromAbove originalInstruction fromBelow transformedInstruction = foldlist ([(upwardsInfoFromInstructionData fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for Assignment(current basetype: InstructionData) - -- ==================================================================================================== - downwardsAssignmentInstructionInInstruction :: t -> Downwards t -> Assignment (From t) -> Downwards t - downwardsAssignmentInstructionInInstruction self = const - transformAssignmentInstructionInInstruction :: t -> Downwards t -> Assignment (From t) -> InfoFromAssignmentParts t -> InstructionData (To t) - transformAssignmentInstructionInInstruction self fromAbove originalAssignment fromBelow = AssignmentInstruction $ originalAssignment { - assignmentLhs = recursivelyTransformedAssignmentLhs fromBelow, - assignmentRhs = recursivelyTransformedAssignmentRhs fromBelow, - assignmentSemInf = convert $ assignmentSemInf originalAssignment - } - upwardsAssignmentInstructionInInstruction :: t -> Downwards t -> Assignment (From t) -> InfoFromAssignmentParts t -> InstructionData (To t) -> Upwards t - upwardsAssignmentInstructionInInstruction self fromAbove originalAssignment fromBelow transformedAssignment = foldlist ([(upwardsInfoFromAssignmentLhs fromBelow)] ++ [(upwardsInfoFromAssignmentRhs fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for ProcedureCall(current basetype: InstructionData) - -- ==================================================================================================== - downwardsProcedureCallInstructionInInstruction :: t -> Downwards t -> ProcedureCall (From t) -> Downwards t - downwardsProcedureCallInstructionInInstruction self = const - transformProcedureCallInstructionInInstruction :: t -> Downwards t -> ProcedureCall (From t) -> InfoFromProcedureCallParts t -> InstructionData (To t) - transformProcedureCallInstructionInInstruction self fromAbove originalProcedureCall fromBelow = ProcedureCallInstruction $ originalProcedureCall { - actualParametersOfProcedureToCall = recursivelyTransformedActualParametersOfProcedureToCall fromBelow, - procedureCallSemInf = convert $ procedureCallSemInf originalProcedureCall - } - upwardsProcedureCallInstructionInInstruction :: t -> Downwards t -> ProcedureCall (From t) -> InfoFromProcedureCallParts t -> InstructionData (To t) -> Upwards t - upwardsProcedureCallInstructionInInstruction self fromAbove originalProcedureCall fromBelow transformedProcedureCall = foldlist ((upwardsInfoFromActualParametersOfProcedureToCall fromBelow)) - -- ==================================================================================================== - -- == Node transformers for ActualParameter - -- ==================================================================================================== - downwardsActualParameter :: t -> Downwards t -> ActualParameter (From t) -> Downwards t - downwardsActualParameter self = const - transformActualParameter :: t -> Downwards t -> ActualParameter (From t) -> InfoFromActualParameterParts t -> ActualParameter (To t) - transformActualParameter self fromAbove originalActualParameter fromBelow = originalActualParameter { - actualParameterData = recursivelyTransformedActualParameterData fromBelow, - actualParameterSemInf = convert $ actualParameterSemInf originalActualParameter - } - upwardsActualParameter :: t -> Downwards t -> ActualParameter (From t) -> InfoFromActualParameterParts t -> ActualParameter (To t) -> Upwards t - upwardsActualParameter self fromAbove originalActualParameter fromBelow transformedActualParameter = foldlist ([(upwardsInfoFromActualParameterData fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for Expression(current basetype: ActualParameterData) - -- ==================================================================================================== - downwardsInputActualParameterInActualParameter :: t -> Downwards t -> Expression (From t) -> Downwards t - downwardsInputActualParameterInActualParameter self = const - transformInputActualParameterInActualParameter :: t -> Downwards t -> Expression (From t) -> InfoFromExpressionParts t -> ActualParameterData (To t) - transformInputActualParameterInActualParameter self fromAbove originalExpression fromBelow = InputActualParameter $ originalExpression { - expressionData = recursivelyTransformedExpressionData fromBelow, - expressionSemInf = convert $ expressionSemInf originalExpression - } - upwardsInputActualParameterInActualParameter :: t -> Downwards t -> Expression (From t) -> InfoFromExpressionParts t -> ActualParameterData (To t) -> Upwards t - upwardsInputActualParameterInActualParameter self fromAbove originalExpression fromBelow transformedExpression = foldlist ([(upwardsInfoFromExpressionData fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for LeftValue(current basetype: ActualParameterData) - -- ==================================================================================================== - downwardsOutputActualParameterInActualParameter :: t -> Downwards t -> LeftValue (From t) -> Downwards t - downwardsOutputActualParameterInActualParameter self = const - transformOutputActualParameterInActualParameter :: t -> Downwards t -> LeftValue (From t) -> InfoFromLeftValueParts t -> ActualParameterData (To t) - transformOutputActualParameterInActualParameter self fromAbove originalLeftValue fromBelow = OutputActualParameter $ originalLeftValue { - leftValueData = recursivelyTransformedLeftValueData fromBelow, - leftValueSemInf = convert $ leftValueSemInf originalLeftValue - } - upwardsOutputActualParameterInActualParameter :: t -> Downwards t -> LeftValue (From t) -> InfoFromLeftValueParts t -> ActualParameterData (To t) -> Upwards t - upwardsOutputActualParameterInActualParameter self fromAbove originalLeftValue fromBelow transformedLeftValue = foldlist ([(upwardsInfoFromLeftValueData fromBelow)]) - -- ==================================================================================================== - -- == Node transformers for IntConstantType - -- ==================================================================================================== - transformIntConstant :: t -> Downwards t -> IntConstantType (From t) -> IntConstantType (To t) - transformIntConstant self fromAbove originalIntConstantType = originalIntConstantType { - intConstantSemInf = convert $ intConstantSemInf originalIntConstantType - } - upwardsIntConstant :: t -> Downwards t -> IntConstantType (From t) -> IntConstantType (To t) -> Upwards t - upwardsIntConstant self fromAbove originalIntConstantType transformedIntConstantType = defaultValue - -- ==================================================================================================== - -- == Node transformers for FloatConstantType - -- ==================================================================================================== - transformFloatConstant :: t -> Downwards t -> FloatConstantType (From t) -> FloatConstantType (To t) - transformFloatConstant self fromAbove originalFloatConstantType = originalFloatConstantType { - floatConstantSemInf = convert $ floatConstantSemInf originalFloatConstantType - } - upwardsFloatConstant :: t -> Downwards t -> FloatConstantType (From t) -> FloatConstantType (To t) -> Upwards t - upwardsFloatConstant self fromAbove originalFloatConstantType transformedFloatConstantType = defaultValue - -- ==================================================================================================== - -- == Node transformers for BoolConstantType - -- ==================================================================================================== - transformBoolConstant :: t -> Downwards t -> BoolConstantType (From t) -> BoolConstantType (To t) - transformBoolConstant self fromAbove originalBoolConstantType = originalBoolConstantType { - boolConstantSemInf = convert $ boolConstantSemInf originalBoolConstantType - } - upwardsBoolConstant :: t -> Downwards t -> BoolConstantType (From t) -> BoolConstantType (To t) -> Upwards t - upwardsBoolConstant self fromAbove originalBoolConstantType transformedBoolConstantType = defaultValue - -- ==================================================================================================== - -- == Node transformers for Variable - -- ==================================================================================================== - transformVariable :: t -> Downwards t -> Variable (From t) -> Variable (To t) - transformVariable self fromAbove originalVariable = originalVariable { - variableSemInf = convert $ variableSemInf originalVariable - } - upwardsVariable :: t -> Downwards t -> Variable (From t) -> Variable (To t) -> Upwards t - upwardsVariable self fromAbove originalVariable transformedVariable = defaultValue --- ==================================================================================================== --- == Walker functions --- ==================================================================================================== - -- ==================================================================================================== - -- == Walker for Procedure - -- ==================================================================================================== - walkProcedure :: Walker t Procedure - walkProcedure selfpointer fromAbove construction = (transformedProcedure, toAbove) - where - toBelow = downwardsProcedure selfpointer fromAbove construction - transformedInParameters = map (walkFormalParameter selfpointer toBelow) $ inParameters construction - transformedOutParameters = map (walkFormalParameter selfpointer toBelow) $ outParameters construction - transformedProcedureBody = (walkBlock selfpointer toBelow) $ procedureBody construction - fromBelow = InfoFromProcedureParts { - recursivelyTransformedInParameters = map fst transformedInParameters, - upwardsInfoFromInParameters = map snd transformedInParameters, - recursivelyTransformedOutParameters = map fst transformedOutParameters, - upwardsInfoFromOutParameters = map snd transformedOutParameters, - recursivelyTransformedProcedureBody = fst transformedProcedureBody, - upwardsInfoFromProcedureBody = snd transformedProcedureBody - } - transformedProcedure = transformProcedure selfpointer fromAbove construction fromBelow - toAbove = upwardsProcedure selfpointer fromAbove construction fromBelow transformedProcedure - -- ==================================================================================================== - -- == Walker for Block - -- ==================================================================================================== - walkBlock :: Walker t Block - walkBlock selfpointer fromAbove construction = (transformedBlock, toAbove) - where - toBelow = downwardsBlock selfpointer fromAbove construction - transformedBlockDeclarations = map (walkLocalDeclaration selfpointer toBelow) $ blockDeclarations construction - transformedBlockInstructions = (walkProgram selfpointer toBelow) $ blockInstructions construction - fromBelow = InfoFromBlockParts { - recursivelyTransformedBlockDeclarations = map fst transformedBlockDeclarations, - upwardsInfoFromBlockDeclarations = map snd transformedBlockDeclarations, - recursivelyTransformedBlockInstructions = fst transformedBlockInstructions, - upwardsInfoFromBlockInstructions = snd transformedBlockInstructions - } - transformedBlock = transformBlock selfpointer fromAbove construction fromBelow - toAbove = upwardsBlock selfpointer fromAbove construction fromBelow transformedBlock - -- ==================================================================================================== - -- == Walker for Program - -- ==================================================================================================== - walkProgram :: Walker t Program - walkProgram selfpointer fromAbove construction = (transformedProgram, toAbove) - where - toBelow = downwardsProgram selfpointer fromAbove construction - transformedProgramConstruction = case programConstruction construction of - EmptyProgram construction -> (walkEmptyProgramInProgram selfpointer toBelow) construction - PrimitiveProgram construction -> (walkPrimitiveProgramInProgram selfpointer toBelow) construction - SequenceProgram construction -> (walkSequenceProgramInProgram selfpointer toBelow) construction - BranchProgram construction -> (walkBranchProgramInProgram selfpointer toBelow) construction - SequentialLoopProgram construction -> (walkSequentialLoopProgramInProgram selfpointer toBelow) construction - ParallelLoopProgram construction -> (walkParallelLoopProgramInProgram selfpointer toBelow) construction - fromBelow = InfoFromProgramParts { - recursivelyTransformedProgramConstruction = fst transformedProgramConstruction, - upwardsInfoFromProgramConstruction = snd transformedProgramConstruction - } - transformedProgram = transformProgram selfpointer fromAbove construction fromBelow - toAbove = upwardsProgram selfpointer fromAbove construction fromBelow transformedProgram - -- ==================================================================================================== - -- == Walker for Empty, current base type: ProgramConstruction - -- ==================================================================================================== - walkEmptyProgramInProgram :: (TransformationPhase t) => t -> Downwards t -> Empty (From t) -> (ProgramConstruction (To t), Upwards t) - walkEmptyProgramInProgram selfpointer fromAbove construction = (transformedEmpty, toAbove) - where - transformedEmpty = transformEmptyProgramInProgram selfpointer fromAbove construction - toAbove = upwardsEmptyProgramInProgram selfpointer fromAbove construction transformedEmpty - -- ==================================================================================================== - -- == Walker for Primitive, current base type: ProgramConstruction - -- ==================================================================================================== - walkPrimitiveProgramInProgram :: (TransformationPhase t) => t -> Downwards t -> Primitive (From t) -> (ProgramConstruction (To t), Upwards t) - walkPrimitiveProgramInProgram selfpointer fromAbove construction = (transformedPrimitive, toAbove) - where - toBelow = downwardsPrimitiveProgramInProgram selfpointer fromAbove construction - transformedPrimitiveInstruction = (walkInstruction selfpointer toBelow) $ primitiveInstruction construction - fromBelow = InfoFromPrimitiveParts { - recursivelyTransformedPrimitiveInstruction = fst transformedPrimitiveInstruction, - upwardsInfoFromPrimitiveInstruction = snd transformedPrimitiveInstruction - } - transformedPrimitive = transformPrimitiveProgramInProgram selfpointer fromAbove construction fromBelow - toAbove = upwardsPrimitiveProgramInProgram selfpointer fromAbove construction fromBelow transformedPrimitive - -- ==================================================================================================== - -- == Walker for Sequence, current base type: ProgramConstruction - -- ==================================================================================================== - walkSequenceProgramInProgram :: (TransformationPhase t) => t -> Downwards t -> Sequence (From t) -> (ProgramConstruction (To t), Upwards t) - walkSequenceProgramInProgram selfpointer fromAbove construction = (transformedSequence, toAbove) - where - toBelow = downwardsSequenceProgramInProgram selfpointer fromAbove construction - transformedSequenceProgramList = map (walkProgram selfpointer toBelow) $ sequenceProgramList construction - fromBelow = InfoFromSequenceParts { - recursivelyTransformedSequenceProgramList = map fst transformedSequenceProgramList, - upwardsInfoFromSequenceProgramList = map snd transformedSequenceProgramList - } - transformedSequence = transformSequenceProgramInProgram selfpointer fromAbove construction fromBelow - toAbove = upwardsSequenceProgramInProgram selfpointer fromAbove construction fromBelow transformedSequence - -- ==================================================================================================== - -- == Walker for Branch, current base type: ProgramConstruction - -- ==================================================================================================== - walkBranchProgramInProgram :: (TransformationPhase t) => t -> Downwards t -> Branch (From t) -> (ProgramConstruction (To t), Upwards t) - walkBranchProgramInProgram selfpointer fromAbove construction = (transformedBranch, toAbove) - where - toBelow = downwardsBranchProgramInProgram selfpointer fromAbove construction - transformedBranchConditionVariable = (walkVariable selfpointer toBelow) $ branchConditionVariable construction - transformedThenBlock = (walkBlock selfpointer toBelow) $ thenBlock construction - transformedElseBlock = (walkBlock selfpointer toBelow) $ elseBlock construction - fromBelow = InfoFromBranchParts { - recursivelyTransformedBranchConditionVariable = fst transformedBranchConditionVariable, - upwardsInfoFromBranchConditionVariable = snd transformedBranchConditionVariable, - recursivelyTransformedThenBlock = fst transformedThenBlock, - upwardsInfoFromThenBlock = snd transformedThenBlock, - recursivelyTransformedElseBlock = fst transformedElseBlock, - upwardsInfoFromElseBlock = snd transformedElseBlock - } - transformedBranch = transformBranchProgramInProgram selfpointer fromAbove construction fromBelow - toAbove = upwardsBranchProgramInProgram selfpointer fromAbove construction fromBelow transformedBranch - -- ==================================================================================================== - -- == Walker for SequentialLoop, current base type: ProgramConstruction - -- ==================================================================================================== - walkSequentialLoopProgramInProgram :: (TransformationPhase t) => t -> Downwards t -> SequentialLoop (From t) -> (ProgramConstruction (To t), Upwards t) - walkSequentialLoopProgramInProgram selfpointer fromAbove construction = (transformedSequentialLoop, toAbove) - where - toBelow = downwardsSequentialLoopProgramInProgram selfpointer fromAbove construction - transformedSequentialLoopCondition = (walkExpression selfpointer toBelow) $ sequentialLoopCondition construction - transformedConditionCalculation = (walkBlock selfpointer toBelow) $ conditionCalculation construction - transformedSequentialLoopCore = (walkBlock selfpointer toBelow) $ sequentialLoopCore construction - fromBelow = InfoFromSequentialLoopParts { - recursivelyTransformedSequentialLoopCondition = fst transformedSequentialLoopCondition, - upwardsInfoFromSequentialLoopCondition = snd transformedSequentialLoopCondition, - recursivelyTransformedConditionCalculation = fst transformedConditionCalculation, - upwardsInfoFromConditionCalculation = snd transformedConditionCalculation, - recursivelyTransformedSequentialLoopCore = fst transformedSequentialLoopCore, - upwardsInfoFromSequentialLoopCore = snd transformedSequentialLoopCore - } - transformedSequentialLoop = transformSequentialLoopProgramInProgram selfpointer fromAbove construction fromBelow - toAbove = upwardsSequentialLoopProgramInProgram selfpointer fromAbove construction fromBelow transformedSequentialLoop - -- ==================================================================================================== - -- == Walker for ParallelLoop, current base type: ProgramConstruction - -- ==================================================================================================== - walkParallelLoopProgramInProgram :: (TransformationPhase t) => t -> Downwards t -> ParallelLoop (From t) -> (ProgramConstruction (To t), Upwards t) - walkParallelLoopProgramInProgram selfpointer fromAbove construction = (transformedParallelLoop, toAbove) - where - toBelow = downwardsParallelLoopProgramInProgram selfpointer fromAbove construction - transformedParallelLoopConditionVariable = (walkVariable selfpointer toBelow) $ parallelLoopConditionVariable construction - transformedNumberOfIterations = (walkExpression selfpointer toBelow) $ numberOfIterations construction - transformedParallelLoopCore = (walkBlock selfpointer toBelow) $ parallelLoopCore construction - fromBelow = InfoFromParallelLoopParts { - recursivelyTransformedParallelLoopConditionVariable = fst transformedParallelLoopConditionVariable, - upwardsInfoFromParallelLoopConditionVariable = snd transformedParallelLoopConditionVariable, - recursivelyTransformedNumberOfIterations = fst transformedNumberOfIterations, - upwardsInfoFromNumberOfIterations = snd transformedNumberOfIterations, - recursivelyTransformedParallelLoopCore = fst transformedParallelLoopCore, - upwardsInfoFromParallelLoopCore = snd transformedParallelLoopCore - } - transformedParallelLoop = transformParallelLoopProgramInProgram selfpointer fromAbove construction fromBelow - toAbove = upwardsParallelLoopProgramInProgram selfpointer fromAbove construction fromBelow transformedParallelLoop - -- ==================================================================================================== - -- == Walker for FormalParameter - -- ==================================================================================================== - walkFormalParameter :: Walker t FormalParameter - walkFormalParameter selfpointer fromAbove construction = (transformedFormalParameter, toAbove) - where - toBelow = downwardsFormalParameter selfpointer fromAbove construction - transformedFormalParameterVariable = (walkVariable selfpointer toBelow) $ formalParameterVariable construction - fromBelow = InfoFromFormalParameterParts { - recursivelyTransformedFormalParameterVariable = fst transformedFormalParameterVariable, - upwardsInfoFromFormalParameterVariable = snd transformedFormalParameterVariable - } - transformedFormalParameter = transformFormalParameter selfpointer fromAbove construction fromBelow - toAbove = upwardsFormalParameter selfpointer fromAbove construction fromBelow transformedFormalParameter - -- ==================================================================================================== - -- == Walker for LocalDeclaration - -- ==================================================================================================== - walkLocalDeclaration :: Walker t LocalDeclaration - walkLocalDeclaration selfpointer fromAbove construction = (transformedLocalDeclaration, toAbove) - where - toBelow = downwardsLocalDeclaration selfpointer fromAbove construction - transformedLocalVariable = (walkVariable selfpointer toBelow) $ localVariable construction - transformedLocalInitValue = case localInitValue construction of - Nothing -> (Nothing, Nothing) - Just justLocalInitValue -> (Just (fst transformedJustLocalInitValue), Just (snd transformedJustLocalInitValue)) - where transformedJustLocalInitValue = (walkExpression selfpointer toBelow) $ justLocalInitValue - fromBelow = InfoFromLocalDeclarationParts { - recursivelyTransformedLocalVariable = fst transformedLocalVariable, - upwardsInfoFromLocalVariable = snd transformedLocalVariable, - recursivelyTransformedLocalInitValue = fst transformedLocalInitValue, - upwardsInfoFromLocalInitValue = snd transformedLocalInitValue - } - transformedLocalDeclaration = transformLocalDeclaration selfpointer fromAbove construction fromBelow - toAbove = upwardsLocalDeclaration selfpointer fromAbove construction fromBelow transformedLocalDeclaration - -- ==================================================================================================== - -- == Walker for Expression - -- ==================================================================================================== - walkExpression :: Walker t Expression - walkExpression selfpointer fromAbove construction = (transformedExpression, toAbove) - where - toBelow = downwardsExpression selfpointer fromAbove construction - transformedExpressionData = case expressionData construction of - LeftValueExpression construction -> (walkLeftValueExpressionInExpression selfpointer toBelow) construction - ConstantExpression construction -> (walkConstantExpressionInExpression selfpointer toBelow) construction - FunctionCallExpression construction -> (walkFunctionCallExpressionInExpression selfpointer toBelow) construction - fromBelow = InfoFromExpressionParts { - recursivelyTransformedExpressionData = fst transformedExpressionData, - upwardsInfoFromExpressionData = snd transformedExpressionData - } - transformedExpression = transformExpression selfpointer fromAbove construction fromBelow - toAbove = upwardsExpression selfpointer fromAbove construction fromBelow transformedExpression - -- ==================================================================================================== - -- == Walker for LeftValue, current base type: ExpressionData - -- ==================================================================================================== - walkLeftValueExpressionInExpression :: (TransformationPhase t) => t -> Downwards t -> LeftValue (From t) -> (ExpressionData (To t), Upwards t) - walkLeftValueExpressionInExpression selfpointer fromAbove construction = (transformedLeftValue, toAbove) - where - toBelow = downwardsLeftValueExpressionInExpression selfpointer fromAbove construction - transformedLeftValueData = case leftValueData construction of - VariableLeftValue construction -> (walkVariableLeftValueInLeftValue selfpointer toBelow) construction - ArrayElemReferenceLeftValue construction -> (walkArrayElemReferenceLeftValueInLeftValue selfpointer toBelow) construction - fromBelow = InfoFromLeftValueParts { - recursivelyTransformedLeftValueData = fst transformedLeftValueData, - upwardsInfoFromLeftValueData = snd transformedLeftValueData - } - transformedLeftValue = transformLeftValueExpressionInExpression selfpointer fromAbove construction fromBelow - toAbove = upwardsLeftValueExpressionInExpression selfpointer fromAbove construction fromBelow transformedLeftValue - -- ==================================================================================================== - -- == Walker for Constant, current base type: ExpressionData - -- ==================================================================================================== - walkConstantExpressionInExpression :: (TransformationPhase t) => t -> Downwards t -> Constant (From t) -> (ExpressionData (To t), Upwards t) - walkConstantExpressionInExpression selfpointer fromAbove construction = (transformedConstant, toAbove) - where - toBelow = downwardsConstantExpressionInExpression selfpointer fromAbove construction - transformedConstantData = case constantData construction of - IntConstant construction -> (walkIntConstantInConstant selfpointer toBelow) construction - FloatConstant construction -> (walkFloatConstantInConstant selfpointer toBelow) construction - BoolConstant construction -> (walkBoolConstantInConstant selfpointer toBelow) construction - ArrayConstant construction -> (walkArrayConstantInConstant selfpointer toBelow) construction - fromBelow = InfoFromConstantParts { - recursivelyTransformedConstantData = fst transformedConstantData, - upwardsInfoFromConstantData = snd transformedConstantData - } - transformedConstant = transformConstantExpressionInExpression selfpointer fromAbove construction fromBelow - toAbove = upwardsConstantExpressionInExpression selfpointer fromAbove construction fromBelow transformedConstant - -- ==================================================================================================== - -- == Walker for FunctionCall, current base type: ExpressionData - -- ==================================================================================================== - walkFunctionCallExpressionInExpression :: (TransformationPhase t) => t -> Downwards t -> FunctionCall (From t) -> (ExpressionData (To t), Upwards t) - walkFunctionCallExpressionInExpression selfpointer fromAbove construction = (transformedFunctionCall, toAbove) - where - toBelow = downwardsFunctionCallExpressionInExpression selfpointer fromAbove construction - transformedActualParametersOfFunctionToCall = map (walkExpression selfpointer toBelow) $ actualParametersOfFunctionToCall construction - fromBelow = InfoFromFunctionCallParts { - recursivelyTransformedActualParametersOfFunctionToCall = map fst transformedActualParametersOfFunctionToCall, - upwardsInfoFromActualParametersOfFunctionToCall = map snd transformedActualParametersOfFunctionToCall - } - transformedFunctionCall = transformFunctionCallExpressionInExpression selfpointer fromAbove construction fromBelow - toAbove = upwardsFunctionCallExpressionInExpression selfpointer fromAbove construction fromBelow transformedFunctionCall - -- ==================================================================================================== - -- == Walker for Constant - -- ==================================================================================================== - walkConstant :: Walker t Constant - walkConstant selfpointer fromAbove construction = (transformedConstant, toAbove) - where - toBelow = downwardsConstant selfpointer fromAbove construction - transformedConstantData = case constantData construction of - IntConstant construction -> (walkIntConstantInConstant selfpointer toBelow) construction - FloatConstant construction -> (walkFloatConstantInConstant selfpointer toBelow) construction - BoolConstant construction -> (walkBoolConstantInConstant selfpointer toBelow) construction - ArrayConstant construction -> (walkArrayConstantInConstant selfpointer toBelow) construction - fromBelow = InfoFromConstantParts { - recursivelyTransformedConstantData = fst transformedConstantData, - upwardsInfoFromConstantData = snd transformedConstantData - } - transformedConstant = transformConstant selfpointer fromAbove construction fromBelow - toAbove = upwardsConstant selfpointer fromAbove construction fromBelow transformedConstant - -- ==================================================================================================== - -- == Walker for IntConstantType, current base type: ConstantData - -- ==================================================================================================== - walkIntConstantInConstant :: (TransformationPhase t) => t -> Downwards t -> IntConstantType (From t) -> (ConstantData (To t), Upwards t) - walkIntConstantInConstant selfpointer fromAbove construction = (transformedIntConstantType, toAbove) - where - transformedIntConstantType = transformIntConstantInConstant selfpointer fromAbove construction - toAbove = upwardsIntConstantInConstant selfpointer fromAbove construction transformedIntConstantType - -- ==================================================================================================== - -- == Walker for FloatConstantType, current base type: ConstantData - -- ==================================================================================================== - walkFloatConstantInConstant :: (TransformationPhase t) => t -> Downwards t -> FloatConstantType (From t) -> (ConstantData (To t), Upwards t) - walkFloatConstantInConstant selfpointer fromAbove construction = (transformedFloatConstantType, toAbove) - where - transformedFloatConstantType = transformFloatConstantInConstant selfpointer fromAbove construction - toAbove = upwardsFloatConstantInConstant selfpointer fromAbove construction transformedFloatConstantType - -- ==================================================================================================== - -- == Walker for BoolConstantType, current base type: ConstantData - -- ==================================================================================================== - walkBoolConstantInConstant :: (TransformationPhase t) => t -> Downwards t -> BoolConstantType (From t) -> (ConstantData (To t), Upwards t) - walkBoolConstantInConstant selfpointer fromAbove construction = (transformedBoolConstantType, toAbove) - where - transformedBoolConstantType = transformBoolConstantInConstant selfpointer fromAbove construction - toAbove = upwardsBoolConstantInConstant selfpointer fromAbove construction transformedBoolConstantType - -- ==================================================================================================== - -- == Walker for ArrayConstantType, current base type: ConstantData - -- ==================================================================================================== - walkArrayConstantInConstant :: (TransformationPhase t) => t -> Downwards t -> ArrayConstantType (From t) -> (ConstantData (To t), Upwards t) - walkArrayConstantInConstant selfpointer fromAbove construction = (transformedArrayConstantType, toAbove) - where - toBelow = downwardsArrayConstantInConstant selfpointer fromAbove construction - transformedArrayConstantValue = map (walkConstant selfpointer toBelow) $ arrayConstantValue construction - fromBelow = InfoFromArrayConstantParts { - recursivelyTransformedArrayConstantValue = map fst transformedArrayConstantValue, - upwardsInfoFromArrayConstantValue = map snd transformedArrayConstantValue - } - transformedArrayConstantType = transformArrayConstantInConstant selfpointer fromAbove construction fromBelow - toAbove = upwardsArrayConstantInConstant selfpointer fromAbove construction fromBelow transformedArrayConstantType - - -- ==================================================================================================== - -- == Walker for LeftValue - -- ==================================================================================================== - walkLeftValue :: Walker t LeftValue - walkLeftValue selfpointer fromAbove construction = (transformedLeftValue, toAbove) - where - toBelow = downwardsLeftValue selfpointer fromAbove construction - transformedLeftValueData = case leftValueData construction of - VariableLeftValue construction -> (walkVariableLeftValueInLeftValue selfpointer toBelow) construction - ArrayElemReferenceLeftValue construction -> (walkArrayElemReferenceLeftValueInLeftValue selfpointer toBelow) construction - fromBelow = InfoFromLeftValueParts { - recursivelyTransformedLeftValueData = fst transformedLeftValueData, - upwardsInfoFromLeftValueData = snd transformedLeftValueData - } - transformedLeftValue = transformLeftValue selfpointer fromAbove construction fromBelow - toAbove = upwardsLeftValue selfpointer fromAbove construction fromBelow transformedLeftValue - -- ==================================================================================================== - -- == Walker for Variable, current base type: LeftValueData - -- ==================================================================================================== - walkVariableLeftValueInLeftValue :: (TransformationPhase t) => t -> Downwards t -> Variable (From t) -> (LeftValueData (To t), Upwards t) - walkVariableLeftValueInLeftValue selfpointer fromAbove construction = (transformedVariable, toAbove) - where - transformedVariable = transformVariableLeftValueInLeftValue selfpointer fromAbove construction - toAbove = upwardsVariableLeftValueInLeftValue selfpointer fromAbove construction transformedVariable - -- ==================================================================================================== - -- == Walker for ArrayElemReference, current base type: LeftValueData - -- ==================================================================================================== - walkArrayElemReferenceLeftValueInLeftValue :: (TransformationPhase t) => t -> Downwards t -> ArrayElemReference (From t) -> (LeftValueData (To t), Upwards t) - walkArrayElemReferenceLeftValueInLeftValue selfpointer fromAbove construction = (transformedArrayElemReference, toAbove) - where - toBelow = downwardsArrayElemReferenceLeftValueInLeftValue selfpointer fromAbove construction - transformedArrayName = (walkLeftValue selfpointer toBelow) $ arrayName construction - transformedArrayIndex = (walkExpression selfpointer toBelow) $ arrayIndex construction - fromBelow = InfoFromArrayElemReferenceParts { - recursivelyTransformedArrayName = fst transformedArrayName, - upwardsInfoFromArrayName = snd transformedArrayName, - recursivelyTransformedArrayIndex = fst transformedArrayIndex, - upwardsInfoFromArrayIndex = snd transformedArrayIndex - } - transformedArrayElemReference = transformArrayElemReferenceLeftValueInLeftValue selfpointer fromAbove construction fromBelow - toAbove = upwardsArrayElemReferenceLeftValueInLeftValue selfpointer fromAbove construction fromBelow transformedArrayElemReference - -- ==================================================================================================== - -- == Walker for Instruction - -- ==================================================================================================== - walkInstruction :: Walker t Instruction - walkInstruction selfpointer fromAbove construction = (transformedInstruction, toAbove) - where - toBelow = downwardsInstruction selfpointer fromAbove construction - transformedInstructionData = case instructionData construction of - AssignmentInstruction construction -> (walkAssignmentInstructionInInstruction selfpointer toBelow) construction - ProcedureCallInstruction construction -> (walkProcedureCallInstructionInInstruction selfpointer toBelow) construction - fromBelow = InfoFromInstructionParts { - recursivelyTransformedInstructionData = fst transformedInstructionData, - upwardsInfoFromInstructionData = snd transformedInstructionData - } - transformedInstruction = transformInstruction selfpointer fromAbove construction fromBelow - toAbove = upwardsInstruction selfpointer fromAbove construction fromBelow transformedInstruction - -- ==================================================================================================== - -- == Walker for Assignment, current base type: InstructionData - -- ==================================================================================================== - walkAssignmentInstructionInInstruction :: (TransformationPhase t) => t -> Downwards t -> Assignment (From t) -> (InstructionData (To t), Upwards t) - walkAssignmentInstructionInInstruction selfpointer fromAbove construction = (transformedAssignment, toAbove) - where - toBelow = downwardsAssignmentInstructionInInstruction selfpointer fromAbove construction - transformedAssignmentLhs = (walkLeftValue selfpointer toBelow) $ assignmentLhs construction - transformedAssignmentRhs = (walkExpression selfpointer toBelow) $ assignmentRhs construction - fromBelow = InfoFromAssignmentParts { - recursivelyTransformedAssignmentLhs = fst transformedAssignmentLhs, - upwardsInfoFromAssignmentLhs = snd transformedAssignmentLhs, - recursivelyTransformedAssignmentRhs = fst transformedAssignmentRhs, - upwardsInfoFromAssignmentRhs = snd transformedAssignmentRhs - } - transformedAssignment = transformAssignmentInstructionInInstruction selfpointer fromAbove construction fromBelow - toAbove = upwardsAssignmentInstructionInInstruction selfpointer fromAbove construction fromBelow transformedAssignment - -- ==================================================================================================== - -- == Walker for ProcedureCall, current base type: InstructionData - -- ==================================================================================================== - walkProcedureCallInstructionInInstruction :: (TransformationPhase t) => t -> Downwards t -> ProcedureCall (From t) -> (InstructionData (To t), Upwards t) - walkProcedureCallInstructionInInstruction selfpointer fromAbove construction = (transformedProcedureCall, toAbove) - where - toBelow = downwardsProcedureCallInstructionInInstruction selfpointer fromAbove construction - transformedActualParametersOfProcedureToCall = map (walkActualParameter selfpointer toBelow) $ actualParametersOfProcedureToCall construction - fromBelow = InfoFromProcedureCallParts { - recursivelyTransformedActualParametersOfProcedureToCall = map fst transformedActualParametersOfProcedureToCall, - upwardsInfoFromActualParametersOfProcedureToCall = map snd transformedActualParametersOfProcedureToCall - } - transformedProcedureCall = transformProcedureCallInstructionInInstruction selfpointer fromAbove construction fromBelow - toAbove = upwardsProcedureCallInstructionInInstruction selfpointer fromAbove construction fromBelow transformedProcedureCall - -- ==================================================================================================== - -- == Walker for ActualParameter - -- ==================================================================================================== - walkActualParameter :: Walker t ActualParameter - walkActualParameter selfpointer fromAbove construction = (transformedActualParameter, toAbove) - where - toBelow = downwardsActualParameter selfpointer fromAbove construction - transformedActualParameterData = case actualParameterData construction of - InputActualParameter construction -> (walkInputActualParameterInActualParameter selfpointer toBelow) construction - OutputActualParameter construction -> (walkOutputActualParameterInActualParameter selfpointer toBelow) construction - fromBelow = InfoFromActualParameterParts { - recursivelyTransformedActualParameterData = fst transformedActualParameterData, - upwardsInfoFromActualParameterData = snd transformedActualParameterData - } - transformedActualParameter = transformActualParameter selfpointer fromAbove construction fromBelow - toAbove = upwardsActualParameter selfpointer fromAbove construction fromBelow transformedActualParameter - -- ==================================================================================================== - -- == Walker for Expression, current base type: ActualParameterData - -- ==================================================================================================== - walkInputActualParameterInActualParameter :: (TransformationPhase t) => t -> Downwards t -> Expression (From t) -> (ActualParameterData (To t), Upwards t) - walkInputActualParameterInActualParameter selfpointer fromAbove construction = (transformedExpression, toAbove) - where - toBelow = downwardsInputActualParameterInActualParameter selfpointer fromAbove construction - transformedExpressionData = case expressionData construction of - LeftValueExpression construction -> (walkLeftValueExpressionInExpression selfpointer toBelow) construction - ConstantExpression construction -> (walkConstantExpressionInExpression selfpointer toBelow) construction - FunctionCallExpression construction -> (walkFunctionCallExpressionInExpression selfpointer toBelow) construction - fromBelow = InfoFromExpressionParts { - recursivelyTransformedExpressionData = fst transformedExpressionData, - upwardsInfoFromExpressionData = snd transformedExpressionData - } - transformedExpression = transformInputActualParameterInActualParameter selfpointer fromAbove construction fromBelow - toAbove = upwardsInputActualParameterInActualParameter selfpointer fromAbove construction fromBelow transformedExpression - -- ==================================================================================================== - -- == Walker for LeftValue, current base type: ActualParameterData - -- ==================================================================================================== - walkOutputActualParameterInActualParameter :: (TransformationPhase t) => t -> Downwards t -> LeftValue (From t) -> (ActualParameterData (To t), Upwards t) - walkOutputActualParameterInActualParameter selfpointer fromAbove construction = (transformedLeftValue, toAbove) - where - toBelow = downwardsOutputActualParameterInActualParameter selfpointer fromAbove construction - transformedLeftValueData = case leftValueData construction of - VariableLeftValue construction -> (walkVariableLeftValueInLeftValue selfpointer toBelow) construction - ArrayElemReferenceLeftValue construction -> (walkArrayElemReferenceLeftValueInLeftValue selfpointer toBelow) construction - fromBelow = InfoFromLeftValueParts { - recursivelyTransformedLeftValueData = fst transformedLeftValueData, - upwardsInfoFromLeftValueData = snd transformedLeftValueData - } - transformedLeftValue = transformOutputActualParameterInActualParameter selfpointer fromAbove construction fromBelow - toAbove = upwardsOutputActualParameterInActualParameter selfpointer fromAbove construction fromBelow transformedLeftValue - -- ==================================================================================================== - -- == Walker for Variable - -- ==================================================================================================== - walkVariable :: Walker t Variable - walkVariable selfpointer fromAbove construction = (transformedVariable, toAbove) - where - transformedVariable = transformVariable selfpointer fromAbove construction - toAbove = upwardsVariable selfpointer fromAbove construction transformedVariable --- ==================================================================================================== --- == Upwards types --- ==================================================================================================== -data (TransformationPhase t) => InfoFromProcedureParts t = InfoFromProcedureParts { - recursivelyTransformedInParameters :: [FormalParameter (To t)], - upwardsInfoFromInParameters :: [Upwards t], - recursivelyTransformedOutParameters :: [FormalParameter (To t)], - upwardsInfoFromOutParameters :: [Upwards t], - recursivelyTransformedProcedureBody :: Block (To t), - upwardsInfoFromProcedureBody :: Upwards t -} -data (TransformationPhase t) => InfoFromBlockParts t = InfoFromBlockParts { - recursivelyTransformedBlockDeclarations :: [LocalDeclaration (To t)], - upwardsInfoFromBlockDeclarations :: [Upwards t], - recursivelyTransformedBlockInstructions :: Program (To t), - upwardsInfoFromBlockInstructions :: Upwards t -} -data (TransformationPhase t) => InfoFromProgramParts t = InfoFromProgramParts { - recursivelyTransformedProgramConstruction :: ProgramConstruction (To t), - upwardsInfoFromProgramConstruction :: Upwards t -} -data (TransformationPhase t) => InfoFromPrimitiveParts t = InfoFromPrimitiveParts { - recursivelyTransformedPrimitiveInstruction :: Instruction (To t), - upwardsInfoFromPrimitiveInstruction :: Upwards t -} -data (TransformationPhase t) => InfoFromSequenceParts t = InfoFromSequenceParts { - recursivelyTransformedSequenceProgramList :: [Program (To t)], - upwardsInfoFromSequenceProgramList :: [Upwards t] -} -data (TransformationPhase t) => InfoFromBranchParts t = InfoFromBranchParts { - recursivelyTransformedBranchConditionVariable :: Variable (To t), - upwardsInfoFromBranchConditionVariable :: Upwards t, - recursivelyTransformedThenBlock :: Block (To t), - upwardsInfoFromThenBlock :: Upwards t, - recursivelyTransformedElseBlock :: Block (To t), - upwardsInfoFromElseBlock :: Upwards t -} -data (TransformationPhase t) => InfoFromSequentialLoopParts t = InfoFromSequentialLoopParts { - recursivelyTransformedSequentialLoopCondition :: Expression (To t), - upwardsInfoFromSequentialLoopCondition :: Upwards t, - recursivelyTransformedConditionCalculation :: Block (To t), - upwardsInfoFromConditionCalculation :: Upwards t, - recursivelyTransformedSequentialLoopCore :: Block (To t), - upwardsInfoFromSequentialLoopCore :: Upwards t -} -data (TransformationPhase t) => InfoFromParallelLoopParts t = InfoFromParallelLoopParts { - recursivelyTransformedParallelLoopConditionVariable :: Variable (To t), - upwardsInfoFromParallelLoopConditionVariable :: Upwards t, - recursivelyTransformedNumberOfIterations :: Expression (To t), - upwardsInfoFromNumberOfIterations :: Upwards t, - recursivelyTransformedParallelLoopCore :: Block (To t), - upwardsInfoFromParallelLoopCore :: Upwards t -} -data (TransformationPhase t) => InfoFromFormalParameterParts t = InfoFromFormalParameterParts { - recursivelyTransformedFormalParameterVariable :: Variable (To t), - upwardsInfoFromFormalParameterVariable :: Upwards t -} -data (TransformationPhase t) => InfoFromLocalDeclarationParts t = InfoFromLocalDeclarationParts { - recursivelyTransformedLocalVariable :: Variable (To t), - upwardsInfoFromLocalVariable :: Upwards t, - recursivelyTransformedLocalInitValue :: Maybe (Expression (To t)), - upwardsInfoFromLocalInitValue :: Maybe (Upwards t) -} -data (TransformationPhase t) => InfoFromExpressionParts t = InfoFromExpressionParts { - recursivelyTransformedExpressionData :: ExpressionData (To t), - upwardsInfoFromExpressionData :: Upwards t -} -data (TransformationPhase t) => InfoFromConstantParts t = InfoFromConstantParts { - recursivelyTransformedConstantData :: ConstantData (To t), - upwardsInfoFromConstantData :: Upwards t -} -data (TransformationPhase t) => InfoFromFunctionCallParts t = InfoFromFunctionCallParts { - recursivelyTransformedActualParametersOfFunctionToCall :: [Expression (To t)], - upwardsInfoFromActualParametersOfFunctionToCall :: [Upwards t] -} -data (TransformationPhase t) => InfoFromLeftValueParts t = InfoFromLeftValueParts { - recursivelyTransformedLeftValueData :: LeftValueData (To t), - upwardsInfoFromLeftValueData :: Upwards t -} -data (TransformationPhase t) => InfoFromArrayElemReferenceParts t = InfoFromArrayElemReferenceParts { - recursivelyTransformedArrayName :: LeftValue (To t), - upwardsInfoFromArrayName :: Upwards t, - recursivelyTransformedArrayIndex :: Expression (To t), - upwardsInfoFromArrayIndex :: Upwards t -} -data (TransformationPhase t) => InfoFromInstructionParts t = InfoFromInstructionParts { - recursivelyTransformedInstructionData :: InstructionData (To t), - upwardsInfoFromInstructionData :: Upwards t -} -data (TransformationPhase t) => InfoFromAssignmentParts t = InfoFromAssignmentParts { - recursivelyTransformedAssignmentLhs :: LeftValue (To t), - upwardsInfoFromAssignmentLhs :: Upwards t, - recursivelyTransformedAssignmentRhs :: Expression (To t), - upwardsInfoFromAssignmentRhs :: Upwards t -} -data (TransformationPhase t) => InfoFromProcedureCallParts t = InfoFromProcedureCallParts { - recursivelyTransformedActualParametersOfProcedureToCall :: [ActualParameter (To t)], - upwardsInfoFromActualParametersOfProcedureToCall :: [Upwards t] -} -data (TransformationPhase t) => InfoFromActualParameterParts t = InfoFromActualParameterParts { - recursivelyTransformedActualParameterData :: ActualParameterData (To t), - upwardsInfoFromActualParameterData :: Upwards t -} -data (TransformationPhase t) => InfoFromArrayConstantParts t = InfoFromArrayConstantParts { - recursivelyTransformedArrayConstantValue :: [Constant (To t)], - upwardsInfoFromArrayConstantValue :: [Upwards t] -} diff --git a/Feldspar/Compiler/PluginArchitecture/DefaultConvert.hs b/Feldspar/Compiler/PluginArchitecture/DefaultConvert.hs deleted file mode 100644 --- a/Feldspar/Compiler/PluginArchitecture/DefaultConvert.hs +++ /dev/null @@ -1,125 +0,0 @@ --- --- Copyright (c) 2009-2010, 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, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-} - -module Feldspar.Compiler.PluginArchitecture.DefaultConvert where - -import Feldspar.Compiler.Imperative.Semantics --- =========================================================================== --- == Defaults --- =========================================================================== - -class Default t where - defaultValue :: t - defaultValue = error "Default value requested." - -class Combine t where - combine :: t -> t -> t - combine = error "Default combination function used." - -instance Default Int where - defaultValue = 0 -instance Combine Int where - combine = (+) - -instance Default Bool where - defaultValue = False - -instance Default () where - defaultValue = () -instance Combine () where - combine _ _ = () - -instance (Default a, Default b) => Default (a,b) where - defaultValue = (defaultValue, defaultValue) - -class Convert a b where - convert :: a -> b - -instance Default b => Convert a b where - convert _ = defaultValue - --- ==================================================================================================== --- == ConvertAllInfos class & instance --- ==================================================================================================== -class (SemanticInfo from, SemanticInfo to - , Convert(ProcedureInfo from) (ProcedureInfo to) - , Convert(BlockInfo from) (BlockInfo to) - , Convert(ProgramInfo from) (ProgramInfo to) - , Convert(EmptyInfo from) (EmptyInfo to) - , Convert(PrimitiveInfo from) (PrimitiveInfo to) - , Convert(SequenceInfo from) (SequenceInfo to) - , Convert(BranchInfo from) (BranchInfo to) - , Convert(SequentialLoopInfo from) (SequentialLoopInfo to) - , Convert(ParallelLoopInfo from) (ParallelLoopInfo to) - , Convert(FormalParameterInfo from) (FormalParameterInfo to) - , Convert(LocalDeclarationInfo from) (LocalDeclarationInfo to) - , Convert(ExpressionInfo from) (ExpressionInfo to) - , Convert(ConstantInfo from) (ConstantInfo to) - , Convert(FunctionCallInfo from) (FunctionCallInfo to) - , Convert(LeftValueInfo from) (LeftValueInfo to) - , Convert(ArrayElemReferenceInfo from) (ArrayElemReferenceInfo to) - , Convert(InstructionInfo from) (InstructionInfo to) - , Convert(AssignmentInfo from) (AssignmentInfo to) - , Convert(ProcedureCallInfo from) (ProcedureCallInfo to) - , Convert(ActualParameterInfo from) (ActualParameterInfo to) - , Convert(IntConstantInfo from) (IntConstantInfo to) - , Convert(FloatConstantInfo from) (FloatConstantInfo to) - , Convert(BoolConstantInfo from) (BoolConstantInfo to) - , Convert(ArrayConstantInfo from) (ArrayConstantInfo to) - , Convert(VariableInfo from) (VariableInfo to) - ) => ConvertAllInfos from to - -instance (SemanticInfo from, SemanticInfo to - , Convert(ProcedureInfo from) (ProcedureInfo to) - , Convert(BlockInfo from) (BlockInfo to) - , Convert(ProgramInfo from) (ProgramInfo to) - , Convert(EmptyInfo from) (EmptyInfo to) - , Convert(PrimitiveInfo from) (PrimitiveInfo to) - , Convert(SequenceInfo from) (SequenceInfo to) - , Convert(BranchInfo from) (BranchInfo to) - , Convert(SequentialLoopInfo from) (SequentialLoopInfo to) - , Convert(ParallelLoopInfo from) (ParallelLoopInfo to) - , Convert(FormalParameterInfo from) (FormalParameterInfo to) - , Convert(LocalDeclarationInfo from) (LocalDeclarationInfo to) - , Convert(ExpressionInfo from) (ExpressionInfo to) - , Convert(ConstantInfo from) (ConstantInfo to) - , Convert(FunctionCallInfo from) (FunctionCallInfo to) - , Convert(LeftValueInfo from) (LeftValueInfo to) - , Convert(ArrayElemReferenceInfo from) (ArrayElemReferenceInfo to) - , Convert(InstructionInfo from) (InstructionInfo to) - , Convert(AssignmentInfo from) (AssignmentInfo to) - , Convert(ProcedureCallInfo from) (ProcedureCallInfo to) - , Convert(ActualParameterInfo from) (ActualParameterInfo to) - , Convert(IntConstantInfo from) (IntConstantInfo to) - , Convert(FloatConstantInfo from) (FloatConstantInfo to) - , Convert(BoolConstantInfo from) (BoolConstantInfo to) - , Convert(ArrayConstantInfo from) (ArrayConstantInfo to) - , Convert(VariableInfo from) (VariableInfo to) - ) => ConvertAllInfos from to diff --git a/Feldspar/Compiler/Plugins/BackwardPropagation.hs b/Feldspar/Compiler/Plugins/BackwardPropagation.hs deleted file mode 100644 --- a/Feldspar/Compiler/Plugins/BackwardPropagation.hs +++ /dev/null @@ -1,308 +0,0 @@ --- --- Copyright (c) 2009-2010, 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, FlexibleInstances #-} - -module Feldspar.Compiler.Plugins.BackwardPropagation ( - BackwardPropagation(..) - ) - where - -import Feldspar.Compiler.PluginArchitecture -import Feldspar.Compiler.Plugins.PropagationUtils -import qualified Data.Map as Map -import qualified Data.List as List -import qualified Data.Set as Set -import Data.Maybe -import Feldspar.Compiler.Options - --- =========================================================================== --- == Copy propagation plugin (backward) --- =========================================================================== - -type VarStatBck = VarStatistics () - -data BackwardPropagation = BackwardPropagation - -instance TransformationPhase BackwardPropagation where - type From BackwardPropagation = InitSemInf - type To BackwardPropagation = () - type Downwards BackwardPropagation = () - type Upwards BackwardPropagation = () - -instance Plugin BackwardPropagation where - type ExternalInfo BackwardPropagation = DebugOption - executePlugin BackwardPropagation externalInfo procedure - | externalInfo == NoSimplification = fst $ executeTransformationPhase BackwardPropagation () procedure - | otherwise = fst $ executeTransformationPhase PropagationTransform [] $ fst $ executeTransformationPhase BackwardPropagationCollect (Occurrence_read,False) procedure - --- ==================== --- Collect --- ==================== - -instance Default [(VariableData, LeftValueData ())] where - defaultValue = [] - --- meaning (out,var,out written in a sequence before out=var) -instance Default [(VariableData, LeftValueData (),Bool)] where - defaultValue = [] - -instance Combine (VarStatBck, [(VariableData, LeftValueData (),Bool)]) where - combine (m1,x1) (m2,x2) = (combine m1 m2, x1 ++ x2) - -instance Default (Maybe (VariableData, LeftValueData (),Bool)) where - defaultValue = Nothing - -data BackwardPropagationSemInf - -instance SemanticInfo BackwardPropagationSemInf where - type ProcedureInfo BackwardPropagationSemInf = () - type BlockInfo BackwardPropagationSemInf = [(VariableData, LeftValueData ())] --replacements inside block - type ProgramInfo BackwardPropagationSemInf = () - type EmptyInfo BackwardPropagationSemInf = () - type PrimitiveInfo BackwardPropagationSemInf = Maybe (VariableData, LeftValueData (), Bool) --if the primitive is a copy assignment the datas of the assigment, just because when we delete primitives at 2nd phase we need this - type SequenceInfo BackwardPropagationSemInf = () - type BranchInfo BackwardPropagationSemInf = () - type SequentialLoopInfo BackwardPropagationSemInf = () - type ParallelLoopInfo BackwardPropagationSemInf = () - type FormalParameterInfo BackwardPropagationSemInf = () - type LocalDeclarationInfo BackwardPropagationSemInf = () - type ExpressionInfo BackwardPropagationSemInf = () - type ConstantInfo BackwardPropagationSemInf = () - type FunctionCallInfo BackwardPropagationSemInf = () - type LeftValueInfo BackwardPropagationSemInf = () - type ArrayElemReferenceInfo BackwardPropagationSemInf = () - type InstructionInfo BackwardPropagationSemInf = () - type AssignmentInfo BackwardPropagationSemInf = () - type ProcedureCallInfo BackwardPropagationSemInf = () - type ActualParameterInfo BackwardPropagationSemInf = () - type IntConstantInfo BackwardPropagationSemInf = () - type FloatConstantInfo BackwardPropagationSemInf = () - type BoolConstantInfo BackwardPropagationSemInf = () - type ArrayConstantInfo BackwardPropagationSemInf = () - type VariableInfo BackwardPropagationSemInf = () - -data BackwardPropagationCollect = BackwardPropagationCollect - -instance TransformationPhase BackwardPropagationCollect where - type From BackwardPropagationCollect = InitSemInf - type To BackwardPropagationCollect = BackwardPropagationSemInf - type Downwards BackwardPropagationCollect = (Occurrence_place, Bool) - type Upwards BackwardPropagationCollect = (VarStatBck, [(VariableData, LeftValueData (),Bool)]) - downwardsBranchProgramInProgram self d orig = (occurrenceDownwards orig, False) - downwardsSequentialLoopProgramInProgram self d orig = (occurrenceDownwards orig, False) - downwardsParallelLoopProgramInProgram self d orig = (occurrenceDownwards orig, False) - downwardsFormalParameter self d orig = (occurrenceDownwards orig, False) - downwardsLocalDeclaration self d orig = (occurrenceDownwards orig, isJust $ localInitValue orig) - downwardsAssignmentInstructionInInstruction self d orig = (occurrenceDownwards orig, False) - downwardsActualParameter self d orig = (occurrenceDownwards orig, False) - downwardsExpression self d orig = (occurrenceDownwards orig, False) - upwardsVariable self (d,me) origVar newVar = case d of - Occurrence_declare - | me -> (Map.singleton (variableData origVar) $ Occurrences (One Nothing) Zero, []) - | otherwise -> (Map.singleton (variableData origVar) $ Occurrences Zero Zero, []) - Occurrence_read -> (Map.singleton (variableData origVar) $ Occurrences Zero (One ()), []) - Occurrence_write -> (Map.singleton (variableData origVar) $ Occurrences (One Nothing) Zero, []) - Occurrence_notopt -> (Map.singleton (variableData origVar) $ Occurrences Multiple Multiple, []) - upwardsPrimitiveProgramInProgram self d origPrimitive u newPrimitive = case newPrimitive of - PrimitiveProgram newPr -> case primitiveSemInf newPr of - Just e -> (fst $ upwardsInfoFromPrimitiveInstruction u, [e]) - Nothing -> upwardsInfoFromPrimitiveInstruction u - _ -> upwardsInfoFromPrimitiveInstruction u - - upwardsBlock self d origBlock u newBlock = (deleteFromVarStatistics (map (fst) $ blockSemInf newBlock) $ fst $ upwardsInfoFromBlockInstructions u,[]) - upwardsSequenceProgramInProgram self d origiSeq u transformedSequence = checkInSequence $ upwardsInfoFromSequenceProgramList u - transformBlock self d origBlock u = Block { - blockDeclarations = recursivelyTransformedBlockDeclarations u, - blockInstructions = recursivelyTransformedBlockInstructions u, - blockSemInf = checkInDeclatation origBlock $ upwardsInfoFromBlockInstructions u - } - transformPrimitiveProgramInProgram self d origPrimitive u = PrimitiveProgram $ Primitive { - primitiveInstruction = recursivelyTransformedPrimitiveInstruction u, - primitiveSemInf = getNames origPrimitive - } - -getNames :: (SemanticInfo t) => Primitive t -> Maybe (VariableData, LeftValueData (),Bool) -getNames pr = getNames' $ instructionData $ primitiveInstruction pr where - getNames' (AssignmentInstruction _) = Nothing - getNames' (ProcedureCallInstruction pc) - | goodName pc = getParamNames $ map actualParameterData $ actualParametersOfProcedureToCall pc - | otherwise = Nothing - goodName pc = "copy" == (nameOfProcedureToCall pc) - getParamNames [InputActualParameter i, OutputActualParameter o] = pairJust (getIName i) (getOName o) - getParamNames _ = Nothing - pairJust (Just a) (Just b) = Just (a,b,False) - pairJust _ _ = Nothing - getIName i = getExpName $ expressionData i - getOName o = Just $ deleteSemInf $ leftValueData o - getExpName (LeftValueExpression lv) = getLvName_noarr $ leftValueData lv - getExpName _ = Nothing - getLvName_noarr (VariableLeftValue v) = Just $ variableData v - getLvName_noarr _ = Nothing - -getLvName :: (SemanticInfo t) => LeftValueData t -> VariableData -getLvName (VariableLeftValue v) = variableData v -getLvName (ArrayElemReferenceLeftValue aer) = getLvName $ leftValueData $ arrayName aer - -checkInSequence :: [(VarStatBck, [(VariableData, LeftValueData (), Bool)])] -> (VarStatBck, [(VariableData, LeftValueData (), Bool)]) -checkInSequence [] = defaultValue -checkInSequence xs = (varstat $ map fst xs, mapMaybe (checkSeq xs False False False) $ foldl (\ls (vs,s) -> s++ls) [] xs) - where - varstat :: [VarStatBck] -> VarStatBck - varstat = foldl combine defaultValue - checkSeq :: [(VarStatBck, [(VariableData, LeftValueData (), Bool)])] -> Bool{-usedVar-} -> Bool{-usedOut-} -> Bool{-after-} -> (VariableData {-var-}, LeftValueData () {-out-}, Bool) -> Maybe (VariableData, LeftValueData (), Bool) - checkSeq [] _ usedOut _ (var,outD,outUsedLower) = Just (var,outD,usedOut) - checkSeq ((vs,s):ys) usedVar usedOut after sp@(var,outD,outUsedLower) - | after && (vs `notUse` var) = checkSeq ys usedVar usedOut after sp - | after {- && (vs `hasUse` var) -} = Nothing - | {-(not after) && -} (sp `List.elem` s) && ((not outUsedLower) || (not usedVar)) = checkSeq ys usedVar usedOut True sp - | {-(not after) && -} usedVar && (vs `notUse` out) = checkSeq ys usedVar usedOut after sp - | {-(not after) && -} usedVar {- && (vs `hasUse` out)-} = Nothing - | {-(not after) && (not usedVar) && -} (vs `hasRead` var) && (vs `notUse` out) = checkSeq ys True usedOut after sp - | {-(not after) && (not usedVar) && -} (vs `hasRead` var) {- && (vs `hasUse` out) -} = Nothing - | {-(not after) && (not usedVar) && -} (vs `hasWrite` var) && (vs `hasWrite` out) = Nothing - | {-(not after) && (not usedVar) && -} (vs `hasWrite` var) {- && (vs `notWrite` out)-} = checkSeq ys True usedOut after sp - | {-(not after) && (not usedVar) && (vs `notUse` var) && -} (vs `hasUse` out) = checkSeq ys usedVar True after sp - | {-(not after) && (not usedVar) && (vs `notUse` var) && (vs `notUse` out)-} otherwise = checkSeq ys usedVar usedOut after sp - where - out = getLvName outD -{- -check the sequence format: -______________ -| use out | -| ___________| -|__|= | -| use var | -|_____________| -out = var -______________ -| not use var | -|_____________| - -| --} - -checkInDeclatation :: Block InitSemInf -> (VarStatBck, [(VariableData, LeftValueData (), Bool)]) -> [(VariableData, LeftValueData ())] -checkInDeclatation origBlock u = mapMaybe (checkDecl $ decl) (snd u) where - decl = blockDeclarations origBlock - checkDecl :: [LocalDeclaration InitSemInf] -> (VariableData, LeftValueData (), Bool) -> Maybe (VariableData, LeftValueData ()) - checkDecl lds (var,outD,outUsedLower) = case List.find (\ld -> var == declaredVar ld) lds of - Nothing -> Nothing - Just ld -> case localInitValue ld of - Nothing -> Just (var,outD) - Just exp -> case outUsedLower of - True -> Nothing - False -> Just (var,outD) -{- -check var get initValue, because it is a write, and it means we can't use out because "out=var" --} - --- ==================== --- BackwardPropagation --- ==================== - -data PropagationTransform = PropagationTransform - -instance TransformationPhase PropagationTransform where - type From PropagationTransform = BackwardPropagationSemInf - type To PropagationTransform = () - type Downwards PropagationTransform = [(VariableData, LeftValueData ())] - type Upwards PropagationTransform = () - downwardsBlock self d origBlock = unChain $ foldl addChain (blockSemInf origBlock) d - downwardsLocalDeclaration self d origLocDecl = [] - transformBlock self d orig u = delUnusedDecl (map fst $ downwardsBlock self d orig) orig (recursivelyTransformedBlockDeclarations u) (recursivelyTransformedBlockInstructions u) - transformPrimitiveProgramInProgram self d origPrimitive u = - case isIdentity $ instructionData newInstr of - True -> EmptyProgram $ Empty () - False -> makedPrim - where - makedPrim = PrimitiveProgram $ Primitive { - primitiveInstruction = newInstr, - primitiveSemInf =() - } - newInstr = recursivelyTransformedPrimitiveInstruction u - isIdentity (AssignmentInstruction a) = isIdentity' (assignmentRhs a) (assignmentLhs a) - isIdentity (ProcedureCallInstruction p) - | nameOfProcedureToCall p == "copy" = case map actualParameterData $ actualParametersOfProcedureToCall p of - [InputActualParameter i,OutputActualParameter o] -> isIdentity' i o - _ -> False - | otherwise = False - isIdentity' e l = List.elem (expressionData e) [LeftValueExpression $ swapArrayIndex l, LeftValueExpression l] - swapArrayIndex :: LeftValue () -> LeftValue () - swapArrayIndex l = setIndex $ (\(a,b)->(a,reverse b)) $ getIndex l - getIndex :: LeftValue () -> (Variable (), [Expression ()]) - getIndex lv = getIndex2 $ leftValueData lv - getIndex2 (VariableLeftValue v) = (v,[]) - getIndex2 (ArrayElemReferenceLeftValue a) = (fst $ getIndex $ arrayName a, (arrayIndex a):(snd $ getIndex $ arrayName a)) - setIndex :: (Variable (), [Expression ()]) -> LeftValue () - setIndex x = LeftValue (setIndex2 x) () - setIndex2 (v,[]) = VariableLeftValue v - setIndex2 (v,(x:xs)) = ArrayElemReferenceLeftValue $ ArrayElemReference (setIndex (v,xs)) x () - transformVariableLeftValueInLeftValue self d origVar = case List.find (\(a,b) -> a == variableData origVar) d of - Nothing -> VariableLeftValue $ origVar { - variableSemInf = () - } - Just (var,out) -> out - -unChain :: [(VariableData, LeftValueData ())] -> [(VariableData, LeftValueData ())] -unChain s = unchain' s where - unchain' s - | s == unchain'' s = s - | otherwise = unchain'' s - unchain'' s = foldl addChain [] s - -addChain :: [(VariableData, LeftValueData ())] -> (VariableData, LeftValueData ()) -> [(VariableData, LeftValueData ())] -addChain [] pair = [pair] -addChain (x@(mibe1,mit1):xs) r@(mibe2,mit2) - | (getLvName mit1) == mibe2 = (mibe1,changeInnerArrayName mit1 mit2):r:xs - | (getLvName mit2) == mibe1 = (mibe2,changeInnerArrayName mit2 mit1):x:xs - | otherwise = x:(addChain xs r) - where - changeInnerArrayName :: LeftValueData () {-toChange-} -> LeftValueData () {-newName-} -> LeftValueData () - changeInnerArrayName toChange (ArrayElemReferenceLeftValue aer) = ArrayElemReferenceLeftValue aer { - arrayName = LeftValue (changeInnerArrayName toChange $ leftValueData $ arrayName aer) () - } - changeInnerArrayName (ArrayElemReferenceLeftValue aer) newName@(VariableLeftValue _) = ArrayElemReferenceLeftValue aer { - arrayName = LeftValue (changeInnerArrayName (leftValueData $ arrayName aer) newName) () - } - changeInnerArrayName (VariableLeftValue _) newName@(VariableLeftValue _) = newName - -{- -addChain [ (a, b) ] (b, c) = [ (a, b), (a, c) ] -addChain [ (a, b) ] (b[i],c) = [ (a, b), (a[i], c) ] -addChain [ (a[m],b) ] (b[i],c) = [ (a[m],b), (a[m][i], c) ] -addChain [ (b, c) ] (a, b) = [ (a, b), (a, c) ] -addChain [ (b, c) ] (a[i],b) = [ (a, b), (a[i], c) ] -addChain [ (b[i],c) ] (a[m],b) = [ (a[m],b), (a[m][i], c) ] - -but arrayof(arrayof(lv,index1)index2) = lv[index2][index1] -so first go down in newNames indexes and put these outwards -then go down toChanges indexes, and when no indexes change - --} - diff --git a/Feldspar/Compiler/Plugins/ForwardPropagation.hs b/Feldspar/Compiler/Plugins/ForwardPropagation.hs deleted file mode 100644 --- a/Feldspar/Compiler/Plugins/ForwardPropagation.hs +++ /dev/null @@ -1,344 +0,0 @@ --- --- Copyright (c) 2009-2010, 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, FlexibleInstances #-} - -module Feldspar.Compiler.Plugins.ForwardPropagation ( - ForwardPropagation(..) - ) - where - -import Feldspar.Compiler.PluginArchitecture -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.List as List -import Feldspar.Compiler.Plugins.PropagationUtils -import Feldspar.Compiler.Error -import Feldspar.Compiler.Options -import Feldspar.Compiler.Imperative.CodeGeneration (simpleType) - -fwdPropError = handleError "PluginArch/ForwardPropagation" InternalError - --- =========================================================================== --- == Copy propagation plugin (forward) --- =========================================================================== - -type VarStatFwd = VarStatistics (ExpressionData ForwardPropagationSemInf, [VariableData], Bool) -type OccurrencesFwd = Occurrences (ExpressionData ForwardPropagationSemInf, [VariableData], Bool) - -data ForwardPropagation = ForwardPropagation - -instance Plugin ForwardPropagation where - type ExternalInfo ForwardPropagation = DebugOption - executePlugin ForwardPropagation externalInfo procedure - | externalInfo == NoSimplification || externalInfo == NoPrimitiveInstructionHandling = procedure - | otherwise = fst $ executeTransformationPhase ForwardPropagationTransform (fst globals1) procedureCollected1 - where - (procedureCollected1,globals1) = executeTransformationPhase ForwardPropagationCollect Occurrence_read procedure - -instance TransformationPhase ForwardPropagation where - type From ForwardPropagation = () - type To ForwardPropagation = () - type Downwards ForwardPropagation = () - type Upwards ForwardPropagation = () - --- ==================== --- Collect --- ==================== - -data ForwardPropagationSemInf - -instance SemanticInfo ForwardPropagationSemInf where - type ProcedureInfo ForwardPropagationSemInf = () - type BlockInfo ForwardPropagationSemInf = VarStatFwd - type ProgramInfo ForwardPropagationSemInf = () - type EmptyInfo ForwardPropagationSemInf = () - type PrimitiveInfo ForwardPropagationSemInf = () - type SequenceInfo ForwardPropagationSemInf = () - type BranchInfo ForwardPropagationSemInf = () - type SequentialLoopInfo ForwardPropagationSemInf = VarStatFwd - type ParallelLoopInfo ForwardPropagationSemInf = () - type FormalParameterInfo ForwardPropagationSemInf = () - type LocalDeclarationInfo ForwardPropagationSemInf = () - type ExpressionInfo ForwardPropagationSemInf = () - type ConstantInfo ForwardPropagationSemInf = () - type FunctionCallInfo ForwardPropagationSemInf = () - type LeftValueInfo ForwardPropagationSemInf = () - type ArrayElemReferenceInfo ForwardPropagationSemInf = Maybe VariableData --name of the indexed variable - type InstructionInfo ForwardPropagationSemInf = () - type AssignmentInfo ForwardPropagationSemInf = () - type ProcedureCallInfo ForwardPropagationSemInf = () - type ActualParameterInfo ForwardPropagationSemInf = () - type IntConstantInfo ForwardPropagationSemInf = () - type FloatConstantInfo ForwardPropagationSemInf = () - type BoolConstantInfo ForwardPropagationSemInf = () - type ArrayConstantInfo ForwardPropagationSemInf = () - type VariableInfo ForwardPropagationSemInf = Occurrence_place - -instance Combine (VarStatFwd, Maybe VariableData) where - combine a b = (combine (fst a) $ fst b, Nothing) - -data ForwardPropagationCollect = ForwardPropagationCollect - -instance TransformationPhase ForwardPropagationCollect where - type From ForwardPropagationCollect = () - type To ForwardPropagationCollect = ForwardPropagationSemInf - type Downwards ForwardPropagationCollect = Occurrence_place - type Upwards ForwardPropagationCollect = (VarStatFwd, Maybe VariableData) - downwardsBranchProgramInProgram self d orig = occurrenceDownwards orig - downwardsSequentialLoopProgramInProgram self d orig = occurrenceDownwards orig - downwardsParallelLoopProgramInProgram self d orig = occurrenceDownwards orig - downwardsFormalParameter self d orig = occurrenceDownwards orig - downwardsLocalDeclaration self d orig = occurrenceDownwards orig - downwardsAssignmentInstructionInInstruction self d orig = occurrenceDownwards orig - downwardsActualParameter self d orig = occurrenceDownwards orig - downwardsInputActualParameterInActualParameter self d orig = occurrenceDownwards orig - downwardsExpression self d orig = occurrenceDownwards orig - transformBlock self d origBlock u = Block { - blockDeclarations = recursivelyTransformedBlockDeclarations u, - blockInstructions = recursivelyTransformedBlockInstructions u, - blockSemInf = selectFromVarStatistics ( declaredVars origBlock) belowStatistics - } where - belowStatistics = checkFwdDeclaration (map fst $ upwardsInfoFromBlockDeclarations u) (fst $ upwardsInfoFromBlockInstructions u) - transformVariable self d origVar = origVar { - variableSemInf = d - } - upwardsVariable self d origVar newVar = case d of - Occurrence_declare -> (Map.singleton (variableData origVar) $ Occurrences Zero Zero, Just $ variableData origVar) - Occurrence_read -> (Map.singleton (variableData origVar) $ Occurrences Zero (One ()), Just $ variableData origVar) - Occurrence_write -> (Map.singleton (variableData origVar) $ Occurrences (One Nothing) Zero, Just $ variableData origVar) - Occurrence_notopt -> (Map.singleton (variableData origVar) $ Occurrences Multiple Multiple, Just $ variableData origVar) --LIE to save variables - upwardsSequenceProgramInProgram self d origSeq u transSeq = (checkFwdSequence $ map fst $ upwardsInfoFromSequenceProgramList u, Nothing) - upwardsBlock self d origBlock u newBlock = (deleteFromVarStatistics (declaredVars origBlock) belowStatistics, Nothing) where - belowStatistics = foldl combine (fst $ upwardsInfoFromBlockInstructions u) $ map fst $ upwardsInfoFromBlockDeclarations u - upwardsParallelLoopProgramInProgram self d origParLoop u transParLoop = (multipleVarStatistics $ - foldl combine (fst $ upwardsInfoFromParallelLoopConditionVariable u) - [fst $ upwardsInfoFromNumberOfIterations u, fst $ upwardsInfoFromParallelLoopCore u], Nothing) - upwardsAssignmentInstructionInInstruction self d origAssign u transAssig = case leftValueData $ assignmentLhs origAssign of - VariableLeftValue vlv -> (Map.insert var occ $ fst $ upwardsInfoFromAssignmentRhs u, Nothing) - where - var = variableData vlv - occ = Occurrences (One $ Just (assRs, Map.keys $ fst $ upwardsInfoFromAssignmentRhs u, False)) Zero - assRs = case transAssig of - AssignmentInstruction newAssign -> expressionData $ assignmentRhs newAssign - _ -> fwdPropError $ "Internal error: ForwardPropagation/1!" - ArrayElemReferenceLeftValue aer -> (combine (fst $ upwardsInfoFromAssignmentLhs u) (fst $ upwardsInfoFromAssignmentRhs u), Nothing) - upwardsLocalDeclaration self d origDecl u newDecl = case localInitValue newDecl of - Nothing -> defaultCase - Just exp -> case expressionData exp of - ConstantExpression (Constant (ArrayConstant ac) ()) -> defaultCase - initExp -> case upwardsInfoFromLocalInitValue u of - Nothing -> defaultCase - Just justUpFromLocalInitValue -> (Map.insert var (occ initExp $ fst justUpFromLocalInitValue) $ fst justUpFromLocalInitValue, Nothing) - where - var = variableData $ localVariable origDecl - occ initExp justUpFromLocalInitValue = Occurrences (One $ Just (initExp, Map.keys justUpFromLocalInitValue, False)) Zero - defaultCase = (fst $ upwardsInfoFromLocalVariable u, Nothing) - upwardsProcedureCallInstructionInInstruction self d origProcCall u transProcCall - | List.isPrefixOf "copy" $ nameOfProcedureToCall origProcCall = case map actualParameterData actParams of -- TODO: eliminate string constant - [InputActualParameter inArr, InputActualParameter arrSize, OutputActualParameter outArr] -> - case leftValueData outArr of - VariableLeftValue vlv -> (Map.insert (var vlv) (occ inArr) $ fst $ head ul, Nothing) - ArrayElemReferenceLeftValue aer -> defaultTr - _ -> defaultTr - | otherwise = defaultTr - where - defaultTr = case ul of - [] -> defaultValue - otherwise -> foldl combine (head ul) (tail ul) - ul = upwardsInfoFromActualParametersOfProcedureToCall u - actParams = case transProcCall of - ProcedureCallInstruction pc -> actualParametersOfProcedureToCall pc - _ -> fwdPropError $ "Internal error: ForwardPropagation/2!" - var vlv = variableData vlv - occ inArr = Occurrences (One $ Just (expressionData inArr, Map.keys $ fst $ head ul, False)) Zero - transformSequentialLoopProgramInProgram self d origSeqLoop u = SequentialLoopProgram $ origSeqLoop { - sequentialLoopCondition = recursivelyTransformedSequentialLoopCondition u, - conditionCalculation = (recursivelyTransformedConditionCalculation u) { - blockSemInf = Map.empty - }, - sequentialLoopCore = recursivelyTransformedSequentialLoopCore u, - sequentialLoopSemInf = blockSemInf $ recursivelyTransformedConditionCalculation u - } - - upwardsSequentialLoopProgramInProgram self d origSeqLoop u newSeqLoop = (multipleVarStatistics $ - combine (deleteFromVarStatistics [condVar] $ fst $ upwardsInfoFromSequentialLoopCondition u) $ fst $ upwardsInfoFromSequentialLoopCore u, Nothing) - where - condVar = head $ Map.keys $ fst $ upwardsInfoFromSequentialLoopCondition u - transformArrayElemReferenceLeftValueInLeftValue self d origArrRef u = ArrayElemReferenceLeftValue $ ArrayElemReference { - arrayName = recursivelyTransformedArrayName u, - arrayIndex = recursivelyTransformedArrayIndex u, - arrayElemReferenceSemInf = snd $ upwardsInfoFromArrayName u - } - upwardsArrayElemReferenceLeftValueInLeftValue self d origArrayRef u transArrayRefe = - (combine (fst $ upwardsInfoFromArrayName u) (fst $ upwardsInfoFromArrayIndex u), snd $ upwardsInfoFromArrayName u) - --upwardsLeftValue self d origLV u transLV = upwardsInfoFromLeftValueData u - upwardsVariableLeftValueInLeftValue self d origVar transVar = upwardsVariable self d origVar $ transformVariable self d origVar - transformVariableLeftValueInLeftValue self d origVar = VariableLeftValue $ transformVariable self d origVar - -checkFwdSequence :: [VarStatFwd] -> VarStatFwd -checkFwdSequence [] = defaultValue -checkFwdSequence xs = List.foldl checkInSeq Map.empty xs - where - checkInSeq :: VarStatFwd -> VarStatFwd -> VarStatFwd - checkInSeq preSeq curr = combine curr $ Map.mapWithKey (updatePreSeq curr) preSeq - updatePreSeq :: VarStatFwd -> VariableData -> OccurrencesFwd -> OccurrencesFwd - updatePreSeq curr preSeqVar preSeqOcc = case writeVar preSeqOcc of - One (Just (preSeqExp,preSeqVars,preSeqVarsWritten)) - | preSeqVarsWritten && curr `hasRead` preSeqVar -> Occurrences (One Nothing) $ readVar preSeqOcc - | any (hasWrite curr) preSeqVars -> case (curr `hasRead` preSeqVar) && not ((simpleType $ variableDataType preSeqVar) && readVar preSeqOcc /= Multiple) of - True -> Occurrences (One Nothing) $ readVar preSeqOcc - False -> Occurrences (One (Just (preSeqExp,preSeqVars ++ (addDep curr preSeqVar),True))) $ readVar preSeqOcc - | otherwise -> case curr `getWrite` preSeqVar of - Nothing -> preSeqOcc - Just (exp,vars,varsWritten) - | exp == preSeqExp -> Occurrences Zero $ readVar preSeqOcc - | otherwise -> preSeqOcc - _ -> preSeqOcc - addDep curr preSeqVar = case curr `getWrite` preSeqVar of - Nothing -> [] - Just (exp,vars,varsWritten) -> vars - -checkFwdDeclaration :: [VarStatFwd] -> VarStatFwd -> VarStatFwd -checkFwdDeclaration [] blockStat = blockStat -checkFwdDeclaration declStat blockStat = checkFwdSequence $ declStat ++ [blockStat] - --- ==================== --- ForwardPropagation --- ==================== - -type VarWrite t = [(VariableData,ExpressionData t)] - -toVarWrite :: VarStatFwd -> VarWrite ForwardPropagationSemInf -toVarWrite vs = Map.foldWithKey (getExp) [] vs where - getExp :: VariableData -> OccurrencesFwd -> VarWrite ForwardPropagationSemInf -> VarWrite ForwardPropagationSemInf - getExp name (Occurrences (One (Just (exp,_,_))) reads) vw - | reads /= Multiple && notConstArray exp = (name,exp):vw --used once and complex expr - | simpleExpr exp = (name,exp):vw --used several and simple expr - | otherwise = vw - getExp name _ vw = vw - notConstArray e = case e of - ConstantExpression (Constant c _) -> simplConst c - _ -> True - simpleExpr e = case e of - ConstantExpression (Constant c _) -> simplConst c - LeftValueExpression l -> case leftValueData l of - VariableLeftValue v -> True - ArrayElemReferenceLeftValue a -> simpleExpr $ expressionData $ arrayIndex a - _ -> False - simplConst (ArrayConstant ac) = False - simplConst _ = True - -data ForwardPropagationTransform = ForwardPropagationTransform - -instance TransformationPhase ForwardPropagationTransform where - type From ForwardPropagationTransform = ForwardPropagationSemInf - type To ForwardPropagationTransform = () - type Downwards ForwardPropagationTransform = VarStatFwd - type Upwards ForwardPropagationTransform = Set.Set VariableData - downwardsBlock self d origBlock = combine d $ blockSemInf origBlock - downwardsSequentialLoopProgramInProgram self d origSeqLoop = combine d $ sequentialLoopSemInf origSeqLoop - transformLeftValueExpressionInExpression self d origLV u = case leftValueData origLV of - VariableLeftValue origVar -> case List.find (\(vn,e) -> (vn == variableData origVar)) varwrite of - Nothing -> defaultTr - Just repl -> expressionData $ fst $ walkExpression self d $ Expression (snd repl) () - ArrayElemReferenceLeftValue origArr -> defaultTr - where - varwrite = toVarWrite d - defaultTr = LeftValueExpression $ LeftValue { - leftValueData = recursivelyTransformedLeftValueData u, - leftValueSemInf = () - } - transformVariableLeftValueInLeftValue self d origVar = case List.find (\(vn,e) -> (vn == var)) varwrite of - Nothing -> defaultTr - Just repl -> case repl of - (_,LeftValueExpression lv) -> leftValueData $ fst $ walkLeftValue self d lv - _ -> defaultTr - where - var = variableData origVar - varwrite = toVarWrite d - defaultTr = VariableLeftValue $ origVar { - variableSemInf = () - } - transformArrayElemReferenceLeftValueInLeftValue self d origArrayRef u = case List.find (\(vn,e) -> (vn == var)) varwrite of - Nothing -> defaultTr - Just repl -> case repl of - (_,LeftValueExpression lv) -> case leftValueData lv of - VariableLeftValue vlv -> defaultTr - ArrayElemReferenceLeftValue aer -> ArrayElemReferenceLeftValue $ ArrayElemReference { - arrayName = fst $ walkLeftValue self (swapArrayIndex d var aer origArrayRef) $ arrayName origArrayRef, - arrayIndex = fst $ walkExpression self d $ arrayIndex aer, - arrayElemReferenceSemInf = () - } - _ -> defaultTr - where - swapArrayIndex :: VarStatFwd -> VariableData -> ArrayElemReference ForwardPropagationSemInf -> ArrayElemReference ForwardPropagationSemInf -> VarStatFwd - swapArrayIndex d var rep orig = Map.adjust (swapArrayIndex2 var rep orig) var d - swapArrayIndex2 var rep orig x = x { - writeVar = One $ Just ( LeftValueExpression $ LeftValue { - leftValueData = ArrayElemReferenceLeftValue $ ArrayElemReference { - arrayName = arrayName rep, - arrayIndex = arrayIndex orig, - arrayElemReferenceSemInf = Just var - }, - leftValueSemInf = () - },[],False) - } - var = getJust $ arrayElemReferenceSemInf origArrayRef - getJust (Just a) = a - getJust _ = fwdPropError $ "Internal error: ForwardPropagation/3!" - varwrite = toVarWrite d - defaultTr = ArrayElemReferenceLeftValue $ ArrayElemReference { - arrayName = recursivelyTransformedArrayName u, - arrayIndex = recursivelyTransformedArrayIndex u, - arrayElemReferenceSemInf = convert $ arrayElemReferenceSemInf origArrayRef - } - upwardsVariable self d origVar newVar = case variableSemInf origVar of - Occurrence_declare -> Set.empty - Occurrence_read -> Set.empty - Occurrence_write -> Set.singleton (variableData origVar) - Occurrence_notopt -> Set.empty - upwardsBlock self d origBlock u transformedBlock = foldl (\s e -> Set.delete e s) (upwardsInfoFromBlockInstructions u) (declaredVars origBlock) --Not need just optimalize compliler (not try delete locals outside block) - transformBlock self d origBlock u = delUnusedDecl (map fst $ toVarWrite $ combine d $ blockSemInf origBlock) origBlock (recursivelyTransformedBlockDeclarations u) (recursivelyTransformedBlockInstructions u) - transformPrimitiveProgramInProgram self d originalPrimitive u - | canDelete && deletablePrimitive = EmptyProgram $ Empty () - | otherwise = PrimitiveProgram $ Primitive { - primitiveInstruction = recursivelyTransformedPrimitiveInstruction u, - primitiveSemInf = () - } - where - canDelete = Set.isSubsetOf (upwardsInfoFromPrimitiveInstruction u) (Set.fromList $ map fst $ toVarWrite d) - deletablePrimitive = case instructionData $ primitiveInstruction originalPrimitive of - ProcedureCallInstruction pc -> List.isPrefixOf "copy" $ nameOfProcedureToCall pc - AssignmentInstruction ass -> True - --need because of the new pluginarcitecture walk structure - upwardsVariableLeftValueInLeftValue self d origVar transVar = upwardsVariable self d origVar $ transformVariable self d origVar - transformLeftValue self d origLV u = case transformLeftValueExpressionInExpression self d origLV u of - LeftValueExpression lv -> lv - _ -> fwdPropError $ "Internal error: ForwardPropagation/4!" - diff --git a/Feldspar/Compiler/Plugins/HandlePrimitives.hs b/Feldspar/Compiler/Plugins/HandlePrimitives.hs deleted file mode 100644 --- a/Feldspar/Compiler/Plugins/HandlePrimitives.hs +++ /dev/null @@ -1,255 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Plugins.HandlePrimitives - ( HandlePrimitives(..) - , makeAssignment - , makePrimitive - ) where - - -import Data.List (find) - -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Imperative.Semantics (SemanticInfo) -import Feldspar.Compiler.Imperative.CodeGeneration (simpleType, typeof, toLeftValue) -import Feldspar.Compiler.PluginArchitecture (TransformationPhase(..), Plugin(..), InfoFromPrimitiveParts(..), InfoFromProcedureParts(..)) -import Feldspar.Compiler.PluginArchitecture.DefaultConvert (Combine(..)) -import Feldspar.Compiler.Options -import Feldspar.Compiler.Error - - -handlePrimitivesError = handleError "PluginArch/HandlePrimitives" InternalError - - -data HandleTraceFunctions = HandleTraceFunctions - - -instance TransformationPhase HandleTraceFunctions where - type From HandleTraceFunctions = () - type To HandleTraceFunctions = () - type Downwards HandleTraceFunctions = () - type Upwards HandleTraceFunctions = Bool - upwardsPrimitiveProgramInProgram = upwardsPrimitiveProgramInProgram' - transformProcedure = transformProcedure' - - -data HandlePrimitives = HandlePrimitives - - -instance TransformationPhase HandlePrimitives where - type From HandlePrimitives = () - type To HandlePrimitives = () - type Downwards HandlePrimitives = (Int,Platform) - type Upwards HandlePrimitives = () - transformPrimitiveProgramInProgram = transformPrimitive' - - -instance Plugin HandlePrimitives where - type ExternalInfo HandlePrimitives = (Int, DebugOption, Platform) - executePlugin _ (_,NoPrimitiveInstructionHandling,_) procedure = procedure - executePlugin _ (defArrSize,_,platform) procedure - = fst $ executeTransformationPhase HandlePrimitives (defArrSize,platform) - $ fst $ executeTransformationPhase HandleTraceFunctions () procedure - - - -instance Combine Bool where - combine x y = or [x,y] - - - -upwardsPrimitiveProgramInProgram' :: HandleTraceFunctions -> () -> Primitive () -> InfoFromPrimitiveParts HandleTraceFunctions -> ProgramConstruction () -> Bool -upwardsPrimitiveProgramInProgram' _ _ old _ _ | nameS=="trace" = True - | otherwise = False - where - nameS = nameOfProcedureToCall $ (\(ProcedureCallInstruction x) -> x) $ instructionData $ primitiveInstruction old - - - -transformProcedure' :: HandleTraceFunctions -> () -> Procedure () -> InfoFromProcedureParts HandleTraceFunctions -> Procedure () -transformProcedure' _ _ old upwardInfos - | containsTrace = old{ - procedureBody = (procedureBody old){ - blockInstructions = (blockInstructions $ procedureBody old){ - programConstruction = addTraceSE $ programConstruction $ blockInstructions $ procedureBody old } } } - | otherwise = old - where - containsTrace = upwardsInfoFromProcedureBody upwardInfos - addTraceSE (SequenceProgram sequ) = SequenceProgram sequ{ sequenceProgramList = [traceStart] ++ (sequenceProgramList sequ) ++ [traceEnd] } - addTraceSE _ = SequenceProgram (Sequence [traceStart, blockInstructions $ procedureBody old, traceEnd] ()) - traceStart = Program (PrimitiveProgram $ Primitive (Instruction (ProcedureCallInstruction $ ProcedureCall "traceStart" [] ()) ()) ()) () - traceEnd = Program (PrimitiveProgram $ Primitive (Instruction (ProcedureCallInstruction $ ProcedureCall "traceEnd" [] ()) ()) ()) () - - - -transformPrimitive' :: HandlePrimitives -> (Int,Platform) -> Primitive () -> InfoFromPrimitiveParts HandlePrimitives -> ProgramConstruction () -transformPrimitive' _ (defArrSize,pfm) old modified' - = case (nameS, inps, outs) of - - ("(!)", [arr, idx], [out]) - -> mkPrg $ makeAssignment pfm - (lToe $ LeftValue - (ArrayElemReferenceLeftValue $ ArrayElemReference - (toLeftValue arr) idx () - ) () - ) out defArrSize - - ("setIx", [original, idx, val], [result]) - -> SequenceProgram $ Sequence - [ Program (mkPrg $ makeAssignment pfm original result defArrSize) () - , Program (mkPrg $ makeAssignment pfm val - (LeftValue (ArrayElemReferenceLeftValue $ ArrayElemReference result idx ()) ()) - defArrSize - ) () - ] () - - ("copy", [in1], [out]) -> mkPrg $ makeAssignment pfm in1 out defArrSize - - ("trace", [label, original], [result]) - -> SequenceProgram $ Sequence - [ Program (mkPrg $ makeAssignment pfm original result defArrSize) () - , Program (mkPrg $ makePrimitive pfm (Proc "trace" firstInFP) [lToe result, label] [] 0) () - ] () - - _ -> case (find matchPrimitive $ primitives pfm) of - Just (fd,Right tp) -> SequenceProgram (Sequence plist ()) - where - plist = map (\(cd',inps',outs') -> Program (mkPrg $ makePrimitive pfm cd' inps' outs' 0) ()) $ tp fd inps outs - Just (fd,Left cd) -> mkPrg $ makePrimitive pfm cd inps outs defArrSize - Nothing -> mkPrg $ modified - - where - nameS = nameOfProcedureToCall $ (\(ProcedureCallInstruction x) -> x) $ instructionData $ primitiveInstruction old - as = actualParametersOfProcedureToCall $ (\(ProcedureCallInstruction x) -> x) $ instructionData modified - modified = recursivelyTransformedPrimitiveInstruction modified' - mkPrg x = PrimitiveProgram (Primitive x ()) - - inps = map aToE $ filter isInparam as - outs = map aToL $ filter (not . isInparam) as - - matchPrimitive (fd,_) = (fName fd == nameS) && (matchTypes' (inputs fd) inps) - - matchTypes' :: [TypeDesc] -> [Expression ()] -> Bool - matchTypes' [] [] = True - matchTypes' [] (y:ys) = False - matchTypes' (x:xs) [] = False - matchTypes' (x:xs) (y:ys) = (machTypes x $ typeof y) && (matchTypes' xs ys) - - - -makeAssignment :: Platform -> Expression () -> LeftValue () -> Int -> Instruction () -makeAssignment pfm in1 out defArrSize = makePrimitive pfm Assig [in1] [out] defArrSize - - - -makePrimitive :: Platform -> CPrimDesc -> [Expression ()] -> [LeftValue ()] -> Int -> Instruction () - -makePrimitive pfm Assig [in1] [out] defArrSize - | simpleType (typeof in1) = Instruction (AssignmentInstruction $ Assignment out in1 ()) () - | otherwise = case (typeof in1) of - (ImpArrayType _ t) -> makePrimitive pfm (Proc "copy" firstInFP) [in1, intToCe $ arraySize (typeof in1) defArrSize] [out] 0 - _ -> handlePrimitivesError $ "Unknown type in makePrimitive:\n" ++ show (typeof in1) - -makePrimitive pfm Assig _ _ _ = handlePrimitivesError $ "Wrong number of parameters for an assignment. (Parallel assignment not allowed.)" - -makePrimitive pfm desc inps outs _ - | isNotProc desc && simpleType (typeof $ head outs) - = Instruction (AssignmentInstruction $ Assignment (head outs) (Expression (FunctionCallExpression funCall) ()) ()) () - | otherwise = Instruction (ProcedureCallInstruction procCall) () - where - - funCall = case (desc, length inps, length outs) of - (Op1 op, 1, 1) -> FunctionCall PrefixOp (typeof $ head outs) op inps () - (Op2 op, 2, 1) -> FunctionCall InfixOp (typeof $ head outs) op inps () - (Fun _ _, _, 1) -> FunctionCall SimpleFun (typeof $ head outs) completeFunName inps () - _ -> errorMessage - - procCall = case (desc, length inps, length outs) of - (Fun _ _, _, 1) -> procCall' - (Proc _ _, _, _) -> procCall' - _ -> errorMessage - - procCall' = ProcedureCall completeProcName (inps' ++ outs') () - inps' = map eToA inps - outs' = map lToA outs - completeFunName | funPf desc == noneFP = cName desc - | otherwise = cName desc ++ "_fun" ++ apsToName - completeProcName | funPf desc == noneFP = cName desc - | otherwise = cName desc ++ apsToName - apsToName = concatMap (("_"++) . (toFunName pfm) . typeof) apsToNameList - apsToNameList = (take (useInputs $ funPf desc) inps') ++ (take (useOutputs $ funPf desc) outs') - isNotProc (Proc _ _) = False - isNotProc _ = True - errorMessage = handlePrimitivesError $ "Wrong C pirmitive description or different number of parameter:\n" - ++ show desc ++ "\n" ++ concatMap ((", "++) . show . typeof) inps - - - -toFunName :: Platform -> Type -> String -toFunName pfm (ImpArrayType _ t@(ImpArrayType _ _)) = toFunName pfm t -toFunName pfm (ImpArrayType _ t) = "arrayOf_" ++ toFunName pfm t -toFunName pfm t = case (find (\(t',_,_) -> t == t') $ types pfm) of - Just (_,_,s) -> map (\c -> if c == ' ' then '_' else c) $ s - Nothing -> handlePrimitivesError $ "Unhandled type in platform " ++ name pfm - - - -arraySize :: Type -> Int -> Int -arraySize a@(ImpArrayType _ t) defaultArraySize = arraySize' a - where - arraySize' (ImpArrayType (Norm n) t) = n * arraySize' t - arraySize' (ImpArrayType (Defined n) t) = n * arraySize' t - arraySize' (ImpArrayType Undefined t) = defaultArraySize * arraySize' t - arraySize' _ = 1 - - - -isInparam (ActualParameter (InputActualParameter _) _) = True -isInparam (ActualParameter (OutputActualParameter _) _) = False - - - -aToE (ActualParameter (InputActualParameter x) ()) = x -aToL (ActualParameter (OutputActualParameter x) ()) = x - --- adToE (InputActualParameter x) = x --- adToL (OutputActualParameter x) = x - -eToA x = ActualParameter (InputActualParameter x) () -lToA x = ActualParameter (OutputActualParameter x) () - --- adToA x = ActualParameter x () - --- ceToInt (Expression (ConstantExpression (Constant (IntConstant (IntConstantType x _)) _)) _) = x -intToCe x = Expression (ConstantExpression $ Constant (IntConstant $ IntConstantType x ()) ()) () - -lToe x = Expression (LeftValueExpression x) () - diff --git a/Feldspar/Compiler/Plugins/Precompilation.hs b/Feldspar/Compiler/Plugins/Precompilation.hs deleted file mode 100644 --- a/Feldspar/Compiler/Plugins/Precompilation.hs +++ /dev/null @@ -1,206 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Plugins.Precompilation where - -import Feldspar.Compiler.PluginArchitecture -import qualified Feldspar.Core.Expr as Expr -import Feldspar.Core.Types - -import qualified Feldspar.Compiler.Precompiler.Precompiler as Precompiler -import Feldspar.Compiler.Error - -import System.IO.Unsafe - --- =========================================================================== --- == Precompilation plugin --- =========================================================================== - -data CompilationMode = Interactive | Standalone - deriving (Show, Eq) - -data SignatureInformation = SignatureInformation { - originalFeldsparFunctionName :: String, - generatedImperativeParameterNames :: [String], - originalFeldsparParameterNames :: Maybe [Maybe String] -} deriving (Show, Eq) - -instance Default SignatureInformation where defaultValue = precompilationError InternalError "Default value should not be used" - -precompilationError = handleError "PluginArch/Precompilation" - -data PrecompilationSemanticInfo - -instance SemanticInfo PrecompilationSemanticInfo where - type ProcedureInfo PrecompilationSemanticInfo = SignatureInformation - type BlockInfo PrecompilationSemanticInfo = () - type ProgramInfo PrecompilationSemanticInfo = () - type EmptyInfo PrecompilationSemanticInfo = () - type PrimitiveInfo PrecompilationSemanticInfo = () - type SequenceInfo PrecompilationSemanticInfo = () - type BranchInfo PrecompilationSemanticInfo = () - type SequentialLoopInfo PrecompilationSemanticInfo = () - type ParallelLoopInfo PrecompilationSemanticInfo = () - type FormalParameterInfo PrecompilationSemanticInfo = () - type LocalDeclarationInfo PrecompilationSemanticInfo = () - type ExpressionInfo PrecompilationSemanticInfo = () - type ConstantInfo PrecompilationSemanticInfo = () - type FunctionCallInfo PrecompilationSemanticInfo = () - type LeftValueInfo PrecompilationSemanticInfo = () - type ArrayElemReferenceInfo PrecompilationSemanticInfo = () - type InstructionInfo PrecompilationSemanticInfo = () - type AssignmentInfo PrecompilationSemanticInfo = () - type ProcedureCallInfo PrecompilationSemanticInfo = () - type ActualParameterInfo PrecompilationSemanticInfo = () - type IntConstantInfo PrecompilationSemanticInfo = () - type FloatConstantInfo PrecompilationSemanticInfo = () - type BoolConstantInfo PrecompilationSemanticInfo = () - type ArrayConstantInfo PrecompilationSemanticInfo = () - type VariableInfo PrecompilationSemanticInfo = SignatureInformation - -data Precompilation = Precompilation - -instance TransformationPhase Precompilation where - type From Precompilation = () - type To Precompilation = () - type Downwards Precompilation = SignatureInformation - type Upwards Precompilation = () - downwardsProcedure Precompilation fromAbove procedure = fromAbove { - generatedImperativeParameterNames = - map (variableName . formalParameterVariable) (inParameters procedure) - } - transformProcedure Precompilation fromAbove originalProcedure fromBelow = - Procedure { -- NOTE: fromAbove won't have the generated imperative parameter names right here - procedureName = originalFeldsparFunctionName fromAbove, - inParameters = recursivelyTransformedInParameters fromBelow, - outParameters = recursivelyTransformedOutParameters fromBelow, - procedureBody = recursivelyTransformedProcedureBody fromBelow, - procedureSemInf = () - } - transformVariable = myTransformVariable - transformVariableLeftValueInLeftValue = myTransformVariableLeftValueInLeftValue - -getVariableName :: SignatureInformation -> String -> String -getVariableName signatureInformation origname = case (originalFeldsparParameterNames signatureInformation) of - Just originalParameterNameList -> - if length (generatedImperativeParameterNames signatureInformation) == length originalParameterNameList then - case searchResults of - [] -> origname - otherwise -> case snd $ head $ searchResults of - Just newname -> newname - Nothing -> origname - else - precompilationError InternalError $ "parameter name list length mismatch:" ++ - show (generatedImperativeParameterNames signatureInformation) ++ " " ++ show originalParameterNameList - where - searchResults = (filter (((==) origname).fst) (zip (generatedImperativeParameterNames signatureInformation) originalParameterNameList)) - Nothing -> origname - -myTransformVariable :: Precompilation -> SignatureInformation -> Variable () -> Variable () -myTransformVariable Precompilation fromAbove v = v { - variableName = getVariableName fromAbove (variableName v), - variableSemInf = () -} - -myTransformVariableLeftValueInLeftValue :: Precompilation -> SignatureInformation -> Variable () -> LeftValueData () -myTransformVariableLeftValueInLeftValue Precompilation fromAbove v = VariableLeftValue $ myTransformVariable Precompilation fromAbove v - -data PrecompilationExternalInfo = PrecompilationExternalInfo { - originalFeldsparFunctionSignature :: Precompiler.OriginalFeldsparFunctionSignature, - graphInputInterfaceType :: Tuple StorableType, - numberOfFunctionArguments :: Int, - compilationMode :: CompilationMode -} - -countTuple :: Tuple a -> Int -countTuple (One x) = 1 -countTuple (Tup list) = sum (map countTuple list) - -addPostfixNumbersToMaybeList :: [Maybe String] -> [Maybe String] -addPostfixNumbersToMaybeList list - | length list > 1 = map addPostfixNumberToMaybeString (zip list [1..]) -- postfix numbers only needed for lists with length > 1 - | otherwise = list - -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'" - --- Applies some tweaks the original parameter name list based on the graph's input interface type signature -parameterNameListConsolidator :: PrecompilationExternalInfo -> [Maybe String] -parameterNameListConsolidator externalInfo = case graphInputInterfaceType externalInfo of - One x -> Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo - tuple@(Tup list) -> case numberOfFunctionArguments externalInfo of - 0 -> precompilationError InternalError "parameter name list consolidator function shouldn't be called when numArgs==0" - 1 -> addPostfixNumbersToMaybeList $ replicate (countTuple tuple) - (head $ Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo) - otherwise -> concat $ map (\(cnt,name)->addPostfixNumbersToMaybeList (replicate cnt name)) - (zip (map countTuple list) (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo)) - -instance Plugin Precompilation where - type ExternalInfo Precompilation = PrecompilationExternalInfo - executePlugin Precompilation externalInfo procedure = fst - $ executeTransformationPhase Precompilation (SignatureInformation { - originalFeldsparFunctionName = Precompiler.originalFeldsparFunctionName $ originalFeldsparFunctionSignature externalInfo, - generatedImperativeParameterNames = precompilationError InternalError "GIPN should have been overwritten", - originalFeldsparParameterNames = if numberOfFunctionArguments externalInfo == 0 - then - Nothing -- if there are no arguments, disable parameter name handling (needed because of the dummy var0) - else - (case compilationMode externalInfo of - Standalone -> - if -- ultimate check, should be enough... - numberOfFunctionArguments externalInfo == - length (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo) - then - Just $ parameterNameListConsolidator externalInfo - else - (unsafePerformIO $ do - putStrLn $ "[WARNING @ PluginArch/Precompilation]: argument count mismatch in function " ++ - (Precompiler.originalFeldsparFunctionName $ originalFeldsparFunctionSignature externalInfo) ++ - ", inflating incomplete parameter name list..." - putStrLn $ "numArgs: " ++ show (numberOfFunctionArguments externalInfo) ++ ", parameter list: " ++ - show (Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo) - return $ Just $ parameterNameListConsolidator (externalInfo { - originalFeldsparFunctionSignature = (originalFeldsparFunctionSignature externalInfo) { - Precompiler.originalFeldsparParameterNames = inflate (numberOfFunctionArguments externalInfo) $ - Precompiler.originalFeldsparParameterNames $ originalFeldsparFunctionSignature externalInfo - } - }) - ) - Interactive -> Nothing -- no parameter name handling in interactive mode - ) - }) procedure - diff --git a/Feldspar/Compiler/Plugins/PrettyPrint.hs b/Feldspar/Compiler/Plugins/PrettyPrint.hs deleted file mode 100644 --- a/Feldspar/Compiler/Plugins/PrettyPrint.hs +++ /dev/null @@ -1,88 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Plugins.PrettyPrint where - -import Feldspar.Compiler.PluginArchitecture -import Feldspar.Compiler.Options - --- =========================================================================== --- == PrettyPrint plugin --- =========================================================================== - -instance Default IsRestrict where - defaultValue = NoRestrict - - -instance Default IsDefaultArraySize where - defaultValue = NoDefaultArraySize - - -data PrettyPrint = PrettyPrint - - -instance TransformationPhase PrettyPrint where - type From PrettyPrint = () - type To PrettyPrint = PrettyPrintSemanticInfo - type Downwards PrettyPrint = (IsRestrict, Int) - type Upwards PrettyPrint = () - - transformFormalParameter _ (platform,defArrSize) _ up = - FormalParameter { - formalParameterVariable = addDefaultArraySizes v defArrSize, - formalParameterSemInf = platform - } - where - v = recursivelyTransformedFormalParameterVariable up - - transformLocalDeclaration _ (_,defArrSize) _ up = - LocalDeclaration { - localVariable = addDefaultArraySizes v defArrSize, - localInitValue = recursivelyTransformedLocalInitValue up, - localDeclarationSemInf = () - } - where - v = recursivelyTransformedLocalVariable up - - -instance Plugin PrettyPrint where - type ExternalInfo PrettyPrint = (Platform,Int) - executePlugin PrettyPrint (platform,defArrSize) procedure = fst - $ executeTransformationPhase PrettyPrint (isRestrict platform,defArrSize) procedure where - - -addDefaultArraySizes :: (SemanticInfo t) => Variable t -> Int -> Variable t -addDefaultArraySizes v defArrSize = v{variableType = addDefaultArraySizes' t} - where - t = variableType v - addDefaultArraySizes' (ImpArrayType (Norm n) t) = ImpArrayType (Norm n) $ addDefaultArraySizes' t - addDefaultArraySizes' (ImpArrayType Undefined t) = ImpArrayType (Defined defArrSize) $ addDefaultArraySizes' t - addDefaultArraySizes' t = t - diff --git a/Feldspar/Compiler/Plugins/PropagationUtils.hs b/Feldspar/Compiler/Plugins/PropagationUtils.hs deleted file mode 100644 --- a/Feldspar/Compiler/Plugins/PropagationUtils.hs +++ /dev/null @@ -1,286 +0,0 @@ --- --- Copyright (c) 2009-2010, 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, FlexibleInstances #-} - -module Feldspar.Compiler.Plugins.PropagationUtils where - -import Feldspar.Compiler.PluginArchitecture -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.List as List - --- ======================== --- VariableData --- ======================== - -data VariableData = VariableData { - variableDataType :: Type - , variableDataName :: String -} deriving (Eq,Show) - -variableData :: (SemanticInfo t) => Variable t -> VariableData -variableData var = VariableData { - variableDataName = variableName var - , variableDataType = variableType var -} - -instance Ord VariableData where - compare v1 v2 = compare (variableDataName v1) $ variableDataName v2 - -instance Default (Maybe VariableData) where - defaultValue = Nothing - -instance Default [VariableData] where - defaultValue = [] - -instance Default (Set.Set VariableData) where - defaultValue = Set.empty - -instance Combine (Set.Set VariableData) where - combine = Set.union - --- ======================== --- VarStatistics --- ======================== - -type VarStatistics t = Map.Map VariableData (Occurrences t) - -data Occurrences t - = Occurrences - { writeVar :: Occurrence (Maybe t) - , readVar :: Occurrence () - } - deriving (Eq,Show) - -data Occurrence t = Zero | One t | Multiple - deriving (Eq,Show) - -hasUse :: VarStatistics t -> VariableData -> Bool -hasUse vs var = hasRead vs var || hasWrite vs var - -notUse :: VarStatistics t -> VariableData -> Bool -notUse vs var = not $ hasUse vs var - -hasRead :: VarStatistics t -> VariableData -> Bool -hasRead vs var = case Map.lookup var vs of - Nothing -> False - Just occ -> case readVar occ of - Zero -> False - _ -> True - -notRead :: VarStatistics t -> VariableData -> Bool -notRead vs var = not $ hasRead vs var - -hasWrite :: VarStatistics t -> VariableData -> Bool -hasWrite vs var = case Map.lookup var vs of - Nothing -> False - Just occ -> case writeVar occ of - Zero -> False - _ -> True - -notWrite :: VarStatistics t -> VariableData -> Bool -notWrite vs var = not $ hasWrite vs var - -getWrite :: VarStatistics t -> VariableData -> Maybe t -getWrite vs var = case Map.lookup var vs of - Nothing -> Nothing - Just occ -> case writeVar occ of - One val -> val - _ -> Nothing - -instance Default (VarStatistics t) where - defaultValue = Map.empty - -instance Combine (VarStatistics t) where - combine fst snd = Map.unionWith combine fst snd - -instance Combine (Occurrences t) where - combine o1 o2 = Occurrences - (combine (writeVar o1) (writeVar o2) ) - (combine (readVar o1) (readVar o2) ) - -instance Combine (Occurrence t) where - combine Zero x = x - combine Multiple x = Multiple - combine e@(One _) Zero = e - combine (One _) _ = Multiple - -multipleVarStatistics :: VarStatistics t -> VarStatistics t -multipleVarStatistics vs = Map.map multipleOccurrences vs where - multipleOccurrences (Occurrences write read) = Occurrences (multipleOccurrence write) (multipleOccurrence read) - multipleOccurrence Zero = Zero - multipleOccurrence (One _) = Multiple - multipleOccurrence Multiple = Multiple - -variablesInVarStatistics :: VarStatistics t -> [VariableData] -variablesInVarStatistics vs = Map.keys vs - -selectFromVarStatistics :: [VariableData] -> VarStatistics t -> VarStatistics t -selectFromVarStatistics s vs = Map.filterWithKey (\v o -> v `elem` s) vs - -deleteFromVarStatistics :: [VariableData] -> VarStatistics t -> VarStatistics t -deleteFromVarStatistics s vs = Map.filterWithKey (\v o -> not $ v `elem` s) vs - - --- ======================== --- Downwards --- ======================== - -data Occurrence_place = Occurrence_read | Occurrence_write | Occurrence_declare | Occurrence_notopt - deriving (Eq,Show) - -instance Default Occurrence_place where - defaultValue = Occurrence_read - -class OccurrenceDownwards node where - occurrenceDownwards :: node -> Occurrence_place - -instance OccurrenceDownwards (Branch t) where - occurrenceDownwards _ = Occurrence_notopt --condition variable OK -instance OccurrenceDownwards (SequentialLoop t) where - occurrenceDownwards _ = Occurrence_read --condition variable OK -instance OccurrenceDownwards (ParallelLoop t) where - occurrenceDownwards _ = Occurrence_notopt --condition variable OK -instance OccurrenceDownwards (FormalParameter t) where - occurrenceDownwards _ = Occurrence_notopt -instance OccurrenceDownwards (LocalDeclaration t) where - occurrenceDownwards _ = Occurrence_declare -instance OccurrenceDownwards (Assignment t) where - occurrenceDownwards _ = Occurrence_write --left OK, right is expression -instance OccurrenceDownwards (ActualParameter t) where - occurrenceDownwards _ = Occurrence_write -instance OccurrenceDownwards (Expression t) where - occurrenceDownwards _ = Occurrence_read -- OK - --- ======================== --- Other utils --- ======================== - -declaredVar :: (SemanticInfo t) => LocalDeclaration t -> VariableData -declaredVar = variableData.localVariable - -declaredVars :: (SemanticInfo t) => Block t -> [VariableData] -declaredVars block = map declaredVar $ blockDeclarations block - -delUnusedDecl :: (ConvertAllInfos via to) => [VariableData] -> Block via -> [LocalDeclaration to] -> Program to -> Block to -delUnusedDecl unusedList origblock partiallyTransformedDecl partiallyTransformedInstr = - Block { - blockDeclarations = filter (\d -> not $ List.elem (declaredVar d) unusedList) $ partiallyTransformedDecl, - blockInstructions = partiallyTransformedInstr, - blockSemInf = convert $ blockSemInf origblock - } - --- ======================== --- SemInfUtils --- ======================== - -class SemInfUtils node where - deleteSemInf :: (SemanticInfo t) => node t -> node () - -instance SemInfUtils Expression where - deleteSemInf exp = exp { - expressionData = deleteSemInf $ expressionData exp, - expressionSemInf = () - } - -instance SemInfUtils ExpressionData where - deleteSemInf (LeftValueExpression lve) = LeftValueExpression $ deleteSemInf lve - deleteSemInf (ConstantExpression ce) = ConstantExpression $ deleteSemInf ce - deleteSemInf (FunctionCallExpression fce) = FunctionCallExpression $ deleteSemInf fce - -instance SemInfUtils LeftValue where - deleteSemInf lv = lv { - leftValueData = deleteSemInf $ leftValueData lv, - leftValueSemInf = () - } - -instance SemInfUtils LeftValueData where - deleteSemInf (VariableLeftValue vlv) = VariableLeftValue $ deleteSemInf vlv - deleteSemInf (ArrayElemReferenceLeftValue aer) = ArrayElemReferenceLeftValue $ deleteSemInf aer - -instance SemInfUtils ArrayElemReference where - deleteSemInf aer = aer { - arrayName = deleteSemInf $ arrayName aer, - arrayIndex = deleteSemInf $ arrayIndex aer, - arrayElemReferenceSemInf = () - } - -instance SemInfUtils Variable where - deleteSemInf var = var { - variableSemInf = () - } - -instance SemInfUtils ActualParameter where - deleteSemInf ap = ap { - actualParameterData = deleteSemInf $ actualParameterData ap, - actualParameterSemInf = () - } - -instance SemInfUtils ActualParameterData where - deleteSemInf (InputActualParameter iap) = InputActualParameter $ deleteSemInf iap - deleteSemInf (OutputActualParameter oap) = OutputActualParameter $ deleteSemInf oap - -instance SemInfUtils Constant where - deleteSemInf c = c { - constantData = deleteSemInf $ constantData c, - constantSemInf = () - } - -instance SemInfUtils ConstantData where - deleteSemInf (IntConstant ic) = IntConstant $ deleteSemInf ic - deleteSemInf (FloatConstant fc) = FloatConstant $ deleteSemInf fc - deleteSemInf (BoolConstant bc) = BoolConstant $ deleteSemInf bc - deleteSemInf (ArrayConstant ac) = ArrayConstant $ deleteSemInf ac - -instance SemInfUtils IntConstantType where - deleteSemInf c = c { - intConstantSemInf = () - } - -instance SemInfUtils FloatConstantType where - deleteSemInf c = c { - floatConstantSemInf = () - } - -instance SemInfUtils BoolConstantType where - deleteSemInf c = c { - boolConstantSemInf = () - } - -instance SemInfUtils ArrayConstantType where - deleteSemInf c = c { - arrayConstantValue = map deleteSemInf $ arrayConstantValue c, - arrayConstantSemInf = () - } - -instance SemInfUtils FunctionCall where - deleteSemInf fc = fc { - actualParametersOfFunctionToCall = map deleteSemInf $ actualParametersOfFunctionToCall fc, - functionCallSemInf = () - } diff --git a/Feldspar/Compiler/Plugins/Unroll.hs b/Feldspar/Compiler/Plugins/Unroll.hs deleted file mode 100644 --- a/Feldspar/Compiler/Plugins/Unroll.hs +++ /dev/null @@ -1,181 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Plugins.Unroll where - -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Options -import Prelude -import Feldspar.Compiler.Imperative.Semantics -import Feldspar.Compiler.PluginArchitecture - - -instance Plugin UnrollPlugin where - type ExternalInfo UnrollPlugin = UnrollStrategy - executePlugin UnrollPlugin ei p = case ei of - NoUnroll -> p - Unroll unrollCount -> fst $ executeTransformationPhase Unroll_2 Nothing $ fst $ executeTransformationPhase Unroll_1 unrollCount p - -data UnrollPlugin = UnrollPlugin -instance TransformationPhase UnrollPlugin where - type From UnrollPlugin = () - type To UnrollPlugin = () - type Downwards UnrollPlugin = () - type Upwards UnrollPlugin = () - -data Unroll_1 = Unroll_1 -instance TransformationPhase Unroll_1 where - type From Unroll_1 = () - type To Unroll_1 = UnrollSemInf - type Downwards Unroll_1 = Int - type Upwards Unroll_1 = Bool - upwardsParallelLoopProgramInProgram _ _ _ _ _ = True - transformParallelLoopProgramInProgram Unroll_1 d pl u = trParLoop1 d pl u - -data Unroll_2 = Unroll_2 -instance TransformationPhase Unroll_2 where - type From Unroll_2 = UnrollSemInf - type To Unroll_2 = () - type Downwards Unroll_2 = Maybe SemInfPrg - type Upwards Unroll_2 = () - downwardsProgram Unroll_2 d p - | programSemInf p == Nothing = d - | otherwise = programSemInf p - transformVariable Unroll_2 d v = trVariable d v - transformVariableLeftValueInLeftValue Unroll_2 d v = VariableLeftValue $ trVariable d $ v - transformLeftValueExpressionInExpression Unroll_2 d lvie u = trLVIE d lvie u - -data UnrollSemInf = UnrollSemInf -instance SemanticInfo UnrollSemInf where - type ProcedureInfo UnrollSemInf = () - type BlockInfo UnrollSemInf = () - type ProgramInfo UnrollSemInf = Maybe SemInfPrg - type EmptyInfo UnrollSemInf = Maybe SemInfPrg - type PrimitiveInfo UnrollSemInf = Maybe SemInfPrg - type SequenceInfo UnrollSemInf = Maybe SemInfPrg - type BranchInfo UnrollSemInf = () - type SequentialLoopInfo UnrollSemInf = () - type ParallelLoopInfo UnrollSemInf = () - type FormalParameterInfo UnrollSemInf = () - type LocalDeclarationInfo UnrollSemInf = () - type ExpressionInfo UnrollSemInf = () - type ConstantInfo UnrollSemInf = () - type FunctionCallInfo UnrollSemInf = () - type LeftValueInfo UnrollSemInf = () - type ArrayElemReferenceInfo UnrollSemInf = () - type InstructionInfo UnrollSemInf = () - type AssignmentInfo UnrollSemInf = () - type ProcedureCallInfo UnrollSemInf = () - type ActualParameterInfo UnrollSemInf = () - type IntConstantInfo UnrollSemInf = () - type FloatConstantInfo UnrollSemInf = () - type BoolConstantInfo UnrollSemInf = () - type ArrayConstantInfo UnrollSemInf = () - type VariableInfo UnrollSemInf = () - -instance Combine Bool where - combine = (||) - -data SemInfPrg = SemInfPrg - { position :: Int - , varNames :: [String] - , loopVar :: String - } deriving (Eq, Show) -instance Default (Maybe SemInfPrg) where defaultValue = Nothing - -trLVIE :: Downwards Unroll_2 -> LeftValue UnrollSemInf -> InfoFromLeftValueParts Unroll_2 -> ExpressionData () -trLVIE d (LeftValue leftValue _) u = case d of - Just x -> result x - otherwise -> orig - where - name = case leftValue of - VariableLeftValue d -> Just $ getVarName d - otherwise -> Nothing - result x = case name of - Just n - | n == loopVar x -> FunctionCallExpression $ FunctionCall InfixOp (Numeric ImpSigned S32) ("+") ([loopVarPar, plusPar]) () - | otherwise -> orig - otherwise -> orig - where - loopVarPar = Expression orig () - num = position x - plusPar = Expression (ConstantExpression $ Constant (IntConstant $ IntConstantType num ()) ()) () - orig = LeftValueExpression $ LeftValue (recursivelyTransformedLeftValueData u ) () - -trVariable d v - | d /= Nothing && elementOf (varNames (valueFromJust d)) (getVarName v) = v { variableName = (variableName v) ++ "_u" ++ (show $ position $ valueFromJust d), variableSemInf = ()} - | otherwise = v {variableSemInf = ()} - -trParLoop1 :: Downwards Unroll_1 -> ParallelLoop () -> InfoFromParallelLoopParts Unroll_1 -> ProgramConstruction UnrollSemInf -trParLoop1 d pl u - | ( upwardsInfoFromParallelLoopCore u ) == False && (unrollPossible || varInExpr ) = ParallelLoopProgram newParLoop - | otherwise = ParallelLoopProgram trPl - where - newParLoop = trPl { parallelLoopStep = unrollNum - , parallelLoopCore = newLoopCore - , parallelLoopSemInf = ()} - newLoopCore = origLoopCore - { blockDeclarations = unrollDecls - , blockInstructions = unrollPrg - , blockSemInf = ()} - unrollPrg = Program (SequenceProgram $ Sequence prgs (Nothing)) (Nothing) - prgs = map (\(i,p) -> writeSemInfToPrg p (Just $ SemInfPrg i varNames loopCounter)) $ zip [0,1..] replPrg - writeSemInfToPrg prg semInf = prg { programSemInf = semInf } - replPrg = replicate unrollNum origPrg - origPrg = blockInstructions $ origLoopCore - 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 unrollNum origDecls - origDecls = blockDeclarations $ origLoopCore - origLoopCore = recursivelyTransformedParallelLoopCore u - iterExpr = recursivelyTransformedNumberOfIterations u - loopCounter' = recursivelyTransformedParallelLoopConditionVariable u - trPl = ParallelLoop loopCounter' iterExpr (parallelLoopStep pl) origLoopCore () - unrollNum = d - loopCounter = getVarName $ recursivelyTransformedParallelLoopConditionVariable u - varNames = map (\d -> getVarNameDecl d) origDecls - iterTemp = iterNumFromExpr iterExpr - origIterNum = valueFromJust iterTemp - iterNumIsConstant = isJust iterTemp - unrollPossible = iterNumIsConstant && ( mod origIterNum d == 0 ) - varInExpr = not $ isJust iterTemp - --- helper functions : -iterNumFromExpr (Expression (ConstantExpression (Constant (IntConstant (IntConstantType i _)) _)) _) = Just i -iterNumFromExpr _ = Nothing -isJust (Just x) = True -isJust _ = False -getVarNameDecl d = getVarName $ localVariable d -getVarName v = variableName v -valueFromJust (Just v) = v -valueFromJust Nothing = error "This was Nothing" -renameDeclaration d n = d { localVariable = renameVariable (localVariable d) n } -renameVariable v n = v { variableName = n } -elementOf ss s = (length $ filter (\s' -> s' == s) ss) > 0 diff --git a/Feldspar/Compiler/Precompiler/Precompiler.hs b/Feldspar/Compiler/Precompiler/Precompiler.hs deleted file mode 100644 --- a/Feldspar/Compiler/Precompiler/Precompiler.hs +++ /dev/null @@ -1,133 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Precompiler.Precompiler where - -import System.IO -import System.IO.Unsafe -import Language.Haskell.Exts -import Feldspar.Compiler.Error - -data OriginalFeldsparFunctionSignature = OriginalFeldsparFunctionSignature { - originalFeldsparFunctionName :: String, - originalFeldsparParameterNames :: [Maybe String] -} deriving (Eq) - -instance Show OriginalFeldsparFunctionSignature where - show (OriginalFeldsparFunctionSignature fn pl) = "function name: " ++ show fn ++ ", parameter list: " ++ show pl - -precompilerError errorClass msg = handleError "Precompiler" errorClass msg - -neutralName = "kiscica<>#&@{}-$;>" - --- 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 -> OriginalFeldsparFunctionSignature -stripFunBind x = case x of - FunBind ((Match a b c d e f):rest) -> OriginalFeldsparFunctionSignature (stripName b) (map stripPattern c) -- going for name and parameter list - -- "Match SrcLoc Name [Pat] (Maybe Type) Rhs Binds" - -- TODO handle other patterns, not only the first one (head)? - PatBind a b c d e -> case stripPattern b of - Just functionName -> OriginalFeldsparFunctionSignature functionName [] -- parameterless declarations (?) - Nothing -> precompilerError InternalError ("Unsupported pattern binding: " ++ show b) - TypeSig a b c -> OriginalFeldsparFunctionSignature neutralName [] --head b -- we don't need the type signature (yet) - DataDecl a b c d e f g -> OriginalFeldsparFunctionSignature neutralName [] - InstDecl a b c d e -> OriginalFeldsparFunctionSignature neutralName [] - -- TypeDecl SrcLoc Name [TyVarBind] Type - TypeDecl a b c d -> OriginalFeldsparFunctionSignature neutralName [] - unknown -> precompilerError InternalError ("Unsupported language element [SFB/1]: " ++ show unknown) - -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 :: String -> String -- filecontents -> modulename -getModuleName = stripModuleName . stripModule2 . fromParseResult . customizedParse - -usedExtensions = glasgowExts ++ [ExplicitForall] - --- Ultimate debug function -getParseOutput fileName = parseFileWithMode (defaultParseMode { extensions = usedExtensions }) fileName - --- or: parseFileContentsWithMode -customizedParse = parseModuleWithMode (defaultParseMode { extensions = usedExtensions }) - -getFullDeclarationListWithParameterList :: String -> [OriginalFeldsparFunctionSignature] -getFullDeclarationListWithParameterList fileContents = - map stripFunBind (stripModule $ fromParseResult $ customizedParse 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 . originalFeldsparFunctionName) (getFullDeclarationListWithParameterList fileContents) - -printParameterListOfFunction :: FilePath -> String -> IO [Maybe String] -printParameterListOfFunction fileName functionName = getParameterList fileName functionName - --- The interface -getDeclarationList :: String -> [String] -- filecontents -> Stringlist -getDeclarationList = stripUnnecessary . (map originalFeldsparFunctionName) . getFullDeclarationListWithParameterList - -getExtendedDeclarationList :: String -> [OriginalFeldsparFunctionSignature] -- filecontents -> ExtDeclList -getExtendedDeclarationList fileContents = filter (functionNameNeeded . originalFeldsparFunctionName) - (getFullDeclarationListWithParameterList fileContents) - -getParameterListOld :: String -> String -> [Maybe String] -getParameterListOld fileContents funName = originalFeldsparParameterNames $ head $ - filter ((==funName) . originalFeldsparFunctionName) (getExtendedDeclarationList fileContents) - -getParameterList :: FilePath -> String -> IO [Maybe String] -getParameterList fileName funName = do - handle <- openFile fileName ReadMode - fileContents <- hGetContents handle - return $ originalFeldsparParameterNames $ head $ - filter ((==funName) . originalFeldsparFunctionName) (getExtendedDeclarationList fileContents) diff --git a/Feldspar/Compiler/Standalone/Constants.hs b/Feldspar/Compiler/Standalone/Constants.hs deleted file mode 100644 --- a/Feldspar/Compiler/Standalone/Constants.hs +++ /dev/null @@ -1,42 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Standalone.Constants where - -globalImportList = ["Feldspar.Fs2dot", "Feldspar.Compiler.Compiler", - "Feldspar.Compiler.Precompiler.Precompiler", "Feldspar.Compiler.Options", - "Feldspar.Compiler.Platforms"] - -warningPrefix = "[WARNING]: " -errorPrefix = "[ERROR ]: " - -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" diff --git a/Feldspar/Compiler/Standalone/Library.hs b/Feldspar/Compiler/Standalone/Library.hs deleted file mode 100644 --- a/Feldspar/Compiler/Standalone/Library.hs +++ /dev/null @@ -1,71 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Standalone.Library where - -import qualified Feldspar.Compiler.Options as CoreOptions -import Feldspar.Compiler.Platforms - -import Data.Char -import System.Console.ANSI -import Language.Haskell.Interpreter - -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]) - -withColor :: Color -> IO () -> IO () -withColor color action = do - setSGR [SetColor Foreground Dull color, SetConsoleIntensity BoldIntensity] - action - setSGR [Reset] - -iPutStrLn :: String -> Interpreter () -iPutStrLn = liftIO . putStrLn - -iPutStr :: String -> Interpreter () -iPutStr = liftIO . putStr diff --git a/Feldspar/Compiler/Standalone/Options.hs b/Feldspar/Compiler/Standalone/Options.hs deleted file mode 100644 --- a/Feldspar/Compiler/Standalone/Options.hs +++ /dev/null @@ -1,151 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Standalone.Options where - -import qualified Feldspar.Compiler.Options as CompilerCoreOptions -import qualified Feldspar.Compiler.Compiler as CompilerCore -import qualified Feldspar.Compiler.Standalone.Library as StandaloneLib -import Feldspar.Compiler.Standalone.Constants -import Feldspar.Compiler.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 FunctionMode = SingleFunction String | MultiFunction - -data Options = Options { optSingleFunction :: FunctionMode - , optOutputFileName :: Maybe String - , optDotGeneration :: Bool - , optDotFileName :: Maybe String - , optCompilerMode :: CompilerCoreOptions.Options - } - --- | Default options -startOptions :: Options -startOptions = Options { optSingleFunction = MultiFunction - , optOutputFileName = Nothing - , optDotGeneration = False - , optDotFileName = Nothing - , optCompilerMode = CompilerCore.defaultOptions - } - --- | Option descriptions for getOpt -optionDescriptors :: [ OptDescr (Options -> IO Options) ] -optionDescriptors = - [ Option "f" ["singlefunction"] - (ReqArg - (\arg opt -> return opt { optSingleFunction = SingleFunction arg }) - "FUNCTION") - "Enables single-function compilation" - - , Option "o" ["output"] - (ReqArg - (\arg opt -> return opt { optOutputFileName = Just arg }) - "outputfile.c") - "Overrides the file name for the generated output code" - - , Option "d" ["todot"] - (OptArg - (\arg opt -> return opt { optDotFileName = arg, optDotGeneration = True }) - "dotfile.dot") - "Enables dot generation (outputs to stdout if no filename is specified)" - - , 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 (NoSimplification | NoPrimitiveInstructionHandling)" - , Option "a" ["defaultArraySize"] - (ReqArg - (\arg opt -> return opt { - optCompilerMode = (optCompilerMode opt) { - CompilerCoreOptions.defaultArraySize = parseInt arg "Invalid default array size" - } - }) - "") - "Overrides default array size" - - , 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 "NoSimplification" = CompilerCoreOptions.NoSimplification -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/Transformation/GraphToImperative.hs b/Feldspar/Compiler/Transformation/GraphToImperative.hs deleted file mode 100644 --- a/Feldspar/Compiler/Transformation/GraphToImperative.hs +++ /dev/null @@ -1,631 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Transformation.GraphToImperative where - -import Feldspar.Core.Graph -import Feldspar.Range -import qualified Feldspar.Core.Graph as Graph -import Feldspar.Core.Types hiding (typeOf) -import qualified Feldspar.Core.Types as CoreTypes -import Feldspar.Compiler.Imperative.Representation -import Feldspar.Compiler.Imperative.CodeGeneration -import qualified Feldspar.Compiler.Imperative.Representation as Representation -import Feldspar.Compiler.Transformation.GraphUtils -import Data.List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import Feldspar.Compiler.Error -import Feldspar.Compiler.Imperative.Semantics - --- Transforms a hierarchical graph to a list of imperative functions. - -- collect sources for each function - -- compile each of them - -- put the results in a list -graphToImperative :: HierarchicalGraph -> [Procedure InitSemInf] -graphToImperative g = map transformSourceToProcedure sources where - sources = this : collectSources g - this = ProcedureSource - { interface = hierGraphInterface g - , hierarchy = graphHierarchy g - } - --- A datastructure to represent all data needed for transformation to an --- imperative function. -data ProcedureSource - = ProcedureSource - { interface :: Interface - , hierarchy :: Hierarchy - } - --- 'collectSources' walks thorugh the graph and collects the interfaces --- and hierarchies of 'NoInline' nodes. -class Collect t where - collectSources :: t -> [ProcedureSource] - -instance Collect HierarchicalGraph where - collectSources g = collectSources $ graphHierarchy g - -instance Collect Hierarchy where - collectSources (Hierarchy xs) = collectSources xs - -instance (Collect t) => Collect [t] where - collectSources xs = concatMap collectSources xs - -instance Collect (Node,[Hierarchy]) where - collectSources (n,hs) = this ++ collectSources hs where - this = case function n of - NoInline name interface -> case hs of - [hierarchy] -> [ProcedureSource interface hierarchy] - _ -> error $ "Graph error: malformed hierarchy list in the 'NoInline' node with id " ++ show (nodeId n) - _ -> [] - --- Transforms an interface and a hierarchy to an imperative function. - -- transform top level nodes to declarations - -- split the declarations into 'input' and 'local' groups - -- generate output parameters - -- transform each top-level node to a Program -transformSourceToProcedure :: ProcedureSource -> Procedure InitSemInf -transformSourceToProcedure (ProcedureSource ifc (Hierarchy pairs)) - = Procedure { - procedureName = "PLACEHOLDER", - inParameters = inputDecls, - outParameters = outputDecls, - procedureBody = Block { - blockDeclarations = localDecls, - blockInstructions = Program { - programConstruction = SequenceProgram $ Sequence { - sequenceProgramList = ( map transformNodeToProgram pairs - ++ copyToOutput (interfaceOutput ifc) (interfaceOutputType ifc) True ), - sequenceSemInf = () - }, - programSemInf = () - }, - blockSemInf = () - }, - procedureSemInf = () - } where - inputDecls = case inputNodes of - [inputNode] -> transformNodeToFormalParameter inputNode - [] -> handleError "GraphToImperative" InvariantViolation $ "no input node found" ++ (show (map fst pairs)) - _ -> handleError "GraphToImperative" InvariantViolation $ "exactly one input node expected; nodeId==" ++ (show $ nodeId $ head inputNodes) - localDecls = concatMap transformNodeToLocalDeclaration localNodes - outputDecls = tupleWalk transformSourceToFormalParameter $ interfaceOutputType ifc - transformSourceToFormalParameter :: [Int] -> StorableType -> FormalParameter InitSemInf - transformSourceToFormalParameter path typ = FormalParameter { - formalParameterVariable = Representation.Variable FunOut ctyp (outName path) (), - formalParameterSemInf = () - } where - ctyp = compileStorableType typ - (inputNodes,localNodes) = partition (\n -> nodeId n == interfaceInput ifc) $ map fst pairs - --- Transforms a node to declarations. The number of generated declarations is --- determined by the tuple leafs of the tuple structure in the node type. - -- walk through the tuple structure in the node type - -- variable name: "var" ++ 'node id' ++ 'path in the tuple structure' - -- variable type: type of the leaf in the structure -transformNodeToFormalParameter :: Node -> [FormalParameter InitSemInf] -transformNodeToFormalParameter n = tupleWalk genDecl $ tupleZip (outTyps,initVals) where - genDecl path (typ,ini) - = FormalParameter { - formalParameterVariable = Representation.Variable Value ctyp (varPrefix (nodeId n) ++ varPath path) (), - formalParameterSemInf = () - } where - ctyp = compileStorableType typ - outTyps = outputType n - initVals = case function n of - Array d -> case outTyps of - One t -> One $ Just $ compileStorableData d t - _ -> error "Error: malformed output type of array node." - otherwise -> genNothingTuple outTyps - genNothingTuple (One _) = One Nothing - genNothingTuple (Tup xs) = Tup $ map genNothingTuple xs - -transformNodeToLocalDeclaration :: Node -> [LocalDeclaration InitSemInf] -transformNodeToLocalDeclaration n = tupleWalk genDecl $ tupleZip (outTyps,initVals) where - genDecl path (typ,ini) = LocalDeclaration { - localVariable = Representation.Variable { - variableRole = Value, - variableType = ctyp, - variableName = (varPrefix (nodeId n) ++ varPath path), - variableSemInf = () - }, - localInitValue = ini, - localDeclarationSemInf = () - } where - ctyp = compileStorableType typ - outTyps = outputType n - initVals = case function n of - Array d -> case outTyps of - One t -> One $ Just $ compileStorableData d t - _ -> error "Error: malformed output type of array node." - otherwise -> genNothingTuple outTyps - genNothingTuple (One _) = One Nothing - genNothingTuple (Tup xs) = Tup $ map genNothingTuple xs - -transformNodeListToFormalParameters :: [Node] -> [FormalParameter InitSemInf] -transformNodeListToFormalParameters ns = concatMap transformNodeToFormalParameter ns - -transformNodeListToLocalDeclarations :: [Node] -> [LocalDeclaration InitSemInf] -transformNodeListToLocalDeclarations ns = concatMap transformNodeToLocalDeclaration ns - --- Transforms a node and its subgraphs (if any) to an imperative program. -transformNodeToProgram :: (Node, [Hierarchy]) -> Program InitSemInf -transformNodeToProgram (n,hs) = case function n of - Graph.Input -> Program (EmptyProgram $ Empty ()) () - Array _ -> Program (EmptyProgram $ Empty ()) () - Function s -> Program { - programConstruction = PrimitiveProgram $ Primitive { - primitiveInstruction = Instruction { - instructionData = (ProcedureCallInstruction $ ProcedureCall { - nameOfProcedureToCall = s, - actualParametersOfProcedureToCall = passInArgs (input n) (inputType n) ++ - passOutArgs (nodeId n) (outputType n), - procedureCallSemInf = () - }), - instructionSemInf = () - }, - primitiveSemInf = False - }, - programSemInf = () - } - -- non-inlined function node: - -- call the non-inlined function - -- actual arguments come from the node input and the node id - NoInline s ifc -> Program { - programConstruction = PrimitiveProgram $ Primitive { - primitiveInstruction = Instruction { - instructionData = (ProcedureCallInstruction $ ProcedureCall { - nameOfProcedureToCall = s, - actualParametersOfProcedureToCall = passInArgs (input n) (inputType n) ++ - passOutArgs (nodeId n) (outputType n), - procedureCallSemInf = () - }), - instructionSemInf = () - }, - primitiveSemInf = False - }, - programSemInf = () - } - -- conditional node: - -- condition: first element of the input tuple - -- then branch: compiled from the first interface and the first hierarchy - -- else branch: compiled from the second interface and the second hierarchy - Graph.IfThenElse thenIfc elseIfc -> case hs of - [thenH, elseH] -> case (input n, inputType n) of - (Tup [cond, inp], Tup [One condTyp, inTyp]) - | interfaceInputType thenIfc /= inTyp || interfaceInputType elseIfc /= inTyp - -> error "Error in 'ifThenElse' node: incorrect interface input type." - | compileStorableType condTyp /= Feldspar.Compiler.Imperative.Representation.BoolType - -> error "Error in 'ifThenElse' node: node output is expected to be 'Bool'." - | otherwise -> Program { - programConstruction = BranchProgram $ Branch { - branchConditionVariable = condVar, - thenBlock = mkBranch n thenIfc thenH, - elseBlock = mkBranch n elseIfc elseH, - branchSemInf = () - }, - programSemInf = () - } - where - mkBranch :: Node -> Interface -> Hierarchy -> Block InitSemInf - mkBranch n ifc h@(Hierarchy pairs) = Block { - blockDeclarations = (transformNodeListToLocalDeclarations $ map fst pairs), - blockInstructions = Program { - programConstruction = SequenceProgram $ Sequence { - sequenceProgramList = (copyResult inp (interfaceInput ifc) inTyp False - ++ transformNodeListToPrograms pairs - ++ copyResult (interfaceOutput ifc) (nodeId n) (outputType n) True), - sequenceSemInf = () - }, - programSemInf = () - }, - blockSemInf = () - } - condVar = case cond of - One (Graph.Variable (id,path)) -> - Representation.Variable Value Representation.BoolType (varName id path) () - _ -> error "Error in 'ifThenElse' node: condition is not a variable." - -- TODO: it seems that in case of constant condition the program is already simplified on the graph level - otherwise -> error $ "Error in 'ifThenElse' node: incorrect node input or node input type" - otherwise -> error $ "Error in 'ifThenElse' node: two hierarchies expected, found " ++ show (length hs) - -- while node: - -- state variables: id of the while node - -- condition calculation: first interface and hierarchy - -- input gets the state - -- condition: output of condition calculation - -- body: second interface and hierarchy - -- input gets the state - -- output is written back to the state - While condIfc bodyIfc -> Program { - programConstruction = SequenceProgram $ Sequence { - sequenceProgramList = - (copyResult (input n) (nodeId n) (outputType n) True ++ - [Program { - programConstruction = SequentialLoopProgram $ SequentialLoop { - sequentialLoopCondition = (case interfaceOutput condIfc of - One (Graph.Variable (id,path)) -> varToExpr $ Representation.Variable Value Representation.BoolType (varName id path) () - One (Graph.Constant (BoolData x)) -> Expression { - expressionData = ConstantExpression $ Representation.Constant { - constantData = BoolConstant $ BoolConstantType x (), - constantSemInf = () - }, - expressionSemInf = () - } - unknown -> error $ "Error in a while loop: Malformed interface output of condition calculation: " ++ (show unknown) - -- TODO: should this hold? - ), - conditionCalculation = Block { - blockDeclarations = (transformNodeListToLocalDeclarations condNodes), - blockInstructions = Program { - programConstruction = (SequenceProgram (Sequence (copyStateToCond ++ calculationCond) ())), - programSemInf = () - }, - blockSemInf = () - }, - sequentialLoopCore = Block { - blockDeclarations = (transformNodeListToLocalDeclarations bodyNodes), - blockInstructions = Program { - programConstruction = (SequenceProgram (Sequence (copyStateToBody ++ calculationBody ++ copyResultToState) ())), - programSemInf = () - }, - blockSemInf = () - }, - sequentialLoopSemInf = () - }, - programSemInf = () - } - ]), - sequenceSemInf = () - }, - programSemInf = () - } - where - (Hierarchy condHier, Hierarchy bodyHier) = case hs of - [c,b] -> (c,b) - _ -> error $ "Error in a while node: expected 2 hierarchies, but found " ++ show (length hs) - condNodes = map fst condHier - bodyNodes = map fst bodyHier - copyStateToCond = copyNode (nodeId n) (interfaceInput condIfc) (outputType n) False - calculationCond = transformNodeListToPrograms condHier - copyStateToBody = copyNode (nodeId n) (interfaceInput bodyIfc) (outputType n) False - calculationBody = transformNodeListToPrograms bodyHier - copyResultToState = copyResult (interfaceOutput bodyIfc) (nodeId n) (outputType n) True - -- parallel node: - -- number of iterations: first parameter of 'Parallel' constructor - -- (vs. input of the node, may change later) - -- index variable: input node of the embedded graph - -- body: embedded graph and its interface - Parallel ifc -> - Program { - programConstruction = ParallelLoopProgram $ ParallelLoop - (Representation.Variable Value (Numeric ImpSigned S32) (varName inpId []) ()) num 1 prg - (), - programSemInf = () - } where - num = case (input n, inputType n) of - (One inp, One intyp) -> transformSourceToExpr inp intyp - otherwise -> error "Invalid input of a Parallel node." - hist = case hs of - [(Hierarchy hist)] -> hist - _ -> error "More than one Hierarchy in a Parallel construct" - isInp (node,hs) = case (function node) of - Graph.Input -> True - _ -> False - (inps,notInps) = partition isInp hist - inpId = case inps of - [(node,hs)] -> nodeId node - _ -> error "More than one input node inside the Hierarchy of a Parallel construct" - topLevelNodes = map fst notInps - declarations = concatMap transformNodeToLocalDeclaration topLevelNodes - outSrc = case interfaceOutput ifc of - One src -> src - _ -> error "The interfaceOutput of a Parallel is not (One ...) " - outTypElem = case interfaceOutputType ifc of - One typ -> typ - _ -> error "The interfaceOutputType of a Parallel is not (One ...) " - outTypArray = case outputType n of - One typ -> typ - _ -> error "The outputType of a Parallel is not (One ...) " - outTypArrayImp = compileStorableType outTypArray - outTypElemImp = compileStorableType outTypElem - prg = Block { - blockDeclarations = declarations, - blockInstructions = Program { - programConstruction = SequenceProgram $ Sequence { - sequenceProgramList = map transformNodeToProgram notInps ++ - [ Program { - programConstruction = PrimitiveProgram $ Primitive { - primitiveInstruction = makeCopyFromExprs - (transformSourceToExpr outSrc outTypElem) - (Expression { - expressionData = LeftValueExpression $ LeftValue { - leftValueData = (ArrayElemReferenceLeftValue $ ArrayElemReference { - arrayName = LeftValue { - leftValueData = VariableLeftValue $ Representation.Variable { - variableRole = Value, - variableType = outTypArrayImp, - variableName = (varName (nodeId n) []), - variableSemInf = () - }, - leftValueSemInf = () - }, - arrayIndex = (genVar inpId [] intType), - arrayElemReferenceSemInf = () - }), - leftValueSemInf = () - }, - expressionSemInf = () - }), - primitiveSemInf = True - }, - programSemInf = () - } ], - sequenceSemInf = () - }, - programSemInf = () - }, - blockSemInf = () - } - -transformNodeListToPrograms :: [(Node, [Hierarchy])] -> [Program InitSemInf] -transformNodeListToPrograms pairs = map transformNodeToProgram pairs - - --- Generates the common prefix of variables belonging to the given node id. -varPrefix :: NodeId -> String -varPrefix id = "var" ++ show id - --- Generates a variable's id list that describes the variable's location --- inside the nodes it belongs to. -varPath :: [Int] -> String -varPath path = concatMap (\id -> '_' : show id) path - --- Generates a variable from its id and location. -varName :: NodeId -> [Int] -> String -varName id path = varPrefix id ++ varPath path - --- Generates a variable -genVar :: NodeId -> [Int] -> Type -> Expression InitSemInf -genVar id path typ = Expression { - expressionData = LeftValueExpression $ LeftValue { - leftValueData = VariableLeftValue $ Representation.Variable { - variableRole = Value, - variableType = typ, - variableName = (varName id path), - variableSemInf = () - }, - leftValueSemInf = () - }, - expressionSemInf = () -} - --- Prefix of output parameters -outPrefix :: String -outPrefix = "out" - --- Generaes the name of an output parameter -outName :: [Int] -> String -outName path = outPrefix ++ varPath path - --- Generates an output variable -genOut :: [Int] -> Type -> Expression InitSemInf -genOut path typ = Expression { - expressionData = LeftValueExpression $ LeftValue { - leftValueData = VariableLeftValue $ Representation.Variable { - variableRole = FunOut, - variableType = typ, - variableName = (outName path), - variableSemInf = () - }, - leftValueSemInf = () - }, - expressionSemInf = () -} - --- Generates input parameters of a function call from the node input. -passInArgs :: Tuple Source -> Tuple StorableType -> [ActualParameter InitSemInf] -passInArgs tup typs = tupleWalk genArg $ tupleZip (tup,typs) where - genArg _ (Graph.Constant primData, StorableType _ typ) = ActualParameter { - actualParameterData = InputActualParameter $ compilePrimData primData typ, - actualParameterSemInf = () - } - genArg _ (Graph.Variable (id, path), typ) = ActualParameter { - actualParameterData = InputActualParameter $ genVar id path (compileStorableType typ), - actualParameterSemInf = () - } - --- Generates output parameters of a function call from the node id and output type. -passOutArgs :: NodeId -> Tuple StorableType -> [ActualParameter InitSemInf] -passOutArgs id typs = tupleWalk genArg typs where - genArg path t = ActualParameter { - actualParameterData = OutputActualParameter $ toLeftValue $ genVar id path (compileStorableType t), - actualParameterSemInf = () - } - -------------------------------------------------- --- Compilation of type and data representation -- -------------------------------------------------- - --- Transforms a 'StorableType' to an imperative 'Type' -compileStorableType :: StorableType -> Type -compileStorableType (StorableType dims elemTyp) = case dims of - [] -> compilePrimitiveType elemTyp - (d:ds) -> ImpArrayType (getLength $ upperBound d) $ compileStorableType $ StorableType ds elemTyp - -getLength (Just i) = Norm i -getLength _ = Undefined - --- Transforms a 'PrimitiveType' to an imperative 'Type' -compilePrimitiveType :: PrimitiveType -> Type -compilePrimitiveType typ = case typ of - UnitType -> Representation.BoolType - CoreTypes.BoolType -> Representation.BoolType - IntType True 8 _ -> Numeric ImpSigned S8 - IntType True 16 _ -> Numeric ImpSigned S16 - IntType True 32 _ -> Numeric ImpSigned S32 - IntType True 64 _ -> Numeric ImpSigned S64 - IntType False 8 _ -> Numeric ImpUnsigned S8 - IntType False 16 _ -> Numeric ImpUnsigned S16 - IntType False 32 _ -> Numeric ImpUnsigned S32 - IntType False 64 _ -> Numeric ImpUnsigned S64 - IntType sig size _ -> handleError "GraphToImperative" InvariantViolation $ "unknown integer type: IntType" ++ (show sig) ++ " " ++ (show size) - CoreTypes.FloatType x -> Representation.FloatType -- TODO: think about the imperative typesystem! - CoreTypes.UserType userTypeName -> Representation.UserType userTypeName - --- Transforms an array or primitive data to an imperative constant. -compileStorableDataToConst :: StorableData -> Constant InitSemInf -compileStorableDataToConst (CoreTypes.PrimitiveData pd) = compilePrimDataToConst pd -compileStorableDataToConst (StorableData ds) = Representation.Constant { - constantData = ArrayConstant $ ArrayConstantType (map compileStorableDataToConst ds) (), - constantSemInf = () -} - --- Transforms a primitive data to an imperative constant. -compilePrimDataToConst :: CoreTypes.PrimitiveData -> Constant InitSemInf -compilePrimDataToConst (UnitData ()) = Representation.Constant { - constantData = BoolConstant $ BoolConstantType False (), - constantSemInf = () -} -compilePrimDataToConst (BoolData x) = Representation.Constant { - constantData = BoolConstant $ BoolConstantType x (), - constantSemInf = () -} -compilePrimDataToConst (IntData x) = Representation.Constant { - constantData = IntConstant $ IntConstantType (fromInteger x) (), - constantSemInf = () -} -compilePrimDataToConst (FloatData x) = Representation.Constant { - constantData = FloatConstant $ FloatConstantType x (), -- TODO - constantSemInf = () -} - --- Transforms an array or primitive data to an imperative typed expression. -compileStorableData :: StorableData -> StorableType -> Expression InitSemInf -compileStorableData (CoreTypes.PrimitiveData pd) (StorableType _ elemTyp) = compilePrimData pd elemTyp -compileStorableData a@(StorableData ds) typ = Expression (ConstantExpression $ compileStorableDataToConst a) () - --- Transforms a primitive data to an imperative typed expression. -compilePrimData :: CoreTypes.PrimitiveData -> PrimitiveType -> Expression InitSemInf -compilePrimData d t = Expression (ConstantExpression $ compilePrimDataToConst d) () - -charType = Numeric ImpSigned S8 -intType = Numeric ImpSigned S32 - --- Transforms a Source to an imperative expression. -transformSourceToExpr :: Source -> StorableType -> Expression InitSemInf -transformSourceToExpr (Graph.Constant primData) (StorableType _ typ) = compilePrimData primData typ -transformSourceToExpr (Graph.Variable (id,path)) typ = genVar id path ctyp - where - ctyp = compileStorableType typ - --- Generates a copy call from variable ids and types. -makeCopyFromIds :: (NodeId,[Int],StorableType) -> (NodeId,[Int],StorableType) -> Instruction InitSemInf -makeCopyFromIds (idFrom,pathFrom,typeFrom) (idTo,pathTo,typeTo) = - makeCopyFromExprs - (genVar idFrom pathFrom ctypFrom) - (genVar idTo pathTo ctypTo) - where - ctypTo = compileStorableType typeTo - ctypFrom = compileStorableType typeFrom - --- Generates a copy call from two expressions. -makeCopyFromExprs :: Expression InitSemInf -> Expression InitSemInf -> Instruction InitSemInf -makeCopyFromExprs from to = Instruction { - instructionData = ProcedureCallInstruction $ ProcedureCall { - nameOfProcedureToCall = "copy", - actualParametersOfProcedureToCall = [ActualParameter { - actualParameterData = InputActualParameter from, - actualParameterSemInf = () - }, - ActualParameter { - actualParameterData = OutputActualParameter $ toLeftValue to, - actualParameterSemInf = () - }], - procedureCallSemInf = () - }, - instructionSemInf = () -} - - --- Generates copies for all variables of a node to all variables of another node. -copyNode :: NodeId -> NodeId -> Tuple StorableType -> Bool -> [Program InitSemInf] -copyNode fromId toId typeStructure isOutputCopying = - tupleWalk - (\path typ -> - Program { - programConstruction = PrimitiveProgram (Primitive { - primitiveInstruction = (makeCopyFromIds (fromId,path,typ) (toId,path,typ)), - primitiveSemInf = isOutputCopying - }), - programSemInf = () - } - ) - typeStructure - --- Generates copies from sources to all variables of a node. -copyResult :: Tuple Source -> NodeId -> Tuple StorableType -> Bool -> [Program InitSemInf] -copyResult ifcOut nid outTyp isOutputCopying = - tupleWalk - (\path (out,typ) -> - Program { - programConstruction = PrimitiveProgram (Primitive { - primitiveInstruction = (makeCopyFromExprs (transformSourceToExpr out typ) (genVar nid path $ compileStorableType typ)), - primitiveSemInf = isOutputCopying - }), - programSemInf = () - } - ) - (tupleZip (ifcOut, outTyp)) - --- Generates copies from sources to output variables. -copyToOutput :: Tuple Source -> Tuple StorableType -> Bool -> [Program InitSemInf] -copyToOutput ifcOut outTyp isOutputCopying = - tupleWalk - (\path (out,typ) -> - Program { - programConstruction = PrimitiveProgram $ Primitive { - primitiveInstruction = (makeCopyFromExprs (transformSourceToExpr out typ) (genOut path $ compileStorableType typ)), - primitiveSemInf = isOutputCopying - }, - programSemInf = () - } - ) - (tupleZip (ifcOut, outTyp)) - - -varToExpr :: Representation.Variable InitSemInf -> Expression InitSemInf -varToExpr v = Expression { - expressionData = LeftValueExpression $ LeftValue { - leftValueData = VariableLeftValue v, - leftValueSemInf = () - }, - expressionSemInf = () -} diff --git a/Feldspar/Compiler/Transformation/GraphUtils.hs b/Feldspar/Compiler/Transformation/GraphUtils.hs deleted file mode 100644 --- a/Feldspar/Compiler/Transformation/GraphUtils.hs +++ /dev/null @@ -1,102 +0,0 @@ --- --- Copyright (c) 2009-2010, 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, TypeSynonymInstances #-} - -module Feldspar.Compiler.Transformation.GraphUtils - ( tupleWalk - , tupleZip - , tupleZipList - , replaceVars - ) where - -import Feldspar.Core.Graph -import Feldspar.Core.Types -import Data.List - - --- replaceVars [(var,fun)] ndhier ---- replace the variable (or the variables of the same node ------ if the list part is empty) according to the "fun" -class RepVars a where - replaceVars:: [(Variable, Variable -> Variable)] -> a -> a - -instance RepVars (Node, [Hierarchy]) where - replaceVars chLs (node, hs) = (replaceVars chLs node, map (replaceVars chLs) hs) - -instance RepVars Hierarchy where - replaceVars chLs (Hierarchy ndHrs) = Hierarchy (map (replaceVars chLs) ndHrs) - -instance RepVars Node where - replaceVars chLs (node@(Node {input = nInp, function = nFunc})) - = node{input= replaceVars chLs nInp, function = replaceVars chLs nFunc} - -instance RepVars (Tuple Source) where - replaceVars chLs (One (Constant x)) = One (Constant x) - replaceVars chLs (One (Variable x)) = One (Variable (replaceVars chLs x)) - replaceVars chLs (Tup tls) = Tup (map (replaceVars chLs) tls) - -instance RepVars Variable where - replaceVars chLs (nId, ls) - = case find (\((v,_),_) -> v == nId) chLs of - Nothing -> (nId, ls) - Just ((v,vls),tr) -> case vls of - [] -> tr (nId, ls) - _ -> if (vls == ls) then (tr (nId,ls)) else (nId,ls) - -instance RepVars Function where - replaceVars chLs (NoInline str ifc) = (NoInline str (replaceVars chLs ifc)) - replaceVars chLs (Parallel ifc) = (Parallel (replaceVars chLs ifc)) - replaceVars chLs (IfThenElse ifc1 ifc2) = (IfThenElse (replaceVars chLs ifc1) (replaceVars chLs ifc2)) - replaceVars chLs (While ifc1 ifc2) = (While (replaceVars chLs ifc1) (replaceVars chLs ifc2)) - replaceVars chLs fun = fun - -instance RepVars Interface where - replaceVars chLs ifc@ (Interface {interfaceOutput = ifOut}) - = ifc{interfaceOutput = replaceVars chLs ifOut} - --- The 'tupleWalk' function walks through a tuple, applies the given --- function to every leaf (while provides information about the place of --- the leaf) and puts the results in a list. -tupleWalk :: ([Int] -> a -> b) -> Tuple a -> [b] -tupleWalk = tupleWalk' [] where - tupleWalk' :: [Int] -> ([Int] -> a -> b) -> Tuple a -> [b] - tupleWalk' p f (One x) = [f p x] - tupleWalk' p f (Tup xs) = concatMap ff $ zip xs [0..] where - ff (x,idx) = tupleWalk' (p ++ [idx]) f x - --- Zips to tuples of the same structure. -tupleZip :: (Tuple a, Tuple b) -> Tuple (a,b) -tupleZip (One x, One y) = One (x,y) -tupleZip (Tup xs, Tup ys) = Tup (map tupleZip $ zip xs ys) -tupleZip _ = error "Error: Tuples with different structure are zipped." - --- Zips the "leafs" to list of tuples. -tupleZipList :: (Tuple a, Tuple b) -> [(a,b)] -tupleZipList (One x, One y) = [(x,y)] -tupleZipList (Tup xs, Tup ys) = concatMap tupleZipList $ zip xs ys -tupleZipList _ = error "Error: Tuples with different structure are zipped." diff --git a/Feldspar/Compiler/Transformation/Lifting.hs b/Feldspar/Compiler/Transformation/Lifting.hs deleted file mode 100644 --- a/Feldspar/Compiler/Transformation/Lifting.hs +++ /dev/null @@ -1,144 +0,0 @@ --- --- Copyright (c) 2009-2010, 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.Transformation.Lifting where - -import Feldspar.Core.Graph -import Feldspar.Core.Types hiding (typeOf) -import Feldspar.Compiler.Transformation.GraphUtils -import Data.List - - -replaceNoInlines:: HierarchicalGraph -> HierarchicalGraph -replaceNoInlines g = HierGraph (replaceNoInlinesHr (graphHierarchy g)) (hierGraphInterface g) - -replaceNoInlinesHrList:: [Hierarchy]-> [Hierarchy] -replaceNoInlinesHrList hrlist = map replaceNoInlinesHr hrlist - -replaceNoInlinesHr:: Hierarchy-> Hierarchy -replaceNoInlinesHr (Hierarchy hrlist) = Hierarchy (map replaceNoInlinesNode hrlist) - -replaceNoInlinesNode:: (Node,[Hierarchy]) -> (Node,[Hierarchy]) - -replaceNoInlinesNode (n,hs) = - case function n of - NoInline name interface -> case replaceList of - [] -> (n,replaceNoInlinesHrList hs) - _ -> (nNew, replaceNoInlinesHrList hsNew) - where - replaceList = foldl (collectChangesHr (interfaceInput interface, hs)) (collectChangesInterface interface hs) hs - (nNew_, hsNew_) = changeInp (interfaceInput interface) replaceList (n,hs) - fullReplaceList = [((interfaceInput interface, []), inpVarsChange)] ++ (map fst replaceList) - (nNew, hsNew) = (nNew_{function= replaceVars fullReplaceList (function nNew_)}, map (replaceVars fullReplaceList) hsNew_) - _ -> (n,replaceNoInlinesHrList hs) - - -changeInp:: NodeId -> [((Variable, Variable -> Variable), Tuple StorableType)] -> (Node, [Hierarchy]) -> (Node, [Hierarchy]) -changeInp inpNode chLs (node, hs) = (newNode, newHs) - where - newNode = Node (nodeId node) - (addIfcInpTypes newTyps (function node)) - (addInps (map (fst . fst) chLs) (input node)) - (addInpTypes newTyps (inputType node)) - (outputType node) - newHs = map (addOutTypesHr inpNode newTyps) hs - newTyps = map snd chLs - addInps vars input = Tup ([input] ++ (map (One . Variable) vars)) - addInpTypes types inpType = Tup ([inpType] ++ types) - addIfcInpTypes types (NoInline str ifc@(Interface {interfaceInputType = ifcType})) - = NoInline str ifc{interfaceInputType = Tup ([ifcType] ++ types)} - addOutTypesHr:: NodeId -> [Tuple StorableType] -> Hierarchy -> Hierarchy - addOutTypesHr id types (Hierarchy ndHrs) = Hierarchy (map (addOutTypesNode id types) ndHrs) - addOutTypesNode:: NodeId -> [Tuple StorableType] -> (Node, [Hierarchy]) -> (Node, [Hierarchy]) - addOutTypesNode id types (node@(Node {nodeId = nId, outputType=outType}) ,hs) - = if (id == nId) then (node{outputType = Tup ([outType] ++ types)}, hs) else (node, hs) - -collectChangesInterface :: Interface -> [Hierarchy] -> [((Variable, Variable -> Variable), Tuple StorableType)] -collectChangesInterface iface hs = map (genChange (interfaceInput iface)) $ zip [1..] $ filter ((mustChange hs) . fst) (tupleZipList (interfaceOutput iface, interfaceOutputType iface)) - - -genChange:: NodeId -> (NodeId, (Source, StorableType)) -> ((Variable, Variable -> Variable), Tuple StorableType) -genChange inpId (index, (Variable (id, list), typ)) = (((id, list), varChange inpId index) , One typ) - -mustChange:: [Hierarchy] -> Source -> Bool -mustChange hs x - = case x of - (Variable (id, list)) -> (notInHr id hs) - _ -> False - -inpVarsChange:: Variable -> Variable -inpVarsChange (id,list) = (id, [0] ++ list) - -varChange:: NodeId -> Int -> Variable -> Variable -varChange id index _ = (id, [index]) - - - -class CollectChangesHr a where - collectChangesHr:: (NodeId, [Hierarchy]) -> [((Variable, Variable -> Variable), Tuple StorableType)] -> a -> [((Variable, Variable -> Variable), Tuple StorableType)] - -instance CollectChangesHr Hierarchy where - collectChangesHr nhs changesList (Hierarchy nodeHsList) = foldl (collectChangesHr nhs) changesList nodeHsList - -instance CollectChangesHr (Node, [Hierarchy]) where - collectChangesHr nhs changesList (node, hsList) = foldl (collectChangesHr nhs) (collectChangesHr nhs changesList node) hsList - -instance CollectChangesHr Node where - collectChangesHr nhs changesList node = collectChangesHr nhs (collectChangesHr nhs changesList (filter ((mustChange (snd nhs)) . fst) (tupleZipList (input node, inputType node)))) (function node) - - -instance CollectChangesHr [(Source,StorableType)] where - collectChangesHr (nodeId,hs) changesList sourceList = changesList ++ (map (genChange nodeId) $ zip [((length changesList) + 1)..] $ sourceList) - -instance CollectChangesHr Function where - collectChangesHr nhs changesList (NoInline _ ifc) = collectChangesHr nhs changesList ifc - collectChangesHr nhs changesList (Parallel ifc) = collectChangesHr nhs changesList ifc - collectChangesHr nhs changesList (IfThenElse ifc1 ifc2) = collectChangesHr nhs (collectChangesHr nhs changesList ifc1) ifc2 - collectChangesHr nhs changesList (While ifc1 ifc2) = collectChangesHr nhs (collectChangesHr nhs changesList ifc1) ifc2 - collectChangesHr (nodeId,hs) changesList _ = changesList - -instance CollectChangesHr Interface where - collectChangesHr (nodeId,hs) changesList ifc = changesList ++ (map (genChange nodeId) $ zip [((length changesList) + 1)..] $ filter (mustChange hs . fst) (tupleZipList (interfaceOutput ifc, interfaceOutputType ifc))) - -class NotInHr a where - notInHr :: NodeId -> a -> Bool - -instance NotInHr [Hierarchy] where - notInHr id hs = and $ map (notInHr id) hs - -instance NotInHr Hierarchy where - notInHr id (Hierarchy nodeHs) = and $ map (notInHr id) nodeHs - -instance NotInHr (Node, [Hierarchy]) where - notInHr id (node, hs) = (notInHr id node) && (notInHr id hs) - -instance NotInHr Node where - notInHr id node = id /= (nodeId node) - diff --git a/Feldspar/Fs2dot.hs b/Feldspar/Fs2dot.hs deleted file mode 100644 --- a/Feldspar/Fs2dot.hs +++ /dev/null @@ -1,266 +0,0 @@ --- --- Copyright (c) 2009-2010, 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. --- - --- |Fs2dot is to help us create a visualisation of an algorithm written in --- Feldspar by converting its graph into dot format -- which can be further --- processed by the Graphviz suite. -module Feldspar.Fs2dot - ( fs2dot - , writeDot - , DOTSource - ) - where - -import Feldspar.Core.Types -import Feldspar.Core.Graph -import Feldspar.Core.Reify (reify, Program) -import Prelude hiding (id) - -{- frontend -} - --- |'fs2dot' takes a Feldspar function as its argument and produces DOT language --- source. -fs2dot :: (Program prg) - => prg -- ^Feldspar function - -> DOTSource -- ^DOT language source -fs2dot = toDot . fromGraph . makeHierarchical . reify - --- |'writeDot' creates a DOT language format source file. Expected arguments --- are the desired filename and the Feldspar function to be output in DOT --- language. -writeDot :: (Program prg) - => FilePath -- ^output filename - -> prg -- ^Feldspar function - -> IO () -writeDot filename prg = writeFile filename $ fs2dot prg - --- |This is for clarity. -type DOTSource = String - -{- data types -} - -data DGraph = - DGraph - { inputs :: [NodeId] - , outputs :: [NodeId] - , nodes :: [DNode] - , edges :: [DEdge] - } - deriving (Eq, Show) - -data DNode = - DNode - { id :: Int - , role :: Function - , subgraphs :: [DGraph] - , label :: String - } - deriving (Eq, Show) - -data DEdge = - DEdge - { start :: DConnector - , end :: DConnector - } - deriving (Eq, Show) - -data DConnector = - DNodeConn (NodeId, Int) - | DConstConn PrimitiveData - deriving (Eq, Show) - -{- core -} - -fromGraph :: HierarchicalGraph - -> DGraph -fromGraph graph = - DGraph - { inputs = enumerateInputs graph - , outputs = enumerateOutputs graph - , nodes = (\(Hierarchy h) -> enumerateNodes h) $ graphHierarchy graph - , edges = (\(Hierarchy h) -> enumerateEdges h) $ graphHierarchy graph - } - - where - enumerateInputs graph = [interfaceInput $ hierGraphInterface graph] - enumerateOutputs graph = graph - |> tuple2list . interfaceOutput . hierGraphInterface - |> map (\(Variable (n, _)) -> n) . filter isVariable - - enumerateNodes = map - (\(node, hiers) -> - DNode - { id = nodeId node - , role = function node - , subgraphs = hiers |> map - (\hier -> DGraph - { inputs = [] - , outputs = [] - , nodes = (\(Hierarchy h) -> enumerateNodes h) hier - , edges = [] - } - ) - , label = (fun2label (function node) - ++ " (" ++ show (nodeId node) ++ ")") |> subst '"' '\'' - } - ) - - enumerateEdges :: [(Node, [Hierarchy])] -> [DEdge] - enumerateEdges = concatMap - (\(node, hiers) -> - [ DEdge - { start = DNodeConn (inputnode, 0) - , end = DNodeConn (nodeId node, 0) - } - | inputnode <- - (tuple2list $ input node) - |> filter isVariable |> map (\(Variable (n, _)) -> n) - ] ++ - [ DEdge - { start = DConstConn (constval) - , end = DNodeConn (nodeId node, 0) - } - | constval <- - (tuple2list $ input node) - |> filter (not.isVariable) |> map (\(Constant val) -> val) - ] ++ - concatMap (\(Hierarchy h) -> enumerateEdges h) hiers - ) - - isVariable src = case src of - Variable _ -> True - _ -> False - -toDot :: DGraph - -> DOTSource -toDot graph = - [ dGraphHead - , dGraphOptions - , dGraphNodes graph - , dGraphEdges graph - , dGraphOutputs graph - , dGraphTail - ] |> unlines - |> unlines . filter (not.null) . lines - - where - dGraphHead = "digraph G {" - dGraphOptions = - [ "node [shape=box]" - , "compound=true bgcolor=\"lightgray\"" - , "node [style=filled color=\"black\" fillcolor=\"steelblue\"]" - , "edge []" - ] |> unlines - - dGraphNodes graph = - nodes graph - |> map - (\node -> - if compound node - then - [ "subgraph cluster" ++ show (id node) ++ " {" - , "label =\"" ++ label node ++ "\"" - , subgraphs node |> map - (\subgraph -> - [ dGraphNodes subgraph - , dGraphEdges subgraph - ] |> unlines - ) |> unlines - , "}" - ] |> unlines - else - [ "node" ++ show (id node) - , "[label=\"" ++ label node ++ "\"" - , "href=\"#node" ++ show (id node) ++ "\"]" - ] |> unwords - ) - |> unlines - - dGraphEdges graph = - zip [1..] (edges graph) - |> map - (\(n, edge) -> - if constEdge edge - then "const" ++ show ((\(DNodeConn (i, _)) -> i) $ end edge) - ++ "_" ++ show n - ++ " [label=\"" - ++ show ((\(DEdge (DConstConn val) _) -> val) edge) - ++ "\"]\n" - ++ "const" ++ show ((\(DNodeConn (i, _)) -> i) $ end edge) - ++ "_" ++ show n - ++ " -> " - ++ "node" ++ show ((\(DNodeConn (i, _)) -> i) $ end edge) - else "node" ++ show ((\(DNodeConn (i, _)) -> i) $ start edge) - ++ " -> " - ++ "node" ++ show ((\(DNodeConn (i, _)) -> i) $ end edge) - ) - |> unlines - - where - label edge = "" - constEdge edge = case edge of - DEdge (DConstConn _) _ -> True - _ -> False - - dGraphOutputs graph = zip [0 ..] (outputs graph) |> map - (\(n, opid) -> - [ "node" ++ show opid ++ " -> output" ++ show n - , "output" ++ show n ++ " [label=\"Output " ++ show n ++ "\"]" - ] |> unlines - ) |> unlines - dGraphTail = "}" - compound = \n -> (not.null) $ subgraphs n - -fun2label :: Function - -> String -fun2label (Input) = "Input" -fun2label (Array sd) = "Array " ++ (show sd) -fun2label (Function str) = "Function " ++ (show str) -fun2label (NoInline str ifc) = "NoInLine " ++ (show str) -fun2label (IfThenElse ifc1 ifc2) = "IfThenElse" -fun2label (While ifc1 ifc2) = "While" -fun2label (Parallel ifc) = "Parallel" -- ++ (show i) - -{- utility functions -} - -tupleCount :: Tuple a -> Int -tupleCount (One a) = 1 -tupleCount (Tup as) = sum $ map tupleCount as - -tuple2list :: Tuple a -> [a] -tuple2list (One a) = [a] -tuple2list (Tup as) = concatMap tuple2list as - -subst :: (Eq a) => a -> a -> [a] -> [a] -subst _ _ [] = [] -subst a b (x:xs) = (if a == x then b else x) : subst a b xs - -infixl 1 |> -(|>) :: a -> (a -> b) -> b -(|>) x f = f x - diff --git a/Feldspar/NameExtractor.hs b/Feldspar/NameExtractor.hs new file mode 100644 --- /dev/null +++ b/Feldspar/NameExtractor.hs @@ -0,0 +1,114 @@ +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 :: String -> String -- filecontents -> modulename +getModuleName = stripModuleName . stripModule2 . fromParseResult . customizedParse + +usedExtensions = glasgowExts ++ [ExplicitForall] + +-- Ultimate debug function +getParseOutput fileName = parseFileWithMode (defaultParseMode { extensions = usedExtensions }) fileName + +-- or: parseFileContentsWithMode +customizedParse = parseModuleWithMode (defaultParseMode { extensions = usedExtensions }) + +getFullDeclarationListWithParameterList :: String -> [OriginalFunctionSignature] +getFullDeclarationListWithParameterList fileContents = + map stripFunBind (stripModule $ fromParseResult $ customizedParse 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 fileContents) + +printParameterListOfFunction :: FilePath -> String -> IO [Maybe String] +printParameterListOfFunction fileName functionName = getParameterList fileName functionName + +-- The interface +getDeclarationList :: String -> [String] -- filecontents -> Stringlist +getDeclarationList = stripUnnecessary . (map originalFunctionName) . getFullDeclarationListWithParameterList + +getExtendedDeclarationList :: String -> [OriginalFunctionSignature] -- filecontents -> ExtDeclList +getExtendedDeclarationList fileContents = filter (functionNameNeeded . originalFunctionName) + (getFullDeclarationListWithParameterList fileContents) + +getParameterListOld :: String -> String -> [Maybe String] +getParameterListOld fileContents funName = originalParameterNames $ head $ + filter ((==funName) . originalFunctionName) (getExtendedDeclarationList 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 fileContents) diff --git a/Feldspar/Transformation.hs b/Feldspar/Transformation.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Transformation.hs @@ -0,0 +1,21 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Transformation/Framework.hs @@ -0,0 +1,109 @@ +{-# 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 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,4 +1,4 @@ -Copyright (c) 2009-2010, ERICSSON AB +Copyright (c) 2009-2011, ERICSSON AB All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,31 +1,3 @@ --- --- Copyright (c) 2009-2010, 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. --- - import Distribution.Simple main = defaultMain diff --git a/feldspar-compiler.cabal b/feldspar-compiler.cabal --- a/feldspar-compiler.cabal +++ b/feldspar-compiler.cabal @@ -1,10 +1,10 @@ name: feldspar-compiler -version: 0.3.2 +version: 0.4.0.2 cabal-version: >= 1.6 build-type: Simple license: BSD3 license-file: LICENSE -copyright: Copyright (c) 2009-2010, ERICSSON AB +copyright: Copyright (c) 2009-2011, ERICSSON AB author: Feldspar group, Eotvos Lorand University Faculty of Informatics maintainer: deva@inf.elte.hu @@ -19,36 +19,43 @@ language both according to ANSI C and also targeted to a real DSP HW. category: Compiler -tested-with: GHC==6.10.* +tested-with: GHC==6.12.*, GHC==7.0.2 library exposed-modules: - Feldspar.Compiler.Imperative.CodeGeneration Feldspar.Compiler.Imperative.Representation - Feldspar.Compiler.Imperative.Semantics - Feldspar.Compiler.PluginArchitecture.DefaultConvert - Feldspar.Compiler.Plugins.BackwardPropagation - Feldspar.Compiler.Plugins.ForwardPropagation - Feldspar.Compiler.Plugins.HandlePrimitives - Feldspar.Compiler.Plugins.Precompilation - Feldspar.Compiler.Plugins.PrettyPrint - Feldspar.Compiler.Plugins.PropagationUtils - Feldspar.Compiler.Plugins.Unroll - Feldspar.Compiler.Precompiler.Precompiler - Feldspar.Compiler.Transformation.GraphToImperative - Feldspar.Compiler.Transformation.GraphUtils - Feldspar.Compiler.Transformation.Lifting + Feldspar.Compiler.Imperative.FromCore + Feldspar.Compiler.Imperative.Frontend + Feldspar.Compiler.Imperative.TransformationInstance + Feldspar.Compiler.Imperative.Plugin.ConstantFolding + Feldspar.Compiler.Imperative.Plugin.Unroll + Feldspar.Compiler.Imperative.Plugin.Naming + Feldspar.Compiler.Backend.C.CodeGeneration + Feldspar.Compiler.Backend.C.Plugin.PrettyPrint + Feldspar.Compiler.Backend.C.Plugin.Locator + Feldspar.Compiler.Backend.C.Plugin.HandlePrimitives + Feldspar.Compiler.Backend.C.Plugin.BlockProgramHandler + 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.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.Compiler Feldspar.Compiler.Error - Feldspar.Compiler.Options - Feldspar.Compiler.Platforms - Feldspar.Compiler.PluginArchitecture Feldspar.Compiler - Feldspar.Fs2dot + Feldspar.Transformation + Feldspar.Transformation.Framework + Feldspar.NameExtractor build-depends: - feldspar-language == 0.3.*, - base >= 4 && < 4.3, + feldspar-language == 0.4.*, + base >= 4 && < 4.4, containers, haskell-src-exts, directory, @@ -59,11 +66,16 @@ process extensions: + DeriveDataTypeable EmptyDataDecls FlexibleContexts FlexibleInstances + GADTs MultiParamTypeClasses + PatternGuards Rank2Types + ScopedTypeVariables + StandaloneDeriving TypeFamilies TypeSynonymInstances UndecidableInstances @@ -72,31 +84,38 @@ ./Feldspar/C install-includes: + feldspar_array.h + feldspar_array.c feldspar_c99.h feldspar_c99.c feldspar_tic64x.h feldspar_tic64x.c -executable feldspar - main-is : ./Feldspar/Compiler/CompilerMain.hs + ghc-options: -fcontext-stack=30 - other-modules: - Feldspar.Compiler.Standalone.Constants - Feldspar.Compiler.Standalone.Library - Feldspar.Compiler.Standalone.Options +executable feldspar + main-is : ./Feldspar/Compiler/Frontend/CommandLine/Main.hs build-depends: ansi-terminal extensions: CPP + DeriveDataTypeable EmptyDataDecls FlexibleContexts FlexibleInstances + GADTs MultiParamTypeClasses + PatternGuards Rank2Types + ScopedTypeVariables + StandaloneDeriving TypeFamilies TypeSynonymInstances UndecidableInstances + + + ghc-options: -fcontext-stack=30 cpp-options: -DRELEASE