diff --git a/Feldspar/C/feldspar.c b/Feldspar/C/feldspar.c deleted file mode 100644 --- a/Feldspar/C/feldspar.c +++ /dev/null @@ -1,269 +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. - */ - -#include "feldspar.h" - - - -int mod_fun_signed_int( int a, int b ) -{ - if ((a > 0 && b > 0) || (a < 0 && b < 0)) return a % b; - return (a % b) * (-1); -} - -int mod_fun_unsigned_int( unsigned int a, unsigned int b ) -{ - return a % b; -} - -long mod_fun_signed_long( long a, long b ) -{ - if ((a > 0 && b > 0) || (a < 0 && b < 0)) return a % b; - return (a % b) * (-1); -} - -long mod_fun_unsigned_long( unsigned long a, unsigned long b ) -{ - return a % b; -} - - - -int pow_fun_signed_int( int a, int b) -{ - int out = 1; - int i; - for(i=0; i> -i; - if (i > 0) return x << i; - return x; - } - - -int bit_rotate_fun_signed_int( int x, int i ) -{ - if (i < 0 && x < 0) { - int left = i + sizeof(x) * 8; - return ((x >> -i) & ~bit_shift_fun_signed_int(-1, left)) ^ bit_shift_fun_signed_int(x, left); - } - if (i < 0) return x >> -i ^ bit_shift_fun_signed_int(x, i + sizeof(x) * 8); - else if (i == 0) return x; - else return x << i ^ bit_shift_fun_signed_int(x, i - sizeof(x) * 8); -} - -int rotateL_fun_signed_int( int x, int i ) -{ - return bit_rotate_fun_signed_int(x, i); -} - -int rotateR_fun_signed_int( int x, int i ) -{ - return bit_rotate_fun_signed_int(x, -i); -} - - - - -int bitSize_fun_signed_int( int x ) -{ - return sizeof x * 8; -} - -int isSigned_fun_signed_int( int x ) -{ - (void) x; - return 1; -} - - - -int abs_fun_signed_int( int a ) -{ - if (a < 0) return a*(-1); - return a; -} - -int abs_fun_unsigned_int( unsigned int a ) -{ - return a; -} - -long abs_fun_signed_long( long a ) -{ - if (a < 0) return a*(-1); - return a; -} - -long abs_fun_unsigned_long( unsigned long a ) -{ - return a; -} - -double abs_fun_float( float a ) -{ - if (a < 0) return a*(-1); - return a; -} - -double abs_fun_double( double a ) -{ - if (a < 0) return a*(-1); - return a; -} - - - -int signum_fun_signed_int( int a ) -{ - if (a < 0) return -1; - if (a > 0) return 1; - return 0; -} - -int signum_fun_unsigned_int( unsigned int a ) -{ - if (a > 0) return 1; - return 0; -} - -long signum_fun_signed_long( long a ) -{ - if (a < 0) return -1; - if (a > 0) return 1; - return 0; -} - -long signum_fun_unsigned_long( unsigned long a ) -{ - if (a > 0) return 1; - return 0; -} - -double signum_fun_float( float a ) -{ - if (a < 0) return -1; - if (a > 0) return 1; - return 0; -} - -double signum_fun_double( double a ) -{ - if (a < 0) return -1; - if (a > 0) return 1; - return 0; -} - - - -void copy_arrayOf_signed_int( int* a, int a1, int* b) -{ - int i; - for( i=0; i +#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, + "The 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, "The 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, "The 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); +} diff --git a/Feldspar/C/feldspar_c99.h b/Feldspar/C/feldspar_c99.h new file mode 100644 --- /dev/null +++ b/Feldspar/C/feldspar_c99.h @@ -0,0 +1,179 @@ +// +// 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 + + + +int8_t pow_fun_int8( int8_t, int8_t ); +int16_t pow_fun_int16( int16_t, int16_t ); +int32_t pow_fun_int32( int32_t, int32_t ); +int64_t pow_fun_int64( int64_t, int64_t ); +uint8_t pow_fun_uint8( uint8_t, uint8_t ); +uint16_t pow_fun_uint16( uint16_t, uint16_t ); +uint32_t pow_fun_uint32( uint32_t, uint32_t ); +uint64_t pow_fun_uint64( uint64_t, uint64_t ); + +int8_t abs_fun_int8( int8_t ); +int16_t abs_fun_int16( int16_t ); +int32_t abs_fun_int32( int32_t ); +int64_t abs_fun_int64( int64_t ); + +int8_t signum_fun_int8( int8_t ); +int16_t signum_fun_int16( int16_t ); +int32_t signum_fun_int32( int32_t ); +int64_t signum_fun_int64( int64_t ); +uint8_t signum_fun_uint8( uint8_t ); +uint16_t signum_fun_uint16( uint16_t ); +uint32_t signum_fun_uint32( uint32_t ); +uint64_t signum_fun_uint64( uint64_t ); +float signum_fun_float( float ); + + + +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 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 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 ); + +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 ); + +int8_t rotateL_fun_int8( int8_t, int32_t ); +int16_t rotateL_fun_int16( int16_t, int32_t ); +int32_t rotateL_fun_int32( int32_t, int32_t ); +int64_t rotateL_fun_int64( int64_t, int32_t ); +uint8_t rotateL_fun_uint8( uint8_t, int32_t ); +uint16_t rotateL_fun_uint16( uint16_t, int32_t ); +uint32_t rotateL_fun_uint32( uint32_t, int32_t ); +uint64_t rotateL_fun_uint64( uint64_t, int32_t ); + +int8_t rotateR_fun_int8( int8_t, int32_t ); +int16_t rotateR_fun_int16( int16_t, int32_t ); +int32_t rotateR_fun_int32( int32_t, int32_t ); +int64_t rotateR_fun_int64( int64_t, int32_t ); +uint8_t rotateR_fun_uint8( uint8_t, int32_t ); +uint16_t rotateR_fun_uint16( uint16_t, int32_t ); +uint32_t rotateR_fun_uint32( uint32_t, int32_t ); +uint64_t rotateR_fun_uint64( uint64_t, int32_t ); + +int8_t reverseBits_fun_int8( int8_t ); +int16_t reverseBits_fun_int16( int16_t ); +int32_t reverseBits_fun_int32( int32_t ); +int64_t reverseBits_fun_int64( int64_t ); +uint8_t reverseBits_fun_uint8( uint8_t ); +uint16_t reverseBits_fun_uint16( uint16_t ); +uint32_t reverseBits_fun_uint32( uint32_t ); +uint64_t reverseBits_fun_uint64( uint64_t ); + +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 ); + +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 ); + + + +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* ); + + + +void traceStart(); +void traceEnd(); + +void trace_int8( int8_t, int32_t ); +void trace_int16( int16_t, int32_t ); +void trace_int32( int32_t, int32_t ); +void trace_int64( int64_t, int32_t ); +void trace_uint8( uint8_t, int32_t ); +void trace_uint16( uint16_t, int32_t ); +void trace_uint32( uint32_t, int32_t ); +void trace_uint64( uint64_t, int32_t ); +void trace_float( float, int32_t ); + +#endif /* FELDSPAR_C99_H */ diff --git a/Feldspar/C/feldspar_tic64x.c b/Feldspar/C/feldspar_tic64x.c new file mode 100644 --- /dev/null +++ b/Feldspar/C/feldspar_tic64x.c @@ -0,0 +1,1078 @@ +// +// 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, "The 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, "The 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); +} diff --git a/Feldspar/C/feldspar_tic64x.h b/Feldspar/C/feldspar_tic64x.h new file mode 100644 --- /dev/null +++ b/Feldspar/C/feldspar_tic64x.h @@ -0,0 +1,191 @@ +// +// 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 + + + +char pow_fun_char( char, char ); +short pow_fun_short( short, short ); +int pow_fun_int( int, int ); +long pow_fun_long( long, long ); +long long pow_fun_llong( long long, long long ); +unsigned char pow_fun_uchar( unsigned char, unsigned char ); +unsigned short pow_fun_ushort( unsigned short, unsigned short ); +unsigned pow_fun_uint( unsigned, unsigned ); +unsigned long pow_fun_ulong( unsigned long, unsigned long ); +unsigned long long pow_fun_ullong( unsigned long long, unsigned long long ); + +char abs_fun_char( char ); +short abs_fun_short( short ); +long abs_fun_long( long ); +long long abs_fun_llong( long long ); + +char signum_fun_char( char ); +short signum_fun_short( short ); +int signum_fun_int( int ); +long signum_fun_long( long ); +long long signum_fun_llong( long long ); +unsigned char signum_fun_uchar( unsigned char ); +unsigned short signum_fun_ushort( unsigned short ); +unsigned signum_fun_uint( unsigned ); +unsigned long signum_fun_ulong( unsigned long ); +unsigned long long signum_fun_ullong( unsigned long long ); +float signum_fun_float( float ); + + + +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 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 ); + +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 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 ); +unsigned char rotateL_fun_uchar( unsigned char, int ); +unsigned short rotateL_fun_ushort( unsigned short, int ); +unsigned long rotateL_fun_ulong( unsigned long, int ); +unsigned long long rotateL_fun_ullong( unsigned long long, int ); + +char rotateR_fun_char( char, int ); +short rotateR_fun_short( short, int ); +int rotateR_fun_int( int, int ); +long rotateR_fun_long( long, int ); +long long rotateR_fun_llong( long long, int ); +unsigned char rotateR_fun_uchar( unsigned char, int ); +unsigned short rotateR_fun_ushort( unsigned short, int ); +unsigned rotateR_fun_uint( unsigned, int ); +unsigned long rotateR_fun_ulong( unsigned long, int ); +unsigned long long rotateR_fun_ullong( unsigned long long, int ); + +char reverseBits_fun_char( char ); +short reverseBits_fun_short( short ); +int reverseBits_fun_int( int ); +long reverseBits_fun_long( long ); +long long reverseBits_fun_llong( long long ); +unsigned char reverseBits_fun_uchar( unsigned char ); +unsigned short reverseBits_fun_ushort( unsigned short ); +unsigned long reverseBits_fun_ulong( unsigned long ); +unsigned long long reverseBits_fun_ullong( unsigned long long ); + +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 ); + +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 ); + + + +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* ); + + + +void traceStart(); +void traceEnd(); + +void trace_char( char, int ); +void trace_short( short, int ); +void trace_int( int, int ); +void trace_long( long, int ); +void trace_llong( long long, int ); +void trace_uchar( unsigned char, int ); +void trace_ushort( unsigned short, int ); +void trace_uint( unsigned, int ); +void trace_ulong( unsigned long, int ); +void trace_ullong( unsigned long long, int ); +void trace_float( float, int ); + +#endif /* FELDSPAR_TI_C64X_H */ diff --git a/Feldspar/Compiler.hs b/Feldspar/Compiler.hs --- a/Feldspar/Compiler.hs +++ b/Feldspar/Compiler.hs @@ -1,42 +1,38 @@ -{- - - 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. - -} +-- +-- 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' , defaultOptions + , tic64xPlatformOptions , unrollOptions - , c99Options , noSimplification , noPrimitiveInstructionHandling ) where diff --git a/Feldspar/Compiler/Compiler.hs b/Feldspar/Compiler/Compiler.hs --- a/Feldspar/Compiler/Compiler.hs +++ b/Feldspar/Compiler/Compiler.hs @@ -1,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 @@ -36,11 +32,12 @@ , icompile , icompile' , defaultOptions + , tic64xPlatformOptions , unrollOptions - , c99Options , noSimplification , noPrimitiveInstructionHandling - , includeGeneration + , fixFunctionName + , c99Options ) where import Data.Map @@ -50,6 +47,7 @@ import qualified Feldspar.Core.Expr as Expr import Feldspar.Core.Types import Feldspar.Compiler.Options +import Feldspar.Compiler.Platforms import Feldspar.Compiler.Transformation.GraphToImperative import Feldspar.Compiler.Transformation.Lifting @@ -60,8 +58,9 @@ import Feldspar.Compiler.Plugins.HandlePrimitives import Feldspar.Compiler.Plugins.PrettyPrint import Feldspar.Compiler.Plugins.Unroll -import Feldspar.Compiler.Plugins.ConstantFolding +--import Feldspar.Compiler.Plugins.ConstantFolding + import Feldspar.Compiler.Transformation.GraphUtils import Feldspar.Compiler.Imperative.Semantics import Feldspar.Compiler.Imperative.Representation @@ -69,12 +68,7 @@ import qualified Feldspar.Compiler.Precompiler.Precompiler as Precompiler import System.IO ------------------------------------------- --- Header file for generated C programs -- ------------------------------------------- -intro = "#include \"feldspar.h\"\n\n" - type Writer t = (CompilationMode -> t -> FilePath -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> IO ()) ------------------------- @@ -100,13 +94,9 @@ -- Standalone compiler -- ------------------------- -includeGeneration :: FilePath -> IO () -includeGeneration fileName - = appendFile fileName intro - standaloneWrite :: (Reify.Program t) => Writer t standaloneWrite compilationMode prg outFileName originalFeldsparFunctionSignature opts - = appendFile outFileName $ compToC $ executePluginChain compilationMode prg originalFeldsparFunctionSignature opts + = appendFile outFileName $ compToC (platform opts) $ executePluginChain compilationMode prg originalFeldsparFunctionSignature opts standaloneCompile :: (Reify.Program t) => t -> FilePath -> FilePath -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> IO () standaloneCompile prg inputFileName outputFileName originalFeldsparFunctionSignature opts @@ -118,7 +108,7 @@ fileWrite :: (Reify.Program t) => Writer t fileWrite compilationMode prg fileName originalFeldsparFunctionSignature opts - = writeFile fileName $ intro ++ (compToC $ executePluginChain compilationMode prg originalFeldsparFunctionSignature opts) + = writeFile fileName $ (incList $ includes $ platform $ opts) ++ (compToC (platform opts) $ executePluginChain compilationMode prg originalFeldsparFunctionSignature opts) compile :: (Reify.Program t) => t -> FilePath -> String -> Options -> IO () compile prg fileName functionName opts @@ -126,7 +116,7 @@ writeOut :: (Reify.Program t) => Writer t writeOut compilationMode prg fileName functionName opts - = putStrLn $ intro ++ (compToC $ executePluginChain compilationMode prg functionName opts) + = putStrLn $ (incList $ includes $ platform $ opts) ++ (compToC (platform opts) $ executePluginChain compilationMode prg functionName opts) icompile :: (Reify.Program t) => t -> IO () icompile prg @@ -136,21 +126,27 @@ icompile' prg functionName opts = coreCompile writeOut Interactive prg "" "" (Precompiler.OriginalFeldsparFunctionSignature functionName []) opts +incList :: [String] -> String +incList [] = "\n" +incList (x:xs) = "#include " ++ x ++ "\n" ++ (incList xs) + ------------------------ -- Predefined options -- ------------------------ defaultOptions = Options - { platform = AnsiC + { platform = c99 , unroll = NoUnroll , debug = NoDebug , defaultArraySize = 16 } -c99Options - = defaultOptions { platform = C99 } +c99Options = defaultOptions +tic64xPlatformOptions + = defaultOptions { platform = tic64x } + unrollOptions = defaultOptions { unroll = Unroll 8 } @@ -167,7 +163,7 @@ pluginChain :: ExternalInfoCollection -> Procedure InitSemInf -> Procedure PrettyPrintSemanticInfo pluginChain externalInfo = (executePlugin PrettyPrint (prettyPrintExternalInfo externalInfo)) - . (executePlugin ConstantFolding ()) +-- . (executePlugin ConstantFolding ()) . (executePlugin UnrollPlugin (unrollExternalInfo externalInfo)) . (executePlugin Precompilation (precompilationExternalInfo externalInfo)) . (executePlugin ForwardPropagation (forwardPropagationExternalInfo externalInfo)) @@ -195,7 +191,7 @@ }, prettyPrintExternalInfo = (platform opt, defaultArraySize opt), unrollExternalInfo = unroll opt, - handlePrimitivesExternalInfo = (defaultArraySize opt, debug opt), + handlePrimitivesExternalInfo = (defaultArraySize opt, debug opt, platform opt), forwardPropagationExternalInfo = debug opt, backwardPropagationExternalInfo = debug opt }) diff --git a/Feldspar/Compiler/CompilerMain.hs b/Feldspar/Compiler/CompilerMain.hs --- a/Feldspar/Compiler/CompilerMain.hs +++ b/Feldspar/Compiler/CompilerMain.hs @@ -1,40 +1,40 @@ -{- - - 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. - -} +-- +-- 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 -- ONLY for improving compilation speed in normal mode +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 @@ -50,59 +50,68 @@ import Data.List import System.Console.GetOpt +import System.Console.ANSI import System.FilePath import Language.Haskell.Interpreter -warningPrefix = "[WARNING]: " -errorPrefix = "[ERROR ]: " - serializeOriginalFeldsparFunctionSignature originalFeldsparFunctionSignature = - "(OriginalFeldsparFunctionSignature \"" ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ "\" " ++ (show $ originalFeldsparParameterNames originalFeldsparFunctionSignature) ++ ")" + "(OriginalFeldsparFunctionSignature \"" ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ + "\" " ++ (show $ originalFeldsparParameterNames originalFeldsparFunctionSignature) ++ ")" -generateCompileCode :: String -> String -> String -> OriginalFeldsparFunctionSignature -> String -generateCompileCode inputFileName outputFileName options originalFeldsparFunctionSignature = - "standaloneCompile " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ " \"" ++ inputFileName ++ "\" " ++ " \""++ - outputFileName ++"\" " ++ (serializeOriginalFeldsparFunctionSignature originalFeldsparFunctionSignature) ++ " " ++ options +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 -> String -> OriginalFeldsparFunctionSignature -> Interpreter () +compileFunction :: String -> String -> CoreOptions.Options -> OriginalFeldsparFunctionSignature -> Interpreter () compileFunction inFileName outFileName options originalFeldsparFunctionSignature = do - iPutStr $ "Compiling function " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ "...\t" + 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 - iPutStrLn "[OK]" + liftIO $ withColor Green (putStrLn "[OK]") -compileAllFunctions :: String -> String -> String -> [OriginalFeldsparFunctionSignature] -> Interpreter () +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 $ iPutStrLn "[FAILED]")) + (catchError (compileFunction inFileName outFileName options x) + (const $ liftIO $ withColor Red (putStrLn "[FAILED]"))) `Control.Monad.CatchIO.catch` - (\msg -> iPutStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)) + (\msg -> liftIO $ withColor Red $ putStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)) compileAllFunctions inFileName outFileName options xs -globalImportList = ["Feldspar.Fs2dot", "Feldspar.Compiler.Compiler", "Feldspar.Compiler.Precompiler.Precompiler"] +buildIncludeString :: [String] -> String +buildIncludeString includes = concatMap (\x -> "#include " ++ x ++ "\n") includes -generateIncludeLine :: String -> Interpreter () -generateIncludeLine outputFileName = do - result <- interpret ("includeGeneration \"" ++ outputFileName ++ "\"") (as::IO()) - lift result +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 -> String -> OriginalFeldsparFunctionSignature -> Interpreter (IO ()) -singleFunctionCompilationBody inFileName outFileName options originalFeldsparFunctionSignature = do +singleFunctionCompilationBody :: String -> String -> CoreOptions.Options -> OriginalFeldsparFunctionSignature -> Interpreter (IO ()) +singleFunctionCompilationBody inFileName outFileName coreOptions originalFeldsparFunctionSignature = do iPutStrLn $ "Output file: " ++ outFileName iPutStrLn $ "Compiling function " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ "..." - generateIncludeLine outFileName - result <- interpret (generateCompileCode inFileName outFileName options originalFeldsparFunctionSignature) (as::IO()) + 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 -> String -> [OriginalFeldsparFunctionSignature] -> Interpreter (IO ()) -multiFunctionCompilationBody inFileName outFileName compilerOptions declarationList = do +multiFunctionCompilationBody :: String -> String -> CoreOptions.Options -> [OriginalFeldsparFunctionSignature] -> Interpreter (IO ()) +multiFunctionCompilationBody inFileName outFileName coreOptions declarationList = do iPutStrLn $ "Output file: " ++ outFileName - generateIncludeLine outFileName - compileAllFunctions inFileName outFileName compilerOptions declarationList + liftIO $ includeGeneration outFileName coreOptions + compileAllFunctions inFileName outFileName coreOptions declarationList return(return()) -- | A general interpreter body for interpreting an expression @@ -142,66 +151,6 @@ printInterpreterError (WontCompile xs) printInterpreterError e = putStrLn $ "Code generation failed: " ++ (show e) -data FunctionMode = SingleFunction String | MultiFunction - -data Options = Options { optSingleFunction :: FunctionMode - , optOutputFileName :: Maybe String - , optDotGeneration :: Bool - , optDotFileName :: Maybe String - , optCompilerMode :: String - } - --- | Default options -startOptions :: Options -startOptions = Options { optSingleFunction = MultiFunction - , optOutputFileName = Nothing - , optDotGeneration = False - , optDotFileName = Nothing - , optCompilerMode = "defaultOptions" - } - --- | Option descriptions for getOpt -options :: [ OptDescr (Options -> IO Options) ] -options = - [ 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 "c" ["compilermode"] - (ReqArg - (\arg opt -> return opt { optCompilerMode = arg }) - "compilerMode") - "Changes compiler mode. Valid options are: unrollOptions, noSimplification, noPrimitiveInstructionHandling, c99Options" - - , Option "h" ["help"] - (NoArg - (\_ -> do - --prg <- getProgName - hPutStrLn stderr (usageInfo header options) - exitWith ExitSuccess)) - "Show this help message" - ] - -header = "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" - -- | Calculates the output file name. convertOutputFileName :: String -> Maybe String -> String convertOutputFileName inputFileName maybeOutputFileName = case maybeOutputFileName of @@ -212,37 +161,33 @@ args <- getArgs when (length args == 0) (do - putStrLn $ usageInfo header options + putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors exitWith ExitSuccess) -- Parse options, getting a list of option actions - let (actions, nonOptions, errors) = getOpt Permute options args + let (actions, nonOptions, errors) = getOpt Permute StandaloneOptions.optionDescriptors args when (length errors > 0) (do putStrLn $ concat errors - putStrLn $ usageInfo header options + putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors exitWith (ExitFailure 1)) -- Here we thread startOptions through all supplied option actions - opts <- foldl (>>=) (return startOptions) actions + opts <- foldl (>>=) (return StandaloneOptions.startOptions) actions when (length nonOptions /= 1) (do putStrLn "ERROR: Exactly one input file expected." exitWith (ExitFailure 1)) - let Options { optSingleFunction = functionMode - , optOutputFileName = maybeOutputFileName - , optDotGeneration = dotGeneration - , optDotFileName = dotFileName - , optCompilerMode = compilerMode } = opts + 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 - when (not $ compilerMode `elem` - ["defaultOptions", "unrollOptions", "noSimplification", "noPrimitiveInstructionHandling", "c99Options"]) (do - putStrLn $ "Invalid compiler mode \"" ++ compilerMode ++ "\"" - exitWith (ExitFailure 1)) - compilationCore functionMode inputFileName outputFileName opts dotGeneration dotFileName compilerMode compilationCore functionMode inputFileName outputFileName commandLineOptions dotGeneration dotFileName compilerMode = do @@ -263,28 +208,29 @@ -- Dot generation case commandLineOptions of - Options { optDotGeneration = True} -> do + StandaloneOptions.Options { StandaloneOptions.optDotGeneration = True} -> do putStrLn "Dot generation enabled" case functionMode of - SingleFunction funName -> case dotFileName of + StandaloneOptions.SingleFunction funName -> case dotFileName of Just fileName -> highLevelInterpreterWithModuleInfo (generalInterpreterBody $ "writeDot \"" ++ fileName ++ "\" " ++ funName) Nothing -> highLevelInterpreterWithModuleInfo (generalInterpreterBody $ "putStr $ fs2dot " ++ funName) - MultiFunction -> putStrLn $ "ERROR: Dot generation requested, but not supported in multi-function mode\n"++ + 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 - MultiFunction + 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) - SingleFunction funName -> do + StandaloneOptions.SingleFunction funName -> do putStrLn $ "Single-function mode, compiling function " ++ funName ++ "..." let originalFeldsparFunctionSignatureNeeded = case filter ((==funName).originalFeldsparFunctionName) declarationList of [a] -> a @@ -293,8 +239,4 @@ highLevelInterpreterWithModuleInfo (singleFunctionCompilationBody inputFileName outputFileName compilerMode originalFeldsparFunctionSignatureNeeded) -iPutStrLn :: String -> Interpreter () -iPutStrLn = liftIO . putStrLn -iPutStr :: String -> Interpreter () -iPutStr = liftIO . putStr 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,30 @@ -{- - - 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. - -} +-- +-- 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 diff --git a/Feldspar/Compiler/Imperative/CodeGeneration.hs b/Feldspar/Compiler/Imperative/CodeGeneration.hs --- a/Feldspar/Compiler/Imperative/CodeGeneration.hs +++ b/Feldspar/Compiler/Imperative/CodeGeneration.hs @@ -1,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 #-} @@ -37,8 +33,10 @@ import Feldspar.Compiler.Imperative.Representation import Feldspar.Compiler.Imperative.Semantics import Feldspar.Compiler.Error -import qualified Data.List as List (last) +import Feldspar.Compiler.Options +import qualified Data.List as List (last,find) + ------------------------ -- C code generation -- ------------------------ @@ -63,46 +61,36 @@ --input of fun deriving (Eq,Show) -compToC :: ToC a => a -> String -compToC = toC Declaration_pl +compToC :: ToC a => Platform -> a -> String +compToC m = toC m Declaration_pl class ToC a where - toC :: Place -> a -> String - -instance ToC Size where - toC _ S8 = "char" - toC _ S16 = "short" - toC _ S32 = "int" - toC _ S64 = "long long" - -instance ToC Signedness where - toC _ ImpSigned = "signed" - toC _ ImpUnsigned = "unsigned" + toC :: Platform -> Place -> a -> String instance ToC Type where - toC _ BoolType = "int" - toC _ FloatType = "float" - toC p (Numeric s t) = listprint id " " [toC p s, toC p t] + 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 p a@(Variable (VariableData r t n) _) = show_variable r p t n NoRestrict + toC m p a@(Variable r t n _) = show_variable m p r t n NoRestrict -show_variable :: VariableRole -> Place -> Type -> String -> IsRestrict -> String -show_variable r p t n restr = listprint (id) " " [variableType, show_name r p t n ++ arrLn] --concat [addSpace $ variableType, show_name r p t n, arrLn] +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 p t,"") - show_type MainParameter_pl t _ = (toC p t,"") + 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 Declaration_pl t) ++ " * const restrict", "") - decl_arr_type_0 t s _ = ((toC Declaration_pl t) ++ " *", "") + 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", ")") @@ -110,7 +98,7 @@ 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 Declaration_pl t) ++ 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" @@ -128,7 +116,8 @@ | place == AddressNeed_pl = "&" ++ n | otherwise = n show_name FunOut place t n - | place == AddressNeed_pl = 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 @@ -139,105 +128,120 @@ genIndex _ = "" instance ToC (Constant PrettyPrintSemanticInfo) where - toC _ (IntConstant i) = show (intConstantValue i) - toC _ (FloatConstant i) = show (floatConstantValue i) ++ "f" - toC _ (BoolConstant (BoolConstantType True _)) = "1" - toC _ (BoolConstant (BoolConstantType False _)) = "0" - toC p a@(ArrayConstant l) = "{" ++ (toCArray p a) ++ "}" + toC m p c = toC m p $ constantData c -toCArray :: Place -> Constant PrettyPrintSemanticInfo -> String -toCArray p (ArrayConstant l) = listprint (toCArray p) "," (arrayConstantValue l) -toCArray p i = toC p i +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 p (VariableLeftValue (VariableInLeftValue v _)) = toC p v - toC p (ArrayElemReferenceLeftValue leftArrayElemReference) = toC p $ insertIndex (arrayName $ arrayElemReferenceData leftArrayElemReference) 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 (VariableLeftValue (VariableInLeftValue variable semInf)) = VariableLeftValue $ VariableInLeftValue - (variable { - variableData = (variableData variable) { - variableType = decrArrayDepth (variableType $ variableData variable), - variableName = (concat[variableName $ variableData variable,"[", - toC ValueNeed_pl (arrayIndex $ arrayElemReferenceData leftArrayElemReference), "]"]) - } + insertIndex (LeftValue (VariableLeftValue variable) semInf) = LeftValue (VariableLeftValue $ + variable { + variableType = decrArrayDepth (variableType variable), + variableName = (concat[variableName variable,"[", + toC m ValueNeed_pl (arrayIndex leftArrayElemReference), "]"]) }) semInf - insertIndex (ArrayElemReferenceLeftValue leftArrayElemReference) = + insertIndex (LeftValue (ArrayElemReferenceLeftValue leftArrayElemReference) semInf) = LeftValue ( ArrayElemReferenceLeftValue $ leftArrayElemReference { - arrayElemReferenceData = ArrayElemReferenceData (insertIndex (arrayName $ arrayElemReferenceData leftArrayElemReference)) - (arrayIndex $ arrayElemReferenceData leftArrayElemReference) - } - + arrayName = (insertIndex (arrayName leftArrayElemReference)), + arrayIndex = (arrayIndex leftArrayElemReference) + }) semInf instance ToC (ActualParameter PrettyPrintSemanticInfo) where - toC p (InputActualParameter (InputActualParameterType e _)) = toC FunctionCallIn_pl e - toC p (OutputActualParameter (OutputActualParameterType l _)) = toC AddressNeed_pl l + 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 p (LeftValueExpression (LeftValueInExpression lv _)) = toC p lv - toC p (ConstantExpression c) = toC p c - toC p (FunctionCallExpression (FunctionCall (FunctionCallData InfixOp _ f [a,b]) _)) = concat["(",toC p a," ",f," ",toC p b,")"] - toC p (FunctionCallExpression (FunctionCall (FunctionCallData _ t f x) _)) = concat [f,"(",listprint (toC p) ", " x,")"] + 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 p (Procedure n il ol pr semInf) = concat ["void ",n,"(",param,")\n{\n",prog,"}\n"] + toC m p (Procedure n il ol pr semInf) = concat ["void ",n,"(",param,")\n{\n",prog,"}\n"] where - param = listprint (toC MainParameter_pl) ", " (il ++ ol) - prog = ind (toC Declaration_pl) pr + param = listprint (toC m MainParameter_pl) ", " (il ++ ol) + prog = ind (toC m Declaration_pl) pr instance ToC (Block PrettyPrintSemanticInfo) where - toC p (Block (BlockData d pr) semInf) = listprint id "\n" [decl,toC p pr] + toC m p (Block d pr semInf) = listprint id "\n" [decl,toC m p pr] where - decl = concat $ map (\a->toC Declaration_pl a ++ ";\n") d + decl = concat $ map (\a->toC m Declaration_pl a ++ ";\n") d instance ToC (FormalParameter PrettyPrintSemanticInfo) where - toC p (FormalParameter v restr) = (helper p v restr) + toC m p (FormalParameter v restr) = (helper p v restr) where helper :: Place -> Variable PrettyPrintSemanticInfo -> IsRestrict -> String - helper MainParameter_pl (Variable (VariableData r t n) _) restr - = show_variable r MainParameter_pl t n restr - helper _ (Variable (VariableData r t n) _) restr - = show_variable r Declaration_pl t n restr + 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 p (LocalDeclaration (LocalDeclarationData v i) isDefArrSize) = (helper p v i) + 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 MainParameter_pl v,init i] - helper _ v i = concat [toC Declaration_pl v,init i] + 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 ValueNeed_pl e + init (Just e) = " = " ++ toC m ValueNeed_pl e instance ToC (Instruction PrettyPrintSemanticInfo) where - toC p (AssignmentInstruction assignment) = - concat [toC ValueNeed_pl (assignmentLhs $ assignmentData assignment)," = ",toC ValueNeed_pl (assignmentRhs $ assignmentData assignment),";\n"] - toC p (ProcedureCallInstruction procedureCall) = - concat [nameOfProcedureToCall $ procedureCallData procedureCall,"(", - listprint (toC p) ", " (actualParametersOfProcedureToCall $ procedureCallData procedureCall),");\n"] - -- TODO ProcedureCall.actualParameters procedureCall -----> External helper functions !!! - + 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 p (Program (EmptyProgram (Empty i)) seminf) = "" - toC p (Program (PrimitiveProgram (Primitive i seminf)) psi) = toC p i - toC p (Program (SequenceProgram (Sequence ps _)) psi) = listprint (toC p) "" ps - toC p (Program (BranchProgram (Branch (BranchData con tPrg ePrg) _)) psi) - = concat ["if(",toC ValueNeed_pl con,")\n{\n", ind (toC p) tPrg,"}\nelse\n{\n",ind (toC p) ePrg,"}\n"] - toC p (Program (SequentialLoopProgram (SequentialLoop (SequentialLoopData condVar condCalc loopBody) _)) psi) = concat["{\n",ind id whereBody,"}\n"] + 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 p condCalc,"while(",toC ValueNeed_pl condVar,")\n", - "{\n",ind (toC p) loopBody,ind (toC p) (blockInstructions $ blockData condCalc),"}\n"] - toC p (Program (ParallelLoopProgram (ParallelLoop (ParallelLoopData v num step prg) _)) psi) = concat ["{\n",ind id for_seq,"}\n"] + 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 Declaration_pl v,";\nfor(",for_init,for_test,for_inc,")\n{\n",ind (toC p) prg,"}\n"] - for_init = concat [toC ValueNeed_pl v," = 0; "] - for_test = concat [toC ValueNeed_pl v," < ",toC ValueNeed_pl num,"; "] - for_inc = concat [toC ValueNeed_pl v," += ",show step] + 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 p (Just a) = toC p a + toC _ p Nothing = "" + toC m p (Just a) = toC m p a instance (ToC a) => ToC [a] where - toC p xs = listprint (toC p) "\n" xs + toC m p xs = listprint (toC m p) "\n" xs ---------------------- -- Type -- @@ -247,14 +251,20 @@ typeof :: a -> Type instance (SemanticInfo t) => HasType (Variable t) where - typeof (Variable (VariableData r t s) _) = t + typeof (Variable r t s _) = t instance (SemanticInfo t) => HasType (LeftValue t) where - typeof (VariableLeftValue (VariableInLeftValue v _)) = typeof v + typeof lv = typeof $ leftValueData lv + +instance (SemanticInfo t) => HasType (LeftValueData t) where + typeof (VariableLeftValue v) = typeof v typeof (ArrayElemReferenceLeftValue arrayElemReference) = - decrArrayDepth (typeof (arrayName $ arrayElemReferenceData 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 @@ -271,14 +281,20 @@ | otherwise = codeGenerationError InternalError $ "Different element types in constant array: " ++ show arr instance (SemanticInfo t) => HasType (Expression t) where - typeof (LeftValueExpression lve) = typeof $ leftValueExpressionContents lve + 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 $ functionCallData functionCallExpression + typeof (FunctionCallExpression functionCallExpression) = typeOfFunctionToCall functionCallExpression instance (SemanticInfo t) => HasType (ActualParameter t) where - typeof (InputActualParameter (InputActualParameterType e _)) = typeof e - typeof (OutputActualParameter (OutputActualParameterType l _)) = typeof l + typeof ap = typeof $ actualParameterData ap +instance (SemanticInfo t) => HasType (ActualParameterData t) where + typeof (InputActualParameter e) = typeof e + typeof (OutputActualParameter l) = typeof l + ---------------------- -- Helper functions -- ---------------------- @@ -293,9 +309,8 @@ listprint' s (x:y:xs) = x ++ s ++ listprint' s (y:xs) parameterToExpression :: (SemanticInfo t) => ActualParameter t -> Expression t -parameterToExpression (InputActualParameter (InputActualParameterType e _)) = e -parameterToExpression (OutputActualParameter (OutputActualParameterType lv _)) = - LeftValueExpression $ LeftValueInExpression lv undefined -- TODO undefined +parameterToExpression (ActualParameter (InputActualParameter e) _) = e +parameterToExpression (ActualParameter (OutputActualParameter lv) _) = Expression (LeftValueExpression lv) undefined -- TODO undefined decrArrayDepth :: Type -> Type decrArrayDepth (ImpArrayType _ t) = t @@ -306,22 +321,21 @@ simpleType (Numeric _ _) = True simpleType FloatType = True simpleType (ImpArrayType _ _) = False +simpleType (UserType _) = True toLeftValue :: (SemanticInfo t) => Expression t -> LeftValue t -toLeftValue (LeftValueExpression (LeftValueInExpression lv _)) = lv +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 (LeftValueExpression (LeftValueInExpression lv _)) = contains' n lv where - contains' n (VariableLeftValue - (VariableInLeftValue (Variable (VariableData _ _ n' ) _) _) - ) = n == n' - contains' n (ArrayElemReferenceLeftValue arrayElemReference) = contains' n (arrayName $ arrayElemReferenceData arrayElemReference) || - contains n (arrayIndex $ arrayElemReferenceData arrayElemReference) -contains _ (ConstantExpression _) = False -contains n (FunctionCallExpression functionCallExpression) = - any (contains n) (actualParametersOfFunctionToCall $ functionCallData functionCallExpression) +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 (VariableLeftValue (VariableInLeftValue ( Variable (VariableData _ _ n) _ ) _ )) = n -getVarName (ArrayElemReferenceLeftValue arrayElemReference) = getVarName (arrayName $ arrayElemReferenceData arrayElemReference) +getVarName (LeftValue (VariableLeftValue ( Variable _ _ n _ )) _) = n +getVarName (LeftValue (ArrayElemReferenceLeftValue arrayElemReference) _) = getVarName (arrayName arrayElemReference) 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,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 #-} @@ -36,259 +32,203 @@ import Feldspar.Compiler.Imperative.Semantics --- =========================================================================== --- == Representation of imperative programs --- =========================================================================== - --- ========================= [ Procedure ] =================================== - +-- ==================================================================================================== +-- == 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) - --- ========================= [ Block ] ======================================= + procedureName :: String, + inParameters :: [FormalParameter t], + outParameters :: [FormalParameter t], + procedureBody :: Block t, + procedureSemInf :: ProcedureInfo t +} deriving (Eq, Show) data (SemanticInfo t) => Block t = Block { - blockData :: BlockData t, - blockSemInf :: BlockInfo t -} deriving (Eq,Show) - -data (SemanticInfo t) => BlockData t = BlockData { - blockDeclarations :: [LocalDeclaration t], - blockInstructions :: Program t -} deriving (Eq,Show) - --- ========================= [ Program ] ===================================== + blockDeclarations :: [LocalDeclaration t], + blockInstructions :: Program t, + blockSemInf :: BlockInfo t +} deriving (Eq, Show) data (SemanticInfo t) => Program t = Program { - programConstruction :: ProgramConstruction t, - programSemInf :: ProgramInfo t -} deriving (Eq,Show) + programConstruction :: ProgramConstruction t, + programSemInf :: ProgramInfo t +} deriving (Eq, Show) -data (SemanticInfo t) => ProgramConstruction t = +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) + deriving (Eq, Show) data (SemanticInfo t) => Empty t = Empty { - emptySemInf :: EmptyInfo t -} deriving (Eq,Show) - + emptySemInf :: EmptyInfo t +} deriving (Eq, Show) + data (SemanticInfo t) => Primitive t = Primitive { - primitiveInstruction :: Instruction t, - primitiveSemInf :: PrimitiveInfo t -} deriving (Eq,Show) + primitiveInstruction :: Instruction t, + primitiveSemInf :: PrimitiveInfo t +} deriving (Eq, Show) data (SemanticInfo t) => Sequence t = Sequence { - sequenceProgramList :: [Program t], - sequenceSemInf :: SequenceInfo t -} deriving (Eq,Show) + sequenceProgramList :: [Program t], + sequenceSemInf :: SequenceInfo t +} deriving (Eq, Show) data (SemanticInfo t) => Branch t = Branch { - branchData :: BranchData t, - branchSemInf :: BranchInfo t -} deriving (Eq,Show) - -data (SemanticInfo t) => BranchData t = BranchData { - branchConditionVariable :: Variable t, -- ??? - thenBlock :: Block t, - elseBlock :: Block t + branchConditionVariable :: Variable t, + thenBlock :: Block t, + elseBlock :: Block t, + branchSemInf :: BranchInfo t } deriving (Eq, Show) data (SemanticInfo t) => SequentialLoop t = SequentialLoop { - sequentialLoopData :: SequentialLoopData t, - sequentialLoopSemInf :: SequentialLoopInfo t -} deriving (Eq,Show) - -data (SemanticInfo t) => SequentialLoopData t = SequentialLoopData { - sequentialLoopCondition :: Expression t, - conditionCalculation :: Block t, -- ??? - sequentialLoopCore :: Block t + sequentialLoopCondition :: Expression t, + conditionCalculation :: Block t, + sequentialLoopCore :: Block t, + sequentialLoopSemInf :: SequentialLoopInfo t } deriving (Eq, Show) data (SemanticInfo t) => ParallelLoop t = ParallelLoop { - parallelLoopData :: ParallelLoopData t, - parallelLoopSemInf :: ParallelLoopInfo t -} deriving (Eq,Show) - -data (SemanticInfo t) => ParallelLoopData t = ParallelLoopData { - parallelLoopConditionVariable :: Variable t, - numberOfIterations :: Expression t, -- ??? - parallelLoopStep :: Int, -- ??? - parallelLoopCore :: Block t + parallelLoopConditionVariable :: Variable t, + numberOfIterations :: Expression t, + parallelLoopStep :: Int, + parallelLoopCore :: Block t, + parallelLoopSemInf :: ParallelLoopInfo t } deriving (Eq, Show) --- ========================= [ FormalParameter ] ============================= - data (SemanticInfo t) => FormalParameter t = FormalParameter { - formalParameterVariable :: Variable t, - formalParameterSemInf :: FormalParameterInfo t -} deriving (Eq,Show) - --- ========================= [ LocalDeclaration ] ============================ + formalParameterVariable :: Variable t, + formalParameterSemInf :: FormalParameterInfo t +} deriving (Eq, Show) data (SemanticInfo t) => LocalDeclaration t = LocalDeclaration { - localDeclarationData :: LocalDeclarationData t, - localDeclarationSemInf :: LocalDeclarationInfo t -} deriving (Eq,Show) - -data (SemanticInfo t) => LocalDeclarationData t = LocalDeclarationData { - localVariable :: Variable t, - localInitValue :: Maybe (Expression t) -} deriving (Eq,Show) + localVariable :: Variable t, + localInitValue :: Maybe (Expression t), + localDeclarationSemInf :: LocalDeclarationInfo t +} deriving (Eq, Show) --- ========================= [ Expression ] ================================== +data (SemanticInfo t) => Expression t = Expression { + expressionData :: ExpressionData t, + expressionSemInf :: ExpressionInfo t +} deriving (Eq, Show) -data (SemanticInfo t) => Expression t = - LeftValueExpression (LeftValueInExpression t) +data (SemanticInfo t) => ExpressionData t = + LeftValueExpression (LeftValue t) | ConstantExpression (Constant t) | FunctionCallExpression (FunctionCall t) deriving (Eq, Show) -data (SemanticInfo t) => LeftValueInExpression t = LeftValueInExpression { - leftValueExpressionContents :: LeftValue t, - leftValueExpressionSemInf :: LeftValueExpressionInfo t +data (SemanticInfo t) => Constant t = Constant { + constantData :: ConstantData t, + constantSemInf :: ConstantInfo t } deriving (Eq, Show) data (SemanticInfo t) => FunctionCall t = FunctionCall { - functionCallData :: FunctionCallData t, - functionCallSemInf :: FunctionCallInfo t + roleOfFunctionToCall :: FunctionRole, + typeOfFunctionToCall :: Type, + nameOfFunctionToCall :: String, + actualParametersOfFunctionToCall :: [Expression t], + functionCallSemInf :: FunctionCallInfo t } deriving (Eq, Show) -data (SemanticInfo t) => FunctionCallData t = FunctionCallData { - roleOfFunctionToCall :: FunctionRole, - typeOfFunctionToCall :: Type, - nameOfFunctionToCall :: String, - actualParametersOfFunctionToCall :: [Expression t] -} deriving (Eq,Show) - --- ========================= [ LeftValue ] =================================== +data (SemanticInfo t) => LeftValue t = LeftValue { + leftValueData :: LeftValueData t, + leftValueSemInf :: LeftValueInfo t +} deriving (Eq, Show) -data (SemanticInfo t) => LeftValue t = - VariableLeftValue (VariableInLeftValue t) +data (SemanticInfo t) => LeftValueData t = + VariableLeftValue (Variable t) | ArrayElemReferenceLeftValue (ArrayElemReference t) - deriving (Eq,Show) - -data (SemanticInfo t) => VariableInLeftValue t = VariableInLeftValue { - variableLeftValueContents :: Variable t, - variableLeftValueSemInf :: VariableInLeftValueInfo t -} deriving (Eq,Show) + deriving (Eq, Show) data (SemanticInfo t) => ArrayElemReference t = ArrayElemReference { - arrayElemReferenceData :: ArrayElemReferenceData t, - arrayElemReferenceSemInf :: ArrayElemReferenceInfo t -} deriving (Eq,Show) - -data (SemanticInfo t) => ArrayElemReferenceData t = ArrayElemReferenceData { - arrayName :: LeftValue t, - arrayIndex :: Expression t -} deriving (Eq,Show) + arrayName :: LeftValue t, + arrayIndex :: Expression t, + arrayElemReferenceSemInf :: ArrayElemReferenceInfo t +} deriving (Eq, Show) --- ========================= [ Instruction ] ================================= +data (SemanticInfo t) => Instruction t = Instruction { + instructionData :: InstructionData t, + instructionSemInf :: InstructionInfo t +} deriving (Eq, Show) -data (SemanticInfo t) => Instruction t = +data (SemanticInfo t) => InstructionData t = AssignmentInstruction (Assignment t) | ProcedureCallInstruction (ProcedureCall t) - deriving (Eq,Show) + deriving (Eq, Show) data (SemanticInfo t) => Assignment t = Assignment { - assignmentData :: AssignmentData t, - assignmentSemInf :: AssignmentInfo t -} deriving (Eq,Show) - -data (SemanticInfo t) => AssignmentData t = AssignmentData { - assignmentLhs :: LeftValue t, - assignmentRhs :: Expression t -} deriving (Eq,Show) + assignmentLhs :: LeftValue t, + assignmentRhs :: Expression t, + assignmentSemInf :: AssignmentInfo t +} deriving (Eq, Show) data (SemanticInfo t) => ProcedureCall t = ProcedureCall { - procedureCallData :: ProcedureCallData t, - procedureCallSemInf :: ProcedureCallInfo t -} deriving (Eq,Show) - -data (SemanticInfo t) => ProcedureCallData t = ProcedureCallData { - nameOfProcedureToCall :: String, - actualParametersOfProcedureToCall :: [ActualParameter t] -} deriving (Eq,Show) - --- ========================= [ ActualParameter ] ============================= - -data (SemanticInfo t) => ActualParameter t = - InputActualParameter (InputActualParameterType t) - | OutputActualParameter (OutputActualParameterType t) - deriving (Eq,Show) + nameOfProcedureToCall :: String, + actualParametersOfProcedureToCall :: [ActualParameter t], + procedureCallSemInf :: ProcedureCallInfo t +} deriving (Eq, Show) -data (SemanticInfo t) => InputActualParameterType t = InputActualParameterType { - inputActualParameterExpression :: Expression t, - inputActualParameterSemInf :: InputActualParameterInfo t -} deriving (Eq,Show) +data (SemanticInfo t) => ActualParameter t = ActualParameter { + actualParameterData :: ActualParameterData t, + actualParameterSemInf :: ActualParameterInfo t +} deriving (Eq, Show) -data (SemanticInfo t) => OutputActualParameterType t = OutputActualParameterType { - outputActualParameterLeftValue :: LeftValue t, - outputActualParameterSemInf :: OutputActualParameterInfo t -} deriving (Eq,Show) +data (SemanticInfo t) => ActualParameterData t = + InputActualParameter (Expression t) + | OutputActualParameter (LeftValue t) + deriving (Eq, Show) --- ========================= [ Constant ] ==================================== +data (SemanticInfo t) => ConstantData t = + IntConstant (IntConstantType t) + | FloatConstant (FloatConstantType t) + | BoolConstant (BoolConstantType t) + | ArrayConstant (ArrayConstantType t) + deriving (Eq, Show) -data Constant t = IntConstant (IntConstantType t) - | FloatConstant (FloatConstantType t) - | BoolConstant (BoolConstantType t) - | ArrayConstant (ArrayConstantType t) - deriving (Eq,Show) - data (SemanticInfo t) => IntConstantType t = IntConstantType { - intConstantValue :: Int, - intConstantSemInf :: IntConstantInfo t + intConstantValue :: Int, + intConstantSemInf :: IntConstantInfo t } deriving (Eq, Show) data (SemanticInfo t) => FloatConstantType t = FloatConstantType { - floatConstantValue :: Float, - floatConstantSemInf :: FloatConstantInfo t + floatConstantValue :: Float, + floatConstantSemInf :: FloatConstantInfo t } deriving (Eq, Show) data (SemanticInfo t) => BoolConstantType t = BoolConstantType { - boolConstantValue :: Bool, - boolConstantSemInf :: BoolConstantInfo t + boolConstantValue :: Bool, + boolConstantSemInf :: BoolConstantInfo t } deriving (Eq, Show) data (SemanticInfo t) => ArrayConstantType t = ArrayConstantType { - arrayConstantValue :: [Constant t], - arrayConstantSemInf :: ArrayConstantInfo t + arrayConstantValue :: [Constant t], + arrayConstantSemInf :: ArrayConstantInfo t } deriving (Eq, Show) --- ========================= [ Variable ] ==================================== - data (SemanticInfo t) => Variable t = Variable { - variableData :: VariableData, - variableSemInf :: VariableInfo t -} deriving (Eq,Show) + variableRole :: VariableRole, + variableType :: Type, + variableName :: String, + variableSemInf :: VariableInfo t +} deriving (Eq, Show) -data VariableData = VariableData { - variableRole :: VariableRole, - variableType :: Type, - variableName :: String -} deriving (Eq,Show) -- ========================= [ Basic structures ] ============================ data Length = Norm Int | Defined Int | Undefined deriving (Eq,Show) -data Size = S8 | S16 | S32 | S64 +data Size = S8 | S16 | S32 | S40 | S64 deriving (Eq,Show) data Signedness = ImpSigned | ImpUnsigned deriving (Eq,Show) -data Type = BoolType | FloatType | Numeric Signedness Size | ImpArrayType Length Type +data Type = BoolType | FloatType | Numeric Signedness Size | ImpArrayType Length Type | UserType String deriving (Eq,Show) data FunctionRole = SimpleFun | InfixOp | PrefixOp diff --git a/Feldspar/Compiler/Imperative/Semantics.hs b/Feldspar/Compiler/Imperative/Semantics.hs --- a/Feldspar/Compiler/Imperative/Semantics.hs +++ b/Feldspar/Compiler/Imperative/Semantics.hs @@ -1,73 +1,73 @@ -{- - - 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. - -} +-- +-- 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 --- =========================================================================== --- == Semantic info class --- =========================================================================== +data InitSemInf +data PrettyPrintSemanticInfo -class (Show (ProcedureInfo t), - Show (BlockInfo t), - Show (ProgramInfo t), - Show (EmptyInfo t), Show (PrimitiveInfo t), Show (SequenceInfo t), Show (BranchInfo t), Show (SequentialLoopInfo t), Show (ParallelLoopInfo t), - Show (FormalParameterInfo t), - Show (LocalDeclarationInfo t), - Show (FunctionCallInfo t), - Show (LeftValueExpressionInfo t), - Show (VariableInLeftValueInfo t), - Show (ArrayElemReferenceInfo t), - Show (InputActualParameterInfo t), Show (OutputActualParameterInfo t), - Show (AssignmentInfo t), - Show (ProcedureCallInfo t), - Show (IntConstantInfo t), Show (FloatConstantInfo t), Show (BoolConstantInfo t), Show (ArrayConstantInfo t), - Show (VariableInfo t), - Eq (ProcedureInfo t), - Eq (BlockInfo t), - Eq (ProgramInfo t), - Eq (EmptyInfo t), Eq (PrimitiveInfo t), Eq (SequenceInfo t), Eq (BranchInfo t), Eq (SequentialLoopInfo t), Eq (ParallelLoopInfo t), - Eq (FormalParameterInfo t), - Eq (LocalDeclarationInfo t), - Eq (FunctionCallInfo t), - Eq (LeftValueExpressionInfo t), - Eq (VariableInLeftValueInfo t), - Eq (ArrayElemReferenceInfo t), - Eq (InputActualParameterInfo t), Eq (OutputActualParameterInfo t), - Eq (AssignmentInfo t), - Eq (ProcedureCallInfo t), - Eq (IntConstantInfo t), Eq (FloatConstantInfo t), Eq (BoolConstantInfo t), Eq (ArrayConstantInfo t), - Eq (VariableInfo t)) - => SemanticInfo t where +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 @@ -79,117 +79,99 @@ type ParallelLoopInfo t type FormalParameterInfo t type LocalDeclarationInfo t - type LeftValueExpressionInfo t - type VariableInLeftValueInfo t + type ExpressionInfo t + type ConstantInfo t + type FunctionCallInfo t + type LeftValueInfo t type ArrayElemReferenceInfo t - type InputActualParameterInfo t - type OutputActualParameterInfo t + type InstructionInfo t type AssignmentInfo t type ProcedureCallInfo t - type FunctionCallInfo t + type ActualParameterInfo t type IntConstantInfo t type FloatConstantInfo t type BoolConstantInfo t type ArrayConstantInfo t type VariableInfo t - --- =========================================================================== --- == Unit semantic info instance --- =========================================================================== - + 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 LeftValueExpressionInfo () = () - type VariableInLeftValueInfo () = () - type ArrayElemReferenceInfo () = () - type InputActualParameterInfo () = () - type OutputActualParameterInfo () = () - type AssignmentInfo () = () - type ProcedureCallInfo () = () - type FunctionCallInfo () = () - type IntConstantInfo () = () - type FloatConstantInfo () = () - type BoolConstantInfo () = () - type ArrayConstantInfo () = () - type VariableInfo () = () - --- =========================================================================== --- == Basic semantic info instance --- =========================================================================== - -data InitSemInf + 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 LeftValueExpressionInfo InitSemInf = () - type VariableInLeftValueInfo InitSemInf = () - type ArrayElemReferenceInfo InitSemInf = () - type InputActualParameterInfo InitSemInf = () - type OutputActualParameterInfo InitSemInf = () - type AssignmentInfo InitSemInf = () - type ProcedureCallInfo InitSemInf = () - type FunctionCallInfo InitSemInf = () - type IntConstantInfo InitSemInf = () - type FloatConstantInfo InitSemInf = () - type BoolConstantInfo InitSemInf = () - type ArrayConstantInfo InitSemInf = () - type VariableInfo InitSemInf = () - --- =========================================================================== --- == PrettyPrint semantic info instance --- =========================================================================== - - -data IsRestrict = Restrict | NoRestrict - deriving (Show,Eq) - -data IsDefaultArraySize = DefaultArraySize | NoDefaultArraySize - deriving (Show,Eq) - -data PrettyPrintSemanticInfo + 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 LeftValueExpressionInfo PrettyPrintSemanticInfo = () - type VariableInLeftValueInfo PrettyPrintSemanticInfo = () - type ArrayElemReferenceInfo PrettyPrintSemanticInfo = () - type InputActualParameterInfo PrettyPrintSemanticInfo = () - type OutputActualParameterInfo PrettyPrintSemanticInfo = () - type AssignmentInfo PrettyPrintSemanticInfo = () - type ProcedureCallInfo PrettyPrintSemanticInfo = () - type FunctionCallInfo PrettyPrintSemanticInfo = () - type IntConstantInfo PrettyPrintSemanticInfo = () - type FloatConstantInfo PrettyPrintSemanticInfo = () - type BoolConstantInfo PrettyPrintSemanticInfo = () - type ArrayConstantInfo PrettyPrintSemanticInfo = () - type VariableInfo PrettyPrintSemanticInfo = () + 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/Options.hs b/Feldspar/Compiler/Options.hs --- a/Feldspar/Compiler/Options.hs +++ b/Feldspar/Compiler/Options.hs @@ -1,46 +1,141 @@ -{- - - 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. - -} +-- +-- 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 Platform = AnsiC | C99 + data UnrollStrategy = NoUnroll | Unroll Int + deriving (Eq, Show) + + data DebugOption = NoDebug | NoSimplification | NoPrimitiveInstructionHandling - deriving Eq + 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Platforms.hs @@ -0,0 +1,223 @@ +-- +-- 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 --- a/Feldspar/Compiler/PluginArchitecture.hs +++ b/Feldspar/Compiler/PluginArchitecture.hs @@ -1,808 +1,1026 @@ -{- - - 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 - --- ================================================================================================================================== --- == 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 specification --- ================================================================================================================================== - - downwardsProcedure :: t -> Downwards t -> Procedure (From t) -> Downwards t - transformProcedure :: t -> Downwards t -> Procedure (From t) -> InfosFromProcedureParts t -> Procedure (To t) - upwardsProcedure :: t -> Downwards t -> Procedure (From t) -> InfosFromProcedureParts t -> Procedure (To t) -> Upwards t - - downwardsBlock :: t -> Downwards t -> Block (From t) -> Downwards t - transformBlock :: t -> Downwards t -> Block (From t) -> InfosFromBlockParts t -> Block (To t) - upwardsBlock :: t -> Downwards t -> Block (From t) -> InfosFromBlockParts t -> Block (To t) -> Upwards t - - downwardsProgram :: t -> Downwards t -> Program (From t) -> Downwards t - transformProgram :: t -> Downwards t -> Program (From t) -> InfosFromProgramParts t -> Program (To t) - upwardsProgram :: t -> Downwards t -> Program (From t) -> InfosFromProgramParts t -> Program (To t) -> Upwards t - - transformEmpty :: t -> Downwards t -> Empty (From t) -> ProgramConstruction (To t) - upwardsEmpty :: t -> Downwards t -> Empty (From t) -> ProgramConstruction (To t) -> Upwards t - - downwardsPrimitive :: t -> Downwards t -> Primitive (From t) -> Downwards t - transformPrimitive :: t -> Downwards t -> Primitive (From t) -> InfosFromPrimitiveParts t -> ProgramConstruction (To t) - upwardsPrimitive :: t -> Downwards t -> Primitive (From t) -> InfosFromPrimitiveParts t -> ProgramConstruction (To t) -> Upwards t - - downwardsSequence :: t -> Downwards t -> Sequence (From t) -> Downwards t - transformSequence :: t -> Downwards t -> Sequence (From t) -> InfosFromSequenceParts t -> ProgramConstruction (To t) - upwardsSequence :: t -> Downwards t -> Sequence (From t) -> InfosFromSequenceParts t -> ProgramConstruction (To t) -> Upwards t - - downwardsBranch :: t -> Downwards t -> Branch (From t) -> Downwards t - transformBranch :: t -> Downwards t -> Branch (From t) -> InfosFromBranchParts t -> ProgramConstruction (To t) - upwardsBranch :: t -> Downwards t -> Branch (From t) -> InfosFromBranchParts t -> ProgramConstruction (To t) -> Upwards t - - downwardsSequentialLoop :: t -> Downwards t -> SequentialLoop (From t) -> Downwards t - transformSequentialLoop :: t -> Downwards t -> SequentialLoop (From t) -> InfosFromSequentialLoopParts t -> ProgramConstruction (To t) - upwardsSequentialLoop :: t -> Downwards t -> SequentialLoop (From t) -> InfosFromSequentialLoopParts t -> ProgramConstruction (To t) -> Upwards t - - downwardsParallelLoop :: t -> Downwards t -> ParallelLoop (From t) -> Downwards t - transformParallelLoop :: t -> Downwards t -> ParallelLoop (From t) -> InfosFromParallelLoopParts t -> ProgramConstruction (To t) - upwardsParallelLoop :: t -> Downwards t -> ParallelLoop (From t) -> InfosFromParallelLoopParts t -> ProgramConstruction (To t) -> Upwards t - - downwardsFormalParameter :: t -> Downwards t -> FormalParameter (From t) -> Downwards t - transformFormalParameter :: t -> Downwards t -> FormalParameter (From t) -> InfosFromFormalParameterParts t -> FormalParameter (To t) - upwardsFormalParameter :: t -> Downwards t -> FormalParameter (From t) -> InfosFromFormalParameterParts t -> FormalParameter (To t) -> Upwards t - - downwardsLocalDeclaration :: t -> Downwards t -> LocalDeclaration (From t) -> Downwards t - transformLocalDeclaration :: t -> Downwards t -> LocalDeclaration (From t) -> InfosFromLocalDeclarationParts t -> LocalDeclaration (To t) - upwardsLocalDeclaration :: t -> Downwards t -> LocalDeclaration (From t) -> InfosFromLocalDeclarationParts t -> LocalDeclaration (To t) -> Upwards t - - downwardsAssignment :: t -> Downwards t -> Assignment (From t) -> Downwards t - transformAssignment :: t -> Downwards t -> Assignment (From t) -> InfosFromAssignmentParts t -> Instruction (To t) - upwardsAssignment :: t -> Downwards t -> Assignment (From t) -> InfosFromAssignmentParts t -> Instruction (To t) -> Upwards t - - downwardsProcedureCall :: t -> Downwards t -> ProcedureCall (From t) -> Downwards t - transformProcedureCall :: t -> Downwards t -> ProcedureCall (From t) -> InfosFromProcedureCallParts t -> Instruction (To t) - upwardsProcedureCall :: t -> Downwards t -> ProcedureCall (From t) -> InfosFromProcedureCallParts t -> Instruction (To t) -> Upwards t - - downwardsInputActualParameter :: t -> Downwards t -> InputActualParameterType (From t) -> Downwards t - transformInputActualParameter :: t -> Downwards t -> InputActualParameterType (From t) -> InfosFromInputActualParameterParts t -> ActualParameter (To t) - upwardsInputActualParameter :: t -> Downwards t -> InputActualParameterType (From t) -> InfosFromInputActualParameterParts t -> ActualParameter (To t) -> Upwards t - - downwardsOutputActualParameter :: t -> Downwards t -> OutputActualParameterType (From t) -> Downwards t - transformOutputActualParameter :: t -> Downwards t -> OutputActualParameterType (From t) -> InfosFromOutputActualParameterParts t -> ActualParameter (To t) - upwardsOutputActualParameter :: t -> Downwards t -> OutputActualParameterType (From t) -> InfosFromOutputActualParameterParts t -> ActualParameter (To t) -> Upwards t - - downwardsVariableInLeftValue :: t -> Downwards t -> VariableInLeftValue (From t) -> Downwards t - transformVariableInLeftValue :: t -> Downwards t -> VariableInLeftValue (From t) -> InfosFromVariableLeftValueParts t -> LeftValue (To t) - upwardsVariableInLeftValue :: t -> Downwards t -> VariableInLeftValue (From t) -> InfosFromVariableLeftValueParts t -> LeftValue (To t) -> Upwards t - - downwardsArrayElemReference :: t -> Downwards t -> ArrayElemReference (From t) -> Downwards t - transformArrayElemReference :: t -> Downwards t -> ArrayElemReference (From t) -> InfosFromArrayElemReferenceParts t -> LeftValue (To t) - upwardsArrayElemReference :: t -> Downwards t -> ArrayElemReference (From t) -> InfosFromArrayElemReferenceParts t -> LeftValue (To t) -> Upwards t - - downwardsLeftValueExpression :: t -> Downwards t -> LeftValueInExpression (From t) -> Downwards t - transformLeftValueExpression :: t -> Downwards t -> LeftValueInExpression (From t) -> InfosFromLeftValueExpressionParts t -> Expression (To t) - upwardsLeftValueExpression :: t -> Downwards t -> LeftValueInExpression (From t) -> InfosFromLeftValueExpressionParts t -> Expression (To t) -> Upwards t - - downwardsFunctionCall :: t -> Downwards t -> FunctionCall (From t) -> Downwards t - transformFunctionCall :: t -> Downwards t -> FunctionCall (From t) -> InfosFromFunctionCallParts t -> Expression (To t) - upwardsFunctionCall :: t -> Downwards t -> FunctionCall (From t) -> InfosFromFunctionCallParts t -> Expression (To t) -> Upwards t - - transformIntConstant :: t -> Downwards t -> IntConstantType (From t) -> Constant (To t) - upwardsIntConstant :: t -> Downwards t -> IntConstantType (From t) -> Constant (To t) -> Upwards t - - transformFloatConstant :: t -> Downwards t -> FloatConstantType (From t) -> Constant (To t) - upwardsFloatConstant :: t -> Downwards t -> FloatConstantType (From t) -> Constant (To t) -> Upwards t - - transformBoolConstant :: t -> Downwards t -> BoolConstantType (From t) -> Constant (To t) - upwardsBoolConstant :: t -> Downwards t -> BoolConstantType (From t) -> Constant (To t) -> Upwards t - - downwardsArrayConstant :: t -> Downwards t -> ArrayConstantType (From t) -> Downwards t - transformArrayConstant :: t -> Downwards t -> ArrayConstantType (From t) -> InfosFromArrayConstantParts t -> Constant (To t) - upwardsArrayConstant :: t -> Downwards t -> ArrayConstantType (From t) -> InfosFromArrayConstantParts t -> Constant (To t) -> Upwards t - - transformVariable :: t -> Downwards t -> Variable (From t) -> Variable (To t) - upwardsVariable :: t -> Downwards t -> Variable (From t) -> Variable (To t) -> Upwards t - --- ================================================================================================================================== --- == Node Transformer defaults --- ================================================================================================================================== - - downwardsProcedure self = const - transformProcedure self fromAbove originalProcedure fromBelow = originalProcedure { - inParameters = recursivelyTransformedInParameters fromBelow, - outParameters = recursivelyTransformedOutParameters fromBelow, - procedureBody = recursivelyTransformedProcedureBody fromBelow, - procedureSemInf = convert $ procedureSemInf originalProcedure - } - upwardsProcedure self fromAbove originalProcedure fromBelow transformedProcedure = foldl combine (upwardsInfoFromProcedureBody fromBelow) - ((upwardsInfoFromInParameters fromBelow)++(upwardsInfoFromOutParameters fromBelow)) - - downwardsBlock self = const - transformBlock self fromAbove originalBlock fromBelow = Block { - blockData = recursivelyTransformedBlockData fromBelow, - blockSemInf = convert $ blockSemInf originalBlock - } - upwardsBlock self fromAbove originalBlock fromBelow transformedBlock = foldl combine - (upwardsInfoFromBlockInstructions fromBelow) (upwardsInfoFromBlockDeclarations fromBelow) - - downwardsProgram self = const - transformProgram self fromAbove originalProgram fromBelow = Program { - programConstruction = recursivelyTransformedProgramConstruction fromBelow, - programSemInf = convert $ programSemInf originalProgram - } - upwardsProgram self fromAbove originalProgram fromBelow transformedProgram = upwardsInfoFromProgramConstruction fromBelow - - transformEmpty self fromAbove originalEmpty = EmptyProgram $ Empty { - emptySemInf = convert $ emptySemInf originalEmpty - } - upwardsEmpty self fromAbove originalEmpty transformedEmpty = defaultValue - - downwardsPrimitive self = const - transformPrimitive self fromAbove originalPrimitive fromBelow = PrimitiveProgram $ Primitive { - primitiveInstruction = recursivelyTransformedPrimitiveInstruction fromBelow, - primitiveSemInf = convert $ primitiveSemInf originalPrimitive - } - upwardsPrimitive self fromAbove originalPrimitive fromBelow transformedPrimitive = upwardsInfoFromPrimitiveInstruction fromBelow - - downwardsSequence self = const - transformSequence self fromAbove originalSequence fromBelow = SequenceProgram $ Sequence { - sequenceProgramList = recursivelyTransformedSequenceProgramList fromBelow, - sequenceSemInf = convert $ sequenceSemInf originalSequence - } - upwardsSequence self fromAbove originalSequence fromBelow transformedSequence = case ul of - [] -> defaultValue - otherwise -> foldl combine (head ul) (tail ul) - where ul = upwardsInfoFromSequenceProgramList fromBelow - - downwardsBranch self = const - transformBranch self fromAbove originalBranch fromBelow = BranchProgram $ Branch { - branchData = recursivelyTransformedBranchData fromBelow, - branchSemInf = convert $ branchSemInf originalBranch - } - upwardsBranch self fromAbove originalBranch fromBelow transformedBranch = - foldl combine (upwardsInfoFromBranchConditionVariable fromBelow) [upwardsInfoFromThenBlock fromBelow, upwardsInfoFromElseBlock fromBelow] - - downwardsSequentialLoop self = const - transformSequentialLoop self fromAbove originalSequentialLoop fromBelow = SequentialLoopProgram $ SequentialLoop { - sequentialLoopData = recursivelyTransformedSequentialLoopData fromBelow, - sequentialLoopSemInf = convert $ sequentialLoopSemInf originalSequentialLoop - } - upwardsSequentialLoop self fromAbove originalSequentialLoop fromBelow transformedSequentialLoop = - foldl combine (upwardsInfoFromSequentialLoopConditionVariable fromBelow) - [upwardsInfoFromSequentialLoopConditionCalculation fromBelow, upwardsInfoFromSequentialLoopCore fromBelow] - - downwardsParallelLoop self = const - transformParallelLoop self fromAbove originalParallelLoop fromBelow = ParallelLoopProgram $ ParallelLoop { - parallelLoopData = recursivelyTransformedParallelLoopData fromBelow, - parallelLoopSemInf = convert $ parallelLoopSemInf originalParallelLoop - } - upwardsParallelLoop self fromAbove originalParallelLoop fromBelow transformedParallelLoop = - foldl combine (upwardsInfoFromParallelLoopConditionVariable fromBelow) - [upwardsInfoFromNumberOfIterations fromBelow, upwardsInfoFromParallelLoopCore fromBelow] - - downwardsFormalParameter self = const - transformFormalParameter self fromAbove originalFormalParameter fromBelow = FormalParameter { - formalParameterVariable = recursivelyTransformedFormalParameterVariable fromBelow, - formalParameterSemInf = convert $ formalParameterSemInf originalFormalParameter - } - upwardsFormalParameter self fromAbove originalFormalParameter fromBelow transformedFormalParameter = - upwardsInfoFromFormalParameterVariable fromBelow - - downwardsLocalDeclaration self = const - transformLocalDeclaration self fromAbove originalLocalDeclaration fromBelow = LocalDeclaration { - localDeclarationData = recursivelyTransformedLocalDeclarationData fromBelow, - localDeclarationSemInf = convert $ localDeclarationSemInf originalLocalDeclaration - } - upwardsLocalDeclaration self fromAbove originalLocalDeclaration fromBelow transformedLocalDeclaration = - case (upwardsInfoFromLocalInitValue fromBelow) of - Nothing -> (upwardsInfoFromLocalVariable fromBelow) - Just justUpFromLocalInitValue -> combine (upwardsInfoFromLocalVariable fromBelow) justUpFromLocalInitValue - - downwardsAssignment self = const - transformAssignment self fromAbove originalAssignment fromBelow = AssignmentInstruction $ Assignment { - assignmentData = recursivelyTransformedAssignmentData fromBelow, - assignmentSemInf = convert $ assignmentSemInf originalAssignment - } - upwardsAssignment self fromAbove originalAssignment fromBelow transformedAssignment = - combine (upwardsInfoFromAssignmentLhs fromBelow) (upwardsInfoFromAssignmentRhs fromBelow) - - downwardsProcedureCall self = const - transformProcedureCall self fromAbove originalProcedureCall fromBelow = ProcedureCallInstruction $ ProcedureCall { - procedureCallData = recursivelyTransformedProcedureCallData fromBelow, - procedureCallSemInf = convert $ procedureCallSemInf originalProcedureCall - } - upwardsProcedureCall self fromAbove originalProcedureCall fromBelow transformedProcedureCall = - case ul of - [] -> defaultValue - otherwise -> foldl combine (head ul) (tail ul) - where - ul = upwardsInfoFromActualParametersOfProcedureToCall fromBelow - - downwardsInputActualParameter self = const - transformInputActualParameter self fromAbove originalInputActualParameter fromBelow = InputActualParameter $ InputActualParameterType { - inputActualParameterExpression = recursivelyTransformedInputActualParameterExpression fromBelow, - inputActualParameterSemInf = convert $ inputActualParameterSemInf originalInputActualParameter - } - upwardsInputActualParameter self fromAbove originalInputActualParameter fromBelow transformedInputActualParameter = - upwardsInfoFromInputActualParameter fromBelow - - downwardsOutputActualParameter self = const - transformOutputActualParameter self fromAbove originalOutputActualParameter fromBelow = OutputActualParameter $ OutputActualParameterType { - outputActualParameterLeftValue = recursivelyTransformedOutputActualParameterLeftValue fromBelow, - outputActualParameterSemInf = convert $ outputActualParameterSemInf originalOutputActualParameter - } - upwardsOutputActualParameter self fromAbove originalOutputActualParameter fromBelow transformedOutputActualParameter = - upwardsInfoFromOutputActualParameterLeftValue fromBelow - - downwardsVariableInLeftValue self = const - transformVariableInLeftValue self fromAbove originalVariableInLeftValue fromBelow = VariableLeftValue $ VariableInLeftValue { - variableLeftValueContents = recursivelyTransformedVariableLeftValueContents fromBelow, - variableLeftValueSemInf = convert $ variableLeftValueSemInf originalVariableInLeftValue - } - upwardsVariableInLeftValue self fromAbove originalVariableInLeftValue fromBelow transformedVariableInLeftValue = - upwardsInfoFromVariableLeftValueContents fromBelow - - downwardsArrayElemReference self = const - transformArrayElemReference self fromAbove originalArrayElemReference fromBelow = ArrayElemReferenceLeftValue $ ArrayElemReference { - arrayElemReferenceData = recursivelyTransformedArrayElemReferenceData fromBelow, - arrayElemReferenceSemInf = convert $ arrayElemReferenceSemInf originalArrayElemReference - } - upwardsArrayElemReference self fromAbove originalArrayElemReference fromBelow transformedArrayElemReference = - combine (upwardsInfoFromArrayName fromBelow) (upwardsInfoFromArrayIndex fromBelow) - - downwardsLeftValueExpression self = const - transformLeftValueExpression self fromAbove originalLeftValueExpression fromBelow = LeftValueExpression $ LeftValueInExpression { - leftValueExpressionContents = recursivelyTransformedLeftValueExpressionContents fromBelow, - leftValueExpressionSemInf = convert $ leftValueExpressionSemInf originalLeftValueExpression - } - upwardsLeftValueExpression self fromAbove originalLeftValueExpression fromBelow transformedLeftValueExpression = - upwardsInfoFromLeftValueExpressionContents fromBelow - - downwardsFunctionCall self = const - transformFunctionCall self fromAbove originalFunctionCall fromBelow = FunctionCallExpression $ FunctionCall { - functionCallData = recursivelyTransformedFunctionCallData fromBelow, - functionCallSemInf = convert $ functionCallSemInf originalFunctionCall - } - upwardsFunctionCall self fromAbove originalFunctionCall fromBelow transformedFunctionCall = case ul of - [] -> defaultValue - otherwise -> foldl combine (head ul) (tail ul) - where ul = upwardsInfoFromActualParametersOfFunctionToCall fromBelow - - transformIntConstant self fromAbove originalIntConstant = IntConstant originalIntConstant { - intConstantSemInf = convert $ intConstantSemInf originalIntConstant - } - upwardsIntConstant self fromAbove originalIntConstant transformedIntConstant = defaultValue - - transformFloatConstant self fromAbove originalFloatConstant = FloatConstant originalFloatConstant { - floatConstantSemInf = convert $ floatConstantSemInf originalFloatConstant - } - upwardsFloatConstant self fromAbove originalFloatConstant transformedFloatConstant = defaultValue - - transformBoolConstant self fromAbove originalBoolConstant = BoolConstant originalBoolConstant { - boolConstantSemInf = convert $ boolConstantSemInf originalBoolConstant - } - upwardsBoolConstant self fromAbove originalBoolConstant transformedBoolConstant = defaultValue - - downwardsArrayConstant self = const - transformArrayConstant self fromAbove originalArrayConstant fromBelow = ArrayConstant $ ArrayConstantType { - arrayConstantValue = recursivelyTransformedArrayConstantValue fromBelow, - arrayConstantSemInf = convert $ arrayConstantSemInf originalArrayConstant - } - upwardsArrayConstant self fromAbove originalArrayConstant fromBelow transformedArrayConstant = case ul of - [] -> defaultValue - otherwise -> foldl combine (head ul) (tail ul) - where ul = upwardsInfoFromConstantList fromBelow - - transformVariable self fromAbove originalVariable = originalVariable { - variableSemInf = convert $ variableSemInf originalVariable - } - upwardsVariable self fromAbove originalVariable transformedVariable = defaultValue - --- ================================================================================================================================== --- == Walker defaults --- ================================================================================================================================== - - 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 = InfosFromProcedureParts { - 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 - - walkFormalParameter :: Walker t FormalParameter - walkFormalParameter selfpointer fromAbove p = (transformedFormalParameter, toAbove) - where - toBelow = downwardsFormalParameter selfpointer fromAbove p - transformedVariable = walkVariable selfpointer toBelow (formalParameterVariable p) - fromBelow = InfosFromFormalParameterParts { - recursivelyTransformedFormalParameterVariable = fst transformedVariable, - upwardsInfoFromFormalParameterVariable = snd transformedVariable - } - transformedFormalParameter = transformFormalParameter selfpointer fromAbove p fromBelow - toAbove = upwardsFormalParameter selfpointer fromAbove p fromBelow transformedFormalParameter - - walkBlock :: Walker t Block - walkBlock selfpointer fromAbove block = (transformedBlock, toAbove) - where - toBelow = downwardsBlock selfpointer fromAbove block - transformedLocalDeclarations = map (walkLocalDeclaration selfpointer toBelow) $ blockDeclarations $ blockData block - transformedProgram = walkProgram selfpointer toBelow $ blockInstructions $ blockData block - fromBelow = InfosFromBlockParts { - recursivelyTransformedBlockData = BlockData { - blockDeclarations = map fst transformedLocalDeclarations, - blockInstructions = fst transformedProgram - }, - upwardsInfoFromBlockDeclarations = map snd transformedLocalDeclarations, - upwardsInfoFromBlockInstructions = snd transformedProgram - } - transformedBlock = transformBlock selfpointer fromAbove block fromBelow - toAbove = upwardsBlock selfpointer fromAbove block fromBelow transformedBlock - - walkProgram :: Walker t Program - walkProgram selfpointer fromAbove program = (transformedProgram, toAbove) - where - toBelow = downwardsProgram selfpointer fromAbove program - transformedProgramConstruction = case programConstruction program of - EmptyProgram empty -> walkEmpty selfpointer toBelow empty - PrimitiveProgram primitive -> walkPrimitive selfpointer toBelow primitive - SequenceProgram sequence -> walkSequence selfpointer toBelow sequence - BranchProgram branch -> walkBranch selfpointer toBelow branch - SequentialLoopProgram sequentialLoop -> walkSequentialLoop selfpointer toBelow sequentialLoop - ParallelLoopProgram parallelLoop -> walkParallelLoop selfpointer toBelow parallelLoop - fromBelow = InfosFromProgramParts { - recursivelyTransformedProgramConstruction = fst transformedProgramConstruction, - upwardsInfoFromProgramConstruction = snd transformedProgramConstruction - } - transformedProgram = transformProgram selfpointer fromAbove program fromBelow - toAbove = upwardsProgram selfpointer fromAbove program fromBelow transformedProgram - - walkEmpty :: (TransformationPhase t) => t -> Downwards t -> Empty (From t) -> (ProgramConstruction (To t), Upwards t) - walkEmpty selfpointer fromAbove empty = (transformedEmpty, toAbove) - where - transformedEmpty = transformEmpty selfpointer fromAbove empty - toAbove = upwardsEmpty selfpointer fromAbove empty transformedEmpty - - walkPrimitive :: (TransformationPhase t) => t -> Downwards t -> Primitive (From t) -> (ProgramConstruction (To t), Upwards t) - walkPrimitive selfpointer fromAbove primitive = (transformedPrimitive, toAbove) - where - toBelow = downwardsPrimitive selfpointer fromAbove primitive - transformedPrimitiveInstruction = - walkInstruction selfpointer toBelow (primitiveInstruction primitive) - fromBelow = InfosFromPrimitiveParts { - recursivelyTransformedPrimitiveInstruction = fst transformedPrimitiveInstruction, - upwardsInfoFromPrimitiveInstruction = snd transformedPrimitiveInstruction - } - transformedPrimitive = transformPrimitive selfpointer fromAbove primitive fromBelow - toAbove = upwardsPrimitive selfpointer fromAbove primitive fromBelow transformedPrimitive - - walkSequence :: (TransformationPhase t) => t -> Downwards t -> Sequence (From t) -> (ProgramConstruction (To t), Upwards t) - walkSequence selfpointer fromAbove sequence = (transformedSequence, toAbove) - where - toBelow = downwardsSequence selfpointer fromAbove sequence - transformedProgramList = - map (walkProgram selfpointer toBelow) (sequenceProgramList sequence) - fromBelow = InfosFromSequenceParts { - recursivelyTransformedSequenceProgramList = map fst transformedProgramList, - upwardsInfoFromSequenceProgramList = map snd transformedProgramList - } - transformedSequence = transformSequence selfpointer fromAbove sequence fromBelow - toAbove = upwardsSequence selfpointer fromAbove sequence fromBelow transformedSequence - - walkBranch :: (TransformationPhase t) => t -> Downwards t -> Branch (From t) -> (ProgramConstruction (To t), Upwards t) - walkBranch selfpointer fromAbove branch = (transformedBranch, toAbove) - where - toBelow = downwardsBranch selfpointer fromAbove branch - transformedBranchConditionVariable = walkVariable selfpointer toBelow (branchConditionVariable $ branchData branch) - transformedThenBlock = walkBlock selfpointer toBelow (thenBlock $ branchData branch) - transformedElseBlock = walkBlock selfpointer toBelow (elseBlock $ branchData branch) - fromBelow = InfosFromBranchParts { - recursivelyTransformedBranchData = BranchData { - branchConditionVariable = fst transformedBranchConditionVariable, - thenBlock = fst transformedThenBlock, - elseBlock = fst transformedElseBlock - }, - upwardsInfoFromBranchConditionVariable = snd transformedBranchConditionVariable, - upwardsInfoFromThenBlock = snd transformedThenBlock, - upwardsInfoFromElseBlock = snd transformedElseBlock - } - transformedBranch = transformBranch selfpointer fromAbove branch fromBelow - toAbove = upwardsBranch selfpointer fromAbove branch fromBelow transformedBranch - - walkSequentialLoop :: (TransformationPhase t) => t -> Downwards t -> SequentialLoop (From t) -> (ProgramConstruction (To t), Upwards t) - walkSequentialLoop selfpointer fromAbove loop = (transformedSequentialLoop, toAbove) - where - toBelow = downwardsSequentialLoop selfpointer fromAbove loop - transformedLoopConditionVariable = - walkExpression selfpointer toBelow (sequentialLoopCondition $ sequentialLoopData loop) - transformedConditionCalculation = - walkBlock selfpointer toBelow (conditionCalculation $ sequentialLoopData loop) - transformedSequentialLoopCore = - walkBlock selfpointer toBelow (sequentialLoopCore $ sequentialLoopData loop) - fromBelow = InfosFromSequentialLoopParts { - recursivelyTransformedSequentialLoopData = SequentialLoopData { - sequentialLoopCondition = fst transformedLoopConditionVariable, - conditionCalculation = fst transformedConditionCalculation, - sequentialLoopCore = fst transformedSequentialLoopCore - }, - upwardsInfoFromSequentialLoopConditionVariable = snd transformedLoopConditionVariable, - upwardsInfoFromSequentialLoopConditionCalculation = snd transformedConditionCalculation, - upwardsInfoFromSequentialLoopCore = snd transformedSequentialLoopCore - } - transformedSequentialLoop = transformSequentialLoop selfpointer fromAbove loop fromBelow - toAbove = upwardsSequentialLoop selfpointer fromAbove loop fromBelow transformedSequentialLoop - - walkParallelLoop :: (TransformationPhase t) => t -> Downwards t -> ParallelLoop (From t) -> (ProgramConstruction (To t), Upwards t) - walkParallelLoop selfpointer fromAbove loop = (transformedParallelLoop, toAbove) - where - toBelow = downwardsParallelLoop selfpointer fromAbove loop - transformedParallelLoopConditionVariable = - walkVariable selfpointer toBelow (parallelLoopConditionVariable $ parallelLoopData loop) - transformedNumberOfIterations = - walkExpression selfpointer toBelow (numberOfIterations $ parallelLoopData loop) - transformedParallelLoopCore = - walkBlock selfpointer toBelow (parallelLoopCore $ parallelLoopData loop) - fromBelow = InfosFromParallelLoopParts { - recursivelyTransformedParallelLoopData = ParallelLoopData { - parallelLoopConditionVariable = fst transformedParallelLoopConditionVariable, - numberOfIterations = fst transformedNumberOfIterations, - parallelLoopStep = parallelLoopStep $ parallelLoopData loop, - parallelLoopCore = fst transformedParallelLoopCore - }, - upwardsInfoFromParallelLoopConditionVariable = snd transformedParallelLoopConditionVariable, - upwardsInfoFromNumberOfIterations = snd transformedNumberOfIterations, - upwardsInfoFromParallelLoopCore = snd transformedParallelLoopCore - } - transformedParallelLoop = transformParallelLoop selfpointer fromAbove loop fromBelow - toAbove = upwardsParallelLoop selfpointer fromAbove loop fromBelow transformedParallelLoop - - walkLocalDeclaration :: Walker t LocalDeclaration - walkLocalDeclaration selfpointer fromAbove local = (transformedLocalDeclaration, toAbove) - where - toBelow = downwardsLocalDeclaration selfpointer fromAbove local - transformedLocalVariable = walkVariable selfpointer toBelow (localVariable $ localDeclarationData local) - transformedLocalInitValue = case localInitValue $ localDeclarationData local of - Nothing -> (Nothing, Nothing) - Just localInitExpression -> (Just (fst transformedLocalInitExpression), Just (snd transformedLocalInitExpression)) - where transformedLocalInitExpression = walkExpression selfpointer toBelow localInitExpression - fromBelow = InfosFromLocalDeclarationParts { - recursivelyTransformedLocalDeclarationData = LocalDeclarationData { - localVariable = fst transformedLocalVariable, - localInitValue = fst transformedLocalInitValue - }, - upwardsInfoFromLocalVariable = snd transformedLocalVariable, - upwardsInfoFromLocalInitValue = snd transformedLocalInitValue - } - transformedLocalDeclaration = transformLocalDeclaration selfpointer fromAbove local fromBelow - toAbove = upwardsLocalDeclaration selfpointer fromAbove local fromBelow transformedLocalDeclaration - - walkExpression :: Walker t Expression - walkExpression selfpointer fromAbove expression = case expression of - LeftValueExpression leftValueExpression -> (transformedLeftValueExpression, toAbove) - where - toBelow = downwardsLeftValueExpression selfpointer fromAbove leftValueExpression - transformedLeftValueExpressionContents = walkLeftValue selfpointer - toBelow (leftValueExpressionContents leftValueExpression) - fromBelow = InfosFromLeftValueExpressionParts { - recursivelyTransformedLeftValueExpressionContents = fst transformedLeftValueExpressionContents, - upwardsInfoFromLeftValueExpressionContents = snd transformedLeftValueExpressionContents - } - transformedLeftValueExpression = transformLeftValueExpression selfpointer fromAbove leftValueExpression fromBelow - toAbove = upwardsLeftValueExpression selfpointer fromAbove leftValueExpression fromBelow transformedLeftValueExpression - ConstantExpression constant -> ((ConstantExpression $ fst transformedConstant), snd transformedConstant) - where - toBelow = fromAbove -- calculations are done in WalkConstant, used only in the ArrayConstant branch - transformedConstant = walkConstant selfpointer toBelow constant - FunctionCallExpression functionCall -> (transformedFunctionCallExpression, toAbove) - where - toBelow = downwardsFunctionCall selfpointer fromAbove functionCall - transformedActualParametersOfFunctionToCall = map - (walkExpression selfpointer toBelow) - (actualParametersOfFunctionToCall $ functionCallData functionCall) - fromBelow = InfosFromFunctionCallParts { - recursivelyTransformedFunctionCallData = (functionCallData functionCall) { - actualParametersOfFunctionToCall = map fst transformedActualParametersOfFunctionToCall - }, - upwardsInfoFromActualParametersOfFunctionToCall = map snd transformedActualParametersOfFunctionToCall - } - transformedFunctionCallExpression = transformFunctionCall selfpointer fromAbove functionCall fromBelow - toAbove = upwardsFunctionCall selfpointer fromAbove functionCall fromBelow transformedFunctionCallExpression - - walkConstant :: Walker t Constant - walkConstant selfpointer fromAbove constant = case constant of - IntConstant intConstant -> (transformedIntConstant, toAbove) - where - transformedIntConstant = transformIntConstant selfpointer fromAbove intConstant - toAbove = upwardsIntConstant selfpointer fromAbove intConstant transformedIntConstant - FloatConstant floatConstant -> (transformedFloatConstant, toAbove) - where - transformedFloatConstant = transformFloatConstant selfpointer fromAbove floatConstant - toAbove = upwardsFloatConstant selfpointer fromAbove floatConstant transformedFloatConstant - BoolConstant boolConstant -> (transformedBoolConstant, toAbove) - where - transformedBoolConstant = transformBoolConstant selfpointer fromAbove boolConstant - toAbove = upwardsBoolConstant selfpointer fromAbove boolConstant transformedBoolConstant - ArrayConstant arrayConstant -> (transformedArrayConstant, toAbove) - where - toBelow = downwardsArrayConstant selfpointer fromAbove arrayConstant - transformedConstantList = map (walkConstant selfpointer toBelow) (arrayConstantValue arrayConstant) - fromBelow = InfosFromArrayConstantParts { - recursivelyTransformedArrayConstantValue = map fst transformedConstantList, - upwardsInfoFromConstantList = map snd transformedConstantList - } - transformedArrayConstant = transformArrayConstant selfpointer fromAbove arrayConstant fromBelow - toAbove = upwardsArrayConstant selfpointer fromAbove arrayConstant fromBelow transformedArrayConstant - - walkLeftValue :: Walker t LeftValue - walkLeftValue selfpointer fromAbove leftValue = case leftValue of - VariableLeftValue lvt -> (transformedVariableLeftValue, toAbove) - where - toBelow = downwardsVariableInLeftValue selfpointer fromAbove lvt - transformedVariableLeftValueContents = - walkVariable selfpointer toBelow (variableLeftValueContents lvt) - fromBelow = InfosFromVariableLeftValueParts { - recursivelyTransformedVariableLeftValueContents = fst transformedVariableLeftValueContents, - upwardsInfoFromVariableLeftValueContents = snd transformedVariableLeftValueContents - } - transformedVariableLeftValue = transformVariableInLeftValue selfpointer fromAbove lvt fromBelow - toAbove = upwardsVariableInLeftValue selfpointer fromAbove lvt fromBelow transformedVariableLeftValue - ArrayElemReferenceLeftValue arrayElemReference -> (transformedArrayElemReference, toAbove) - where - toBelow = downwardsArrayElemReference selfpointer fromAbove arrayElemReference - transformedArrayName = - walkLeftValue selfpointer toBelow (arrayName $ arrayElemReferenceData arrayElemReference) - transformedArrayIndex = - walkExpression selfpointer toBelow (arrayIndex $ arrayElemReferenceData arrayElemReference) - fromBelow = InfosFromArrayElemReferenceParts { - recursivelyTransformedArrayElemReferenceData = ArrayElemReferenceData { - arrayName = fst transformedArrayName, - arrayIndex = fst transformedArrayIndex - }, - upwardsInfoFromArrayName = snd transformedArrayName, - upwardsInfoFromArrayIndex = snd transformedArrayIndex - } - transformedArrayElemReference = transformArrayElemReference selfpointer fromAbove arrayElemReference fromBelow - toAbove = upwardsArrayElemReference selfpointer fromAbove arrayElemReference fromBelow transformedArrayElemReference - - walkActualParameter :: Walker t ActualParameter - walkActualParameter selfpointer fromAbove actualParameter = case actualParameter of - InputActualParameter input -> (transformedInputActualParameter, toAbove) - where - toBelow = downwardsInputActualParameter selfpointer fromAbove input - transformedInputActualParameterExpression = - walkExpression selfpointer toBelow (inputActualParameterExpression input) - fromBelow = InfosFromInputActualParameterParts { - recursivelyTransformedInputActualParameterExpression = fst transformedInputActualParameterExpression, - upwardsInfoFromInputActualParameter = snd transformedInputActualParameterExpression - } - transformedInputActualParameter = transformInputActualParameter selfpointer fromAbove input fromBelow - toAbove = upwardsInputActualParameter selfpointer fromAbove input fromBelow transformedInputActualParameter - OutputActualParameter output -> (transformedOutputActualParameter, toAbove) - where - toBelow = downwardsOutputActualParameter selfpointer fromAbove output - transformedOutputActualParameterLeftValue = - walkLeftValue selfpointer toBelow (outputActualParameterLeftValue output) - fromBelow = InfosFromOutputActualParameterParts { - recursivelyTransformedOutputActualParameterLeftValue = fst transformedOutputActualParameterLeftValue, - upwardsInfoFromOutputActualParameterLeftValue = snd transformedOutputActualParameterLeftValue - } - transformedOutputActualParameter = transformOutputActualParameter selfpointer fromAbove output fromBelow - toAbove = upwardsOutputActualParameter selfpointer fromAbove output fromBelow transformedOutputActualParameter - - - walkInstruction :: Walker t Instruction - walkInstruction selfpointer fromAbove instruction = case instruction of - AssignmentInstruction assignment -> (transformedAssignment, toAbove) - where - toBelow = downwardsAssignment selfpointer fromAbove assignment - transformedAssignmentLhs = walkLeftValue selfpointer toBelow (assignmentLhs $ assignmentData assignment) - transformedAssignmentRhs = walkExpression selfpointer toBelow (assignmentRhs $ assignmentData assignment) - fromBelow = InfosFromAssignmentParts { - recursivelyTransformedAssignmentData = AssignmentData { - assignmentLhs = fst transformedAssignmentLhs, - assignmentRhs = fst transformedAssignmentRhs - }, - upwardsInfoFromAssignmentLhs = snd transformedAssignmentLhs, - upwardsInfoFromAssignmentRhs = snd transformedAssignmentRhs - } - transformedAssignment = transformAssignment selfpointer fromAbove assignment fromBelow - toAbove = upwardsAssignment selfpointer fromAbove assignment fromBelow transformedAssignment - ProcedureCallInstruction procedureCall -> (transformedProcedureCall, toAbove) - where - toBelow = downwardsProcedureCall selfpointer fromAbove procedureCall - transformedActualParametersOfProcedureToCall = map (walkActualParameter selfpointer toBelow) - (actualParametersOfProcedureToCall $ procedureCallData procedureCall) - fromBelow = InfosFromProcedureCallParts { - recursivelyTransformedProcedureCallData = (procedureCallData procedureCall) { - actualParametersOfProcedureToCall = map fst transformedActualParametersOfProcedureToCall - }, - upwardsInfoFromActualParametersOfProcedureToCall = map snd transformedActualParametersOfProcedureToCall - } - transformedProcedureCall = transformProcedureCall selfpointer fromAbove procedureCall fromBelow - toAbove = upwardsProcedureCall selfpointer fromAbove procedureCall fromBelow transformedProcedureCall - - walkVariable :: Walker t Variable - walkVariable selfpointer fromAbove v = (transformedVariable, toAbove) - where - transformedVariable = transformVariable selfpointer fromAbove v - toAbove = upwardsVariable selfpointer fromAbove v transformedVariable - --- ================================================================================================================================== --- == Upwards infos --- ================================================================================================================================== - -data (TransformationPhase t) => InfosFromProcedureParts t = InfosFromProcedureParts { - recursivelyTransformedInParameters :: [FormalParameter (To t)], - upwardsInfoFromInParameters :: [Upwards t], - recursivelyTransformedOutParameters :: [FormalParameter (To t)], - upwardsInfoFromOutParameters :: [Upwards t], - recursivelyTransformedProcedureBody :: Block (To t), - upwardsInfoFromProcedureBody :: Upwards t -} - -data (TransformationPhase t) => InfosFromBlockParts t = InfosFromBlockParts { - recursivelyTransformedBlockData :: BlockData (To t), - upwardsInfoFromBlockDeclarations :: [Upwards t], - upwardsInfoFromBlockInstructions :: Upwards t -} - -data (TransformationPhase t) => InfosFromProgramParts t = InfosFromProgramParts { - recursivelyTransformedProgramConstruction :: ProgramConstruction (To t), - upwardsInfoFromProgramConstruction :: Upwards t -} - -data (TransformationPhase t) => InfosFromPrimitiveParts t = InfosFromPrimitiveParts { - recursivelyTransformedPrimitiveInstruction :: Instruction (To t), - upwardsInfoFromPrimitiveInstruction :: Upwards t -} - -data (TransformationPhase t) => InfosFromSequenceParts t = InfosFromSequenceParts { - recursivelyTransformedSequenceProgramList :: [Program (To t)], - upwardsInfoFromSequenceProgramList :: [Upwards t] -} - -data (TransformationPhase t) => InfosFromBranchParts t = InfosFromBranchParts { - recursivelyTransformedBranchData :: BranchData (To t), - upwardsInfoFromBranchConditionVariable :: Upwards t, - upwardsInfoFromThenBlock :: Upwards t, - upwardsInfoFromElseBlock :: Upwards t -} - -data (TransformationPhase t) => InfosFromSequentialLoopParts t = InfosFromSequentialLoopParts { - recursivelyTransformedSequentialLoopData :: SequentialLoopData (To t), - upwardsInfoFromSequentialLoopConditionVariable :: Upwards t, - upwardsInfoFromSequentialLoopConditionCalculation :: Upwards t, - upwardsInfoFromSequentialLoopCore :: Upwards t -} - -data (TransformationPhase t) => InfosFromParallelLoopParts t = InfosFromParallelLoopParts { - recursivelyTransformedParallelLoopData :: ParallelLoopData (To t), - upwardsInfoFromParallelLoopConditionVariable :: Upwards t, - upwardsInfoFromNumberOfIterations :: Upwards t, - upwardsInfoFromParallelLoopCore :: Upwards t -} - -data (TransformationPhase t) => InfosFromFormalParameterParts t = InfosFromFormalParameterParts { - recursivelyTransformedFormalParameterVariable :: Variable (To t), - upwardsInfoFromFormalParameterVariable :: Upwards t -} - -data (TransformationPhase t) => InfosFromLocalDeclarationParts t = InfosFromLocalDeclarationParts { - recursivelyTransformedLocalDeclarationData :: LocalDeclarationData (To t), - upwardsInfoFromLocalVariable :: Upwards t, - upwardsInfoFromLocalInitValue :: Maybe (Upwards t) -} - -data (TransformationPhase t) => InfosFromAssignmentParts t = InfosFromAssignmentParts { - recursivelyTransformedAssignmentData :: AssignmentData (To t), - upwardsInfoFromAssignmentLhs :: Upwards t, - upwardsInfoFromAssignmentRhs :: Upwards t -} - -data (TransformationPhase t) => InfosFromProcedureCallParts t = InfosFromProcedureCallParts { - recursivelyTransformedProcedureCallData :: ProcedureCallData (To t), - upwardsInfoFromActualParametersOfProcedureToCall :: [Upwards t] -} - -data (TransformationPhase t) => InfosFromInputActualParameterParts t = InfosFromInputActualParameterParts { - recursivelyTransformedInputActualParameterExpression :: Expression (To t), - upwardsInfoFromInputActualParameter :: Upwards t -} - -data (TransformationPhase t) => InfosFromOutputActualParameterParts t = InfosFromOutputActualParameterParts { - recursivelyTransformedOutputActualParameterLeftValue :: LeftValue (To t), - upwardsInfoFromOutputActualParameterLeftValue :: Upwards t -} - -data (TransformationPhase t) => InfosFromArrayElemReferenceParts t = InfosFromArrayElemReferenceParts { - recursivelyTransformedArrayElemReferenceData :: ArrayElemReferenceData (To t), - upwardsInfoFromArrayName :: Upwards t, - upwardsInfoFromArrayIndex :: Upwards t -} - -data (TransformationPhase t) => InfosFromVariableLeftValueParts t = InfosFromVariableLeftValueParts { - recursivelyTransformedVariableLeftValueContents :: Variable (To t), - upwardsInfoFromVariableLeftValueContents :: Upwards t -} - -data (TransformationPhase t) => InfosFromLeftValueExpressionParts t = InfosFromLeftValueExpressionParts { - recursivelyTransformedLeftValueExpressionContents :: LeftValue (To t), - upwardsInfoFromLeftValueExpressionContents :: Upwards t -} - -data (TransformationPhase t) => InfosFromFunctionCallParts t = InfosFromFunctionCallParts { - recursivelyTransformedFunctionCallData :: FunctionCallData (To t), - upwardsInfoFromActualParametersOfFunctionToCall :: [Upwards t] -} - -data (TransformationPhase t) => InfosFromArrayConstantParts t = InfosFromArrayConstantParts { - recursivelyTransformedArrayConstantValue :: [Constant (To t)], - upwardsInfoFromConstantList :: [Upwards t] -} - +-- +-- 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 --- a/Feldspar/Compiler/PluginArchitecture/DefaultConvert.hs +++ b/Feldspar/Compiler/PluginArchitecture/DefaultConvert.hs @@ -1,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 #-} @@ -66,60 +62,64 @@ class Convert a b where convert :: a -> b -{-instance Convert a a where - convert = id-} - 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) - , Default (ProgramInfo to) - , Convert (EmptyInfo from) (EmptyInfo to) - , Convert (PrimitiveInfo from) (PrimitiveInfo to) - , Convert (SequenceInfo from) (SequenceInfo to) - , Convert (BranchInfo from) (BranchInfo to) - , Convert (FormalParameterInfo from) (FormalParameterInfo to) - , Convert (SequentialLoopInfo from) (SequentialLoopInfo to) - , Convert (ParallelLoopInfo from) (ParallelLoopInfo to) - , Convert (LocalDeclarationInfo from) (LocalDeclarationInfo to) - , Convert (LeftValueExpressionInfo from) (LeftValueExpressionInfo to) - , Convert (InputActualParameterInfo from) (InputActualParameterInfo to) - , Convert (OutputActualParameterInfo from) (OutputActualParameterInfo to) - , Convert (VariableInLeftValueInfo from) (VariableInLeftValueInfo to) - , Convert (ArrayElemReferenceInfo from) (ArrayElemReferenceInfo to) - , Convert (ProcedureCallInfo from) (ProcedureCallInfo to) - , Convert (AssignmentInfo from) (AssignmentInfo to) - , Convert (FunctionCallInfo from) (FunctionCallInfo 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 -- TODO general instance needs UndecidableInstances, check whether it is ok - , Convert (ProcedureInfo from) (ProcedureInfo to) - , Convert (BlockInfo from) (BlockInfo to) - , Default (ProgramInfo to) - , Convert (EmptyInfo from) (EmptyInfo to) - , Convert (PrimitiveInfo from) (PrimitiveInfo to) - , Convert (SequenceInfo from) (SequenceInfo to) - , Convert (BranchInfo from) (BranchInfo to) - , Convert (FormalParameterInfo from) (FormalParameterInfo to) - , Convert (SequentialLoopInfo from) (SequentialLoopInfo to) - , Convert (ParallelLoopInfo from) (ParallelLoopInfo to) - , Convert (LocalDeclarationInfo from) (LocalDeclarationInfo to) - , Convert (LeftValueExpressionInfo from) (LeftValueExpressionInfo to) - , Convert (InputActualParameterInfo from) (InputActualParameterInfo to) - , Convert (OutputActualParameterInfo from) (OutputActualParameterInfo to) - , Convert (VariableInLeftValueInfo from) (VariableInLeftValueInfo to) - , Convert (ArrayElemReferenceInfo from) (ArrayElemReferenceInfo to) - , Convert (ProcedureCallInfo from) (ProcedureCallInfo to) - , Convert (AssignmentInfo from) (AssignmentInfo to) - , Convert (FunctionCallInfo from) (FunctionCallInfo 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 + , 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 --- a/Feldspar/Compiler/Plugins/BackwardPropagation.hs +++ b/Feldspar/Compiler/Plugins/BackwardPropagation.hs @@ -1,38 +1,36 @@ -{- - - 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. - -} +-- +-- 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 +module Feldspar.Compiler.Plugins.BackwardPropagation ( + BackwardPropagation(..) + ) where import Feldspar.Compiler.PluginArchitecture @@ -59,71 +57,70 @@ instance Plugin BackwardPropagation where type ExternalInfo BackwardPropagation = DebugOption executePlugin BackwardPropagation externalInfo procedure - | externalInfo == NoSimplification = fst $ executeTransformationPhase BackwardPropagation () procedure - | otherwise = fst $ executeTransformationPhase PropagationTransform [] $ fst $ executeTransformationPhase PropagationCollect (Occurrence_read,False) procedure + | externalInfo == NoSimplification = fst $ executeTransformationPhase BackwardPropagation () procedure + | otherwise = fst $ executeTransformationPhase PropagationTransform [] $ fst $ executeTransformationPhase BackwardPropagationCollect (Occurrence_read,False) procedure -- ==================== -- Collect -- ==================== -instance Default [(VariableData, LeftValue ())] where +instance Default [(VariableData, LeftValueData ())] where defaultValue = [] -- meaning (out,var,out written in a sequence before out=var) -instance Default [(VariableData, LeftValue (),Bool)] where +instance Default [(VariableData, LeftValueData (),Bool)] where defaultValue = [] -instance Combine (VarStatBck, [(VariableData, LeftValue (),Bool)]) where +instance Combine (VarStatBck, [(VariableData, LeftValueData (),Bool)]) where combine (m1,x1) (m2,x2) = (combine m1 m2, x1 ++ x2) -instance Default (Maybe (VariableData, LeftValue (),Bool)) where +instance Default (Maybe (VariableData, LeftValueData (),Bool)) where defaultValue = Nothing -data PropagationSemInf +data BackwardPropagationSemInf -instance SemanticInfo PropagationSemInf where - type ProcedureInfo PropagationSemInf = () - type BlockInfo PropagationSemInf = [(VariableData, LeftValue ())] --replacements inside block - type ProgramInfo PropagationSemInf = () - type EmptyInfo PropagationSemInf = () - type PrimitiveInfo PropagationSemInf = Maybe (VariableData, LeftValue (), 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 PropagationSemInf = () - type BranchInfo PropagationSemInf = () - type SequentialLoopInfo PropagationSemInf = () - type ParallelLoopInfo PropagationSemInf = () - type FormalParameterInfo PropagationSemInf = () - type LocalDeclarationInfo PropagationSemInf = () - type LeftValueExpressionInfo PropagationSemInf = () - type VariableInLeftValueInfo PropagationSemInf = () - type ArrayElemReferenceInfo PropagationSemInf = () - type InputActualParameterInfo PropagationSemInf = () - type OutputActualParameterInfo PropagationSemInf = () - type AssignmentInfo PropagationSemInf = () - type ProcedureCallInfo PropagationSemInf = () - type FunctionCallInfo PropagationSemInf = () - type IntConstantInfo PropagationSemInf = () - type FloatConstantInfo PropagationSemInf = () - type BoolConstantInfo PropagationSemInf = () - type ArrayConstantInfo PropagationSemInf = () - type VariableInfo PropagationSemInf = () +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 PropagationCollect = PropagationCollect +data BackwardPropagationCollect = BackwardPropagationCollect -instance TransformationPhase PropagationCollect where - type From PropagationCollect = InitSemInf - type To PropagationCollect = PropagationSemInf - type Downwards PropagationCollect = (Occurrence_place, Bool) - type Upwards PropagationCollect = (VarStatBck, [(VariableData, LeftValue (),Bool)]) - downwardsBranch self d orig = (occurrenceDownwards orig, False) - downwardsSequentialLoop self d orig = (occurrenceDownwards orig, False) - downwardsParallelLoop self d orig = (occurrenceDownwards orig, False) +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 $ localDeclarationData orig) - downwardsAssignment self d orig = (occurrenceDownwards orig, False) - downwardsInputActualParameter self d orig = (occurrenceDownwards orig, False) - downwardsOutputActualParameter self d orig = (occurrenceDownwards orig, False) - downwardsLeftValueExpression self d orig = (occurrenceDownwards orig, False) - downwardsFunctionCall 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, []) @@ -131,51 +128,53 @@ 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, []) - upwardsPrimitive self d origPrimitive u newPrimitive = case newPrimitive of + 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,[]) - upwardsSequence self d origiSeq u transformedSequence = checkInSequence $ upwardsInfoFromSequenceProgramList u + upwardsSequenceProgramInProgram self d origiSeq u transformedSequence = checkInSequence $ upwardsInfoFromSequenceProgramList u transformBlock self d origBlock u = Block { - blockData = recursivelyTransformedBlockData u, + blockDeclarations = recursivelyTransformedBlockDeclarations u, + blockInstructions = recursivelyTransformedBlockInstructions u, blockSemInf = unChain $ checkInDeclatation origBlock $ upwardsInfoFromBlockInstructions u - } - transformPrimitive self d origPrimitive u = PrimitiveProgram $ Primitive { + } + transformPrimitiveProgramInProgram self d origPrimitive u = PrimitiveProgram $ Primitive { primitiveInstruction = recursivelyTransformedPrimitiveInstruction u, primitiveSemInf = getNames origPrimitive } -getNames :: (SemanticInfo t) => Primitive t -> Maybe (VariableData, LeftValue (),Bool) -getNames pr = getNames' $ primitiveInstruction pr where +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 $ actualParametersOfProcedureToCall $ procedureCallData pc + | goodName pc = getParamNames $ map actualParameterData $ actualParametersOfProcedureToCall pc | otherwise = Nothing - goodName pc = "copy" == (nameOfProcedureToCall $ procedureCallData pc) + 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 $ inputActualParameterExpression i - getOName o = Just $ deleteSemInf $ outputActualParameterLeftValue o - getExpName (LeftValueExpression le) = getLvName_noarr $ leftValueExpressionContents le + getIName i = getExpName $ expressionData i + getOName o = Just $ deleteSemInf $ leftValueData o + getExpName (LeftValueExpression lv) = getLvName_noarr $ leftValueData lv getExpName _ = Nothing - getLvName_noarr (VariableLeftValue vlv) = Just $ variableData $ variableLeftValueContents vlv + getLvName_noarr (VariableLeftValue v) = Just $ variableData v getLvName_noarr _ = Nothing -getLvName :: (SemanticInfo t) => LeftValue t -> VariableData -getLvName (VariableLeftValue vlv) = variableData $ variableLeftValueContents vlv -getLvName (ArrayElemReferenceLeftValue aer) = getLvName $ arrayName $ arrayElemReferenceData aer +getLvName :: (SemanticInfo t) => LeftValueData t -> VariableData +getLvName (VariableLeftValue v) = variableData v +getLvName (ArrayElemReferenceLeftValue aer) = getLvName $ leftValueData $ arrayName aer -checkInSequence :: [(VarStatBck, [(VariableData, LeftValue (), Bool)])] -> (VarStatBck, [(VariableData, LeftValue (), Bool)]) +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, LeftValue (), Bool)])] -> Bool{-usedVar-} -> Bool{-usedOut-} -> Bool{-after-} -> (VariableData {-var-}, LeftValue () {-out-}, Bool) -> Maybe (VariableData, LeftValue (), Bool) + 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 @@ -190,7 +189,6 @@ | {-(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 - --var = variableName varD out = getLvName outD {- check the sequence format: @@ -208,13 +206,13 @@ | -} -checkInDeclatation :: Block InitSemInf -> (VarStatBck, [(VariableData, LeftValue (), Bool)]) -> [(VariableData, LeftValue ())] +checkInDeclatation :: Block InitSemInf -> (VarStatBck, [(VariableData, LeftValueData (), Bool)]) -> [(VariableData, LeftValueData ())] checkInDeclatation origBlock u = mapMaybe (checkDecl $ decl) (snd u) where - decl = blockDeclarations $ blockData origBlock - checkDecl :: [LocalDeclaration InitSemInf] -> (VariableData, LeftValue (), Bool) -> Maybe (VariableData, LeftValue ()) + 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 $ localDeclarationData ld of + Just ld -> case localInitValue ld of Nothing -> Just (var,outD) Just exp -> case outUsedLower of True -> Nothing @@ -230,14 +228,14 @@ data PropagationTransform = PropagationTransform instance TransformationPhase PropagationTransform where - type From PropagationTransform = PropagationSemInf + type From PropagationTransform = BackwardPropagationSemInf type To PropagationTransform = () - type Downwards PropagationTransform = [(VariableData, LeftValue ())] + type Downwards PropagationTransform = [(VariableData, LeftValueData ())] type Upwards PropagationTransform = () downwardsBlock self d origBlock = foldl addChain (blockSemInf origBlock) d downwardsLocalDeclaration self d origLocDecl = [] - transformBlock self d orig fromBelow = delUnusedDecl (map fst $ foldl addChain (blockSemInf orig) d) orig $ recursivelyTransformedBlockData fromBelow - transformPrimitive self d origPrimitive u = + transformBlock self d orig u = delUnusedDecl (map fst $ foldl addChain (blockSemInf orig) d) orig (recursivelyTransformedBlockDeclarations u) (recursivelyTransformedBlockInstructions u) + transformPrimitiveProgramInProgram self d origPrimitive u = case primitiveSemInf origPrimitive of Nothing -> makedPrim Just (var,outD,_) @@ -248,35 +246,30 @@ primitiveInstruction = recursivelyTransformedPrimitiveInstruction u, primitiveSemInf =() } - transformVariableInLeftValue self d origVIL u = case List.find (\(a,b) -> a == newVar) d of - Nothing -> VariableLeftValue $ VariableInLeftValue { - variableLeftValueContents = recursivelyTransformedVariableLeftValueContents u, - variableLeftValueSemInf = () + transformVariableLeftValueInLeftValue self d origVar = case List.find (\(a,b) -> a == {-newVar-} variableData origVar) d of + Nothing -> VariableLeftValue $ origVar { + variableSemInf = () } Just (var,out) -> out - where - newVar = variableData $ recursivelyTransformedVariableLeftValueContents u + --where + -- newVar = variableData $ recursivelyTransformedVariableLeftValueContents u -unChain :: [(VariableData, LeftValue ())] -> [(VariableData, LeftValue ())] +unChain :: [(VariableData, LeftValueData ())] -> [(VariableData, LeftValueData ())] unChain s = foldl addChain [] s -addChain :: [(VariableData, LeftValue ())] -> (VariableData, LeftValue ()) -> [(VariableData, LeftValue ())] +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 :: LeftValue () {-toChange-} -> LeftValue () {-newName-} -> LeftValue () + changeInnerArrayName :: LeftValueData () {-toChange-} -> LeftValueData () {-newName-} -> LeftValueData () changeInnerArrayName toChange (ArrayElemReferenceLeftValue aer) = ArrayElemReferenceLeftValue aer { - arrayElemReferenceData = (arrayElemReferenceData aer) { - arrayName = changeInnerArrayName toChange (arrayName $ arrayElemReferenceData aer) - } + arrayName = LeftValue (changeInnerArrayName toChange $ leftValueData $ arrayName aer) () } changeInnerArrayName (ArrayElemReferenceLeftValue aer) newName@(VariableLeftValue _) = ArrayElemReferenceLeftValue aer { - arrayElemReferenceData = (arrayElemReferenceData aer) { - arrayName = changeInnerArrayName (arrayName $ arrayElemReferenceData aer) newName - } + arrayName = LeftValue (changeInnerArrayName (leftValueData $ arrayName aer) newName) () } changeInnerArrayName (VariableLeftValue _) newName@(VariableLeftValue _) = newName diff --git a/Feldspar/Compiler/Plugins/ConstantFolding.hs b/Feldspar/Compiler/Plugins/ConstantFolding.hs deleted file mode 100644 --- a/Feldspar/Compiler/Plugins/ConstantFolding.hs +++ /dev/null @@ -1,72 +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.ConstantFolding where - -import Feldspar.Compiler.PluginArchitecture - -data ConstantFolding = ConstantFolding - -instance Plugin ConstantFolding where - type ExternalInfo ConstantFolding = () - executePlugin ConstantFolding _ procedure = - fst $ executeTransformationPhase ConstantFolding () procedure - -instance TransformationPhase ConstantFolding where - type From ConstantFolding = () - type To ConstantFolding = () - type Downwards ConstantFolding = () - type Upwards ConstantFolding = () - - transformFunctionCall ConstantFolding _ _ (InfosFromFunctionCallParts funData _) = - case roleOfFunctionToCall $ funData of - InfixOp -> case nameOfFunctionToCall $ funData of - "+" -> elimParamIf (isConstIntN 0) True funCall - "-" -> elimParamIf (isConstIntN 0) False funCall - "*" -> elimParamIf (isConstIntN 1) True funCall - _ -> FunctionCallExpression funCall - _ -> FunctionCallExpression funCall - - where - funCall = FunctionCall (funData) () - - isConstIntN n (ConstantExpression (IntConstant (IntConstantType i _))) = n == i - isConstIntN _ _ = False - - elimParamIf pred flippable funCall@(FunctionCall (FunctionCallData InfixOp _ _ (x:xs)) _) - | pred (head xs) = x - | flippable && pred x = head xs - | otherwise = FunctionCallExpression funCall - elimParamIf _ _ funCall = FunctionCallExpression funCall - diff --git a/Feldspar/Compiler/Plugins/ForwardPropagation.hs b/Feldspar/Compiler/Plugins/ForwardPropagation.hs --- a/Feldspar/Compiler/Plugins/ForwardPropagation.hs +++ b/Feldspar/Compiler/Plugins/ForwardPropagation.hs @@ -1,38 +1,37 @@ -{- - - 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. - -} +-- +-- 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 where +module Feldspar.Compiler.Plugins.ForwardPropagation ( + ForwardPropagation(..) + ) + where import Feldspar.Compiler.PluginArchitecture import qualified Data.Map as Map @@ -49,15 +48,15 @@ -- == Copy propagation plugin (forward) -- =========================================================================== -type VarStatFwd = VarStatistics (Expression ForwardPropagationpSemInf,[VariableData],Bool) -type OccurrencesFwd = Occurrences (Expression ForwardPropagationpSemInf,[VariableData],Bool) +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 + | externalInfo == NoSimplification || externalInfo == NoPrimitiveInstructionHandling = procedure | otherwise = fst $ executeTransformationPhase ForwardPropagationTransform (fst globals1) procedureCollected1 where (procedureCollected1,globals1) = executeTransformationPhase ForwardPropagationCollect Occurrence_read procedure @@ -72,36 +71,34 @@ -- Collect -- ==================== -data ForwardPropagationpSemInf - -instance SemanticInfo ForwardPropagationpSemInf where - type ProcedureInfo ForwardPropagationpSemInf = () - type BlockInfo ForwardPropagationpSemInf = VarStatFwd - type ProgramInfo ForwardPropagationpSemInf = () - type EmptyInfo ForwardPropagationpSemInf = () - type PrimitiveInfo ForwardPropagationpSemInf = () - type SequenceInfo ForwardPropagationpSemInf = () - type BranchInfo ForwardPropagationpSemInf = () - type SequentialLoopInfo ForwardPropagationpSemInf = VarStatFwd - type ParallelLoopInfo ForwardPropagationpSemInf = () - type FormalParameterInfo ForwardPropagationpSemInf = () - type LocalDeclarationInfo ForwardPropagationpSemInf = () - type LeftValueExpressionInfo ForwardPropagationpSemInf = () - type VariableInLeftValueInfo ForwardPropagationpSemInf = () - type ArrayElemReferenceInfo ForwardPropagationpSemInf = Maybe VariableData --name of the indexed variable - type InputActualParameterInfo ForwardPropagationpSemInf = () - type OutputActualParameterInfo ForwardPropagationpSemInf = () - type AssignmentInfo ForwardPropagationpSemInf = () - type ProcedureCallInfo ForwardPropagationpSemInf = () - type FunctionCallInfo ForwardPropagationpSemInf = () - type IntConstantInfo ForwardPropagationpSemInf = () - type FloatConstantInfo ForwardPropagationpSemInf = () - type BoolConstantInfo ForwardPropagationpSemInf = () - type ArrayConstantInfo ForwardPropagationpSemInf = () - type VariableInfo ForwardPropagationpSemInf = Occurrence_place +data ForwardPropagationSemInf -instance Default (Maybe VariableData) where - defaultValue = Nothing +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) @@ -110,25 +107,24 @@ instance TransformationPhase ForwardPropagationCollect where type From ForwardPropagationCollect = () - type To ForwardPropagationCollect = ForwardPropagationpSemInf + type To ForwardPropagationCollect = ForwardPropagationSemInf type Downwards ForwardPropagationCollect = Occurrence_place type Upwards ForwardPropagationCollect = (VarStatFwd, Maybe VariableData) - downwardsBranch self d orig = occurrenceDownwards orig - downwardsSequentialLoop self d orig = occurrenceDownwards orig - downwardsParallelLoop self d orig = occurrenceDownwards orig + 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 - downwardsAssignment self d orig = occurrenceDownwards orig - downwardsInputActualParameter self d orig = occurrenceDownwards orig - downwardsOutputActualParameter self d orig = occurrenceDownwards orig - downwardsLeftValueExpression self d orig = occurrenceDownwards orig - downwardsFunctionCall 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 { - blockData = recursivelyTransformedBlockData u, + blockDeclarations = recursivelyTransformedBlockDeclarations u, + blockInstructions = recursivelyTransformedBlockInstructions u, blockSemInf = selectFromVarStatistics ( declaredVars origBlock) belowStatistics } where - belowStatistics = checkFwdDeclaration (map fst $ upwardsInfoFromBlockDeclarations u) (fst $ upwardsInfoFromBlockInstructions u) - --belowStatistics = foldl combine (fst $ upwardsInfoFromBlockInstructions u) $ map fst $ upwardsInfoFromBlockDeclarations u + belowStatistics = checkFwdDeclaration (map fst $ upwardsInfoFromBlockDeclarations u) (fst $ upwardsInfoFromBlockInstructions u) transformVariable self d origVar = origVar { variableSemInf = d } @@ -137,35 +133,36 @@ 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 - upwardsSequence self d origSeq u transSeq = (checkFwdSequence $ map fst $ upwardsInfoFromSequenceProgramList u, Nothing) + 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 - upwardsParallelLoop self d origParLoop u transParLoop = (multipleVarStatistics $ + upwardsParallelLoopProgramInProgram self d origParLoop u transParLoop = (multipleVarStatistics $ foldl combine (fst $ upwardsInfoFromParallelLoopConditionVariable u) [fst $ upwardsInfoFromNumberOfIterations u, fst $ upwardsInfoFromParallelLoopCore u], Nothing) - upwardsAssignment self d origAssign u transAssig = case assignmentLhs $ assignmentData origAssign of + upwardsAssignmentInstructionInInstruction self d origAssign u transAssig = case leftValueData $ assignmentLhs origAssign of VariableLeftValue vlv -> (Map.insert var occ $ fst $ upwardsInfoFromAssignmentRhs u, Nothing) where - var = variableData $ variableLeftValueContents vlv + var = variableData vlv occ = Occurrences (One $ Just (assRs, Map.keys $ fst $ upwardsInfoFromAssignmentRhs u, False)) Zero assRs = case transAssig of - AssignmentInstruction newAssign -> assignmentRhs $ assignmentData newAssign + 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 $ localDeclarationData newDecl of + upwardsLocalDeclaration self d origDecl u newDecl = case localInitValue newDecl of Nothing -> defaultCase - Just (ConstantExpression (ArrayConstant ac)) -> defaultCase - Just initExp -> case upwardsInfoFromLocalInitValue u of - Nothing -> defaultCase - Just justUpFromLocalInitValue -> (Map.insert var (occ initExp $ fst justUpFromLocalInitValue) $ fst justUpFromLocalInitValue, Nothing) + 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 $ localDeclarationData $ origDecl + var = variableData $ localVariable origDecl occ initExp justUpFromLocalInitValue = Occurrences (One $ Just (initExp, Map.keys justUpFromLocalInitValue, False)) Zero defaultCase = (fst $ upwardsInfoFromLocalVariable u, Nothing) - upwardsProcedureCall self d origProcCall u transProcCall - | List.isPrefixOf "copy" $ nameOfProcedureToCall $ procedureCallData origProcCall = case actParams of -- TODO: eliminate string constant + 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 outputActualParameterLeftValue outArr of + case leftValueData outArr of VariableLeftValue vlv -> (Map.insert (var vlv) (occ inArr) $ fst $ head ul, Nothing) ArrayElemReferenceLeftValue aer -> defaultTr _ -> defaultTr @@ -176,26 +173,33 @@ otherwise -> foldl combine (head ul) (tail ul) ul = upwardsInfoFromActualParametersOfProcedureToCall u actParams = case transProcCall of - ProcedureCallInstruction pc -> actualParametersOfProcedureToCall $ procedureCallData pc + ProcedureCallInstruction pc -> actualParametersOfProcedureToCall pc _ -> fwdPropError $ "Internal error: ForwardPropagation/2!" - var vlv = variableData $ variableLeftValueContents vlv - occ inArr = Occurrences (One $ Just (inputActualParameterExpression inArr, Map.keys $ fst $ head ul, False)) Zero - transformSequentialLoop self d origSeqLoop u = SequentialLoopProgram $ SequentialLoop { - sequentialLoopData = (recursivelyTransformedSequentialLoopData u) { - conditionCalculation = (conditionCalculation $ recursivelyTransformedSequentialLoopData u) { + 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 - } - }, - sequentialLoopSemInf = blockSemInf $ conditionCalculation $ recursivelyTransformedSequentialLoopData u + }, + sequentialLoopCore = recursivelyTransformedSequentialLoopCore u, + sequentialLoopSemInf = blockSemInf $ recursivelyTransformedConditionCalculation u } - upwardsSequentialLoop self d origSeqLoop u newSeqLoop = (multipleVarStatistics $ - combine (fst $ upwardsInfoFromSequentialLoopConditionCalculation u) $ fst $ upwardsInfoFromSequentialLoopCore u, Nothing) - transformArrayElemReference self d origArrRef u = ArrayElemReferenceLeftValue $ ArrayElemReference { - arrayElemReferenceData = recursivelyTransformedArrayElemReferenceData 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 } - upwardsArrayElemReference self d origArrayRef u transArrayRefe = + 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 @@ -207,7 +211,7 @@ 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 $ variableType preSeqVar) && readVar preSeqOcc /= Multiple) of + | 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 @@ -217,8 +221,8 @@ | otherwise -> preSeqOcc _ -> preSeqOcc addDep curr preSeqVar = case curr `getWrite` preSeqVar of - Nothing -> [] - Just (exp,vars,varsWritten) -> vars + Nothing -> [] + Just (exp,vars,varsWritten) -> vars checkFwdDeclaration :: [VarStatFwd] -> VarStatFwd -> VarStatFwd checkFwdDeclaration [] blockStat = blockStat @@ -228,100 +232,90 @@ -- ForwardPropagation -- ==================== -type VarWrite t = [(VariableData,Expression t)] +type VarWrite t = [(VariableData,ExpressionData t)] -toVarWrite :: VarStatFwd -> VarWrite ForwardPropagationpSemInf +toVarWrite :: VarStatFwd -> VarWrite ForwardPropagationSemInf toVarWrite vs = Map.foldWithKey (getExp) [] vs where - getExp :: VariableData -> OccurrencesFwd -> VarWrite ForwardPropagationpSemInf -> VarWrite ForwardPropagationpSemInf + 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 c -> simplConst c + ConstantExpression (Constant c _) -> simplConst c _ -> True simpleExpr e = case e of - ConstantExpression c -> simplConst c - LeftValueExpression l -> case leftValueExpressionContents l of + ConstantExpression (Constant c _) -> simplConst c + LeftValueExpression l -> case leftValueData l of VariableLeftValue v -> True - ArrayElemReferenceLeftValue a -> simpleExpr $ arrayIndex $ arrayElemReferenceData a + ArrayElemReferenceLeftValue a -> simpleExpr $ expressionData $ arrayIndex a _ -> False simplConst (ArrayConstant ac) = False simplConst _ = True -instance Default (Set.Set VariableData) where - defaultValue = Set.empty - -instance Combine (Set.Set VariableData) where - combine = Set.union - data ForwardPropagationTransform = ForwardPropagationTransform instance TransformationPhase ForwardPropagationTransform where - type From ForwardPropagationTransform = ForwardPropagationpSemInf + 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 - downwardsSequentialLoop self d origSeqLoop = combine d $ sequentialLoopSemInf origSeqLoop - transformLeftValueExpression self d origLVE u = case leftValueExpressionContents origLVE of - VariableLeftValue origVar -> case List.find (\(vn,e) -> (vn == var origVar)) varwrite of + 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 -> fst $ walkExpression self d (snd repl) + Just repl -> expressionData $ fst $ walkExpression self d $ Expression (snd repl) () ArrayElemReferenceLeftValue origArr -> defaultTr where - var v = variableData $ variableLeftValueContents v varwrite = toVarWrite d - defaultTr = LeftValueExpression $ LeftValueInExpression { - leftValueExpressionContents = recursivelyTransformedLeftValueExpressionContents u, - leftValueExpressionSemInf = () + defaultTr = LeftValueExpression $ LeftValue { + leftValueData = recursivelyTransformedLeftValueData u, + leftValueSemInf = () } - transformVariableInLeftValue self d origVarLV u = case List.find (\(vn,e) -> (vn == var)) varwrite of + transformVariableLeftValueInLeftValue self d origVar = case List.find (\(vn,e) -> (vn == var)) varwrite of Nothing -> defaultTr Just repl -> case repl of - (_,LeftValueExpression lve) -> fst $ walkLeftValue self d $ leftValueExpressionContents lve + (_,LeftValueExpression lv) -> leftValueData $ fst $ walkLeftValue self d lv _ -> defaultTr where - var = variableData $ variableLeftValueContents origVarLV + var = variableData origVar varwrite = toVarWrite d - defaultTr = VariableLeftValue $ VariableInLeftValue { - variableLeftValueContents = recursivelyTransformedVariableLeftValueContents u, - variableLeftValueSemInf = () + defaultTr = VariableLeftValue $ origVar { + variableSemInf = () } - transformArrayElemReference self d origArrayRef u = case List.find (\(vn,e) -> (vn == var)) varwrite of + transformArrayElemReferenceLeftValueInLeftValue self d origArrayRef u = case List.find (\(vn,e) -> (vn == var)) varwrite of Nothing -> defaultTr Just repl -> case repl of - (_,LeftValueExpression lve) -> case leftValueExpressionContents lve of + (_,LeftValueExpression lv) -> case leftValueData lv of VariableLeftValue vlv -> defaultTr ArrayElemReferenceLeftValue aer -> ArrayElemReferenceLeftValue $ ArrayElemReference { - arrayElemReferenceData = ArrayElemReferenceData { - arrayName = fst $ walkLeftValue self (newD d var aer origArrayRef) $ arrayName $ arrayElemReferenceData origArrayRef - , arrayIndex = fst $ walkExpression self d $ arrayIndex $ arrayElemReferenceData aer - }, + arrayName = fst $ walkLeftValue self (swapArrayIndex d var aer origArrayRef) $ arrayName origArrayRef, + arrayIndex = fst $ walkExpression self d $ arrayIndex aer, arrayElemReferenceSemInf = () } _ -> defaultTr where - newD :: VarStatFwd -> VariableData -> ArrayElemReference ForwardPropagationpSemInf -> ArrayElemReference ForwardPropagationpSemInf -> VarStatFwd - newD d var rep orig = Map.adjust (newDD var rep orig) var d - newDD var rep orig x = x { - writeVar = One $ Just ( LeftValueExpression $ LeftValueInExpression { - leftValueExpressionContents = ArrayElemReferenceLeftValue $ ArrayElemReference { - arrayElemReferenceData = ArrayElemReferenceData { - arrayName = arrayName $ arrayElemReferenceData rep - , arrayIndex = arrayIndex $ arrayElemReferenceData orig - }, + 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 }, - leftValueExpressionSemInf = () + leftValueSemInf = () },[],False) } var = getJust $ arrayElemReferenceSemInf origArrayRef getJust (Just a) = a + getJust _ = fwdPropError $ "Internal error: ForwardPropagation/3!" varwrite = toVarWrite d defaultTr = ArrayElemReferenceLeftValue $ ArrayElemReference { - arrayElemReferenceData = recursivelyTransformedArrayElemReferenceData u, + arrayName = recursivelyTransformedArrayName u, + arrayIndex = recursivelyTransformedArrayIndex u, arrayElemReferenceSemInf = convert $ arrayElemReferenceSemInf origArrayRef } upwardsVariable self d origVar newVar = case variableSemInf origVar of @@ -330,14 +324,21 @@ 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 (recursivelyTransformedBlockData u) - transformPrimitive self d originalPrimitive u = case canDelete of - True -> EmptyProgram $ Empty () - False -> - PrimitiveProgram $ Primitive { + 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 --- a/Feldspar/Compiler/Plugins/HandlePrimitives.hs +++ b/Feldspar/Compiler/Plugins/HandlePrimitives.hs @@ -1,200 +1,229 @@ -{- - - 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. - -} +-- +-- 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, + , makePrimitive ) where +import Data.List (find) + import Feldspar.Compiler.Imperative.Representation import Feldspar.Compiler.Imperative.Semantics (SemanticInfo) -import Feldspar.Compiler.Imperative.CodeGeneration (simpleType, typeof, listprint, compToC, toLeftValue) -import Feldspar.Compiler.PluginArchitecture (TransformationPhase(..), Plugin(..), InfosFromPrimitiveParts(..)) +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 + type Downwards HandlePrimitives = (Int,Platform) type Upwards HandlePrimitives = () - transformPrimitive = transformPrimitive' + transformPrimitiveProgramInProgram = transformPrimitive' instance Plugin HandlePrimitives where - type ExternalInfo HandlePrimitives = (Int,DebugOption) - executePlugin _ (_,NoPrimitiveInstructionHandling) procedure = procedure - executePlugin _ (defArrSize,_) procedure = fst $ executeTransformationPhase HandlePrimitives defArrSize procedure + type ExternalInfo HandlePrimitives = (Int, DebugOption, Platform) + executePlugin _ (_,NoPrimitiveInstructionHandling,_) procedure = procedure + executePlugin _ (defArrSize,_,platform) procedure + = fst $ executeTransformationPhase HandlePrimitives (defArrSize,platform) + $ fst $ executeTransformationPhase HandleTraceFunctions () procedure -transformPrimitive' :: HandlePrimitives -> Int -> Primitive () -> InfosFromPrimitiveParts HandlePrimitives -> ProgramConstruction () -transformPrimitive' _ defArrSize old modified' - = case (nameS,as) of - ("(==)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "equal" "==" - ("(/=)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "not_equal" "!=" - ("(<)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "less" "<" - ("(>)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "greater" ">" - ("(<=)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "less_equal" "<=" - ("(>=)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "greater_equal" ">=" - ("not", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive PrefixOp 1 as "not" "!" - ("(&&)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "and" "&&" - ("(||)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "or" "||" - ("div", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "divide" "/" - ("rem", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "remainder" "%" - ("mod", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "mod" "" - ("(^)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "pow" "" +instance Combine Bool where + combine x y = or [x,y] - ("(.&.)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "bit_and" "&" - ("(.|.)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "bit_or" "|" - ("xor", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "bit_xor" "^" - ("complement", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive PrefixOp 1 as "bit_not" "~" - ("bit", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "bit" "" - ("setBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "setBit" "" - ("clearBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "clearBit" "" - ("complementBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "complementBit" "" - ("testBit", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "testBit" "" - ("shiftL", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "shiftL" "<<" - ("shiftR", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "shiftR" ">>" - ("rotateL", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "rotateL" "" - ("rotateR", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "rotateR" "" - -- ("shift", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "bit_shift" "" - -- ("rotate", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 2 as "bit_rotate" "" - ("bitSize", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "bitSize" "" - ("isSigned", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "isSigned" "" + - ("abs", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "abs" "" - ("signum", [InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive SimpleFun 1 as "signum" "" - ("(+)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "add" "+" - ("(-)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "sub" "-" - ("(*)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "mult" "*" - ("(/)", [InputActualParameter _, InputActualParameter _, OutputActualParameter _]) -> mkPrg $ makePrimitive InfixOp 2 as "divide" "/" +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@(InputActualParameter _), idx@(InputActualParameter _), out@(OutputActualParameter _)]) - -> mkPrg $ makeAssignment - (LeftValueExpression $ LeftValueInExpression + ("(!)", [arr, idx], [out]) + -> mkPrg $ makeAssignment pfm + (lToe $ LeftValue (ArrayElemReferenceLeftValue $ ArrayElemReference - (ArrayElemReferenceData (toLeftValue $ aToE arr) $ aToE idx) () + (toLeftValue arr) idx () ) () - ) (aToL out) defArrSize - - ("setIx", [original@(InputActualParameter _), idx@(InputActualParameter _), val@(InputActualParameter _), result@(OutputActualParameter _)]) + ) out defArrSize + + ("setIx", [original, idx, val], [result]) -> SequenceProgram $ Sequence - [ Program (PrimitiveProgram $ Primitive (makeAssignment (aToE original) (aToL result) defArrSize) ()) () - , Program (PrimitiveProgram $ Primitive - (makeAssignment - (aToE val) - (ArrayElemReferenceLeftValue $ ArrayElemReference (ArrayElemReferenceData (aToL result) $ aToE idx) ()) + [ Program (mkPrg $ makeAssignment pfm original result defArrSize) () + , Program (mkPrg $ makeAssignment pfm val + (LeftValue (ArrayElemReferenceLeftValue $ ArrayElemReference result idx ()) ()) defArrSize - ) ()) () + ) () ] () - ("copy", [in1@(InputActualParameter _), out@(OutputActualParameter _)]) - -> mkPrg $ makeAssignment (aToE in1) (aToL out) defArrSize + ("copy", [in1], [out]) -> mkPrg $ makeAssignment pfm in1 out defArrSize - _ -> mkPrg $ modified + ("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 $ procedureCallData $ (\(ProcedureCallInstruction x) -> x) $ primitiveInstruction old - as = actualParametersOfProcedureToCall $ procedureCallData $ (\(ProcedureCallInstruction x) -> x) modified + 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 :: Expression () -> LeftValue () -> Int -> Instruction () -makeAssignment in1 out defaultArraySize - | simpleType (typeof in1) = AssignmentInstruction $ Assignment (AssignmentData out in1) () - | otherwise = case (typeof in1) of - (ImpArrayType _ t) -> makePrimitive SimpleFun 2 [eToA in1, eToA $ arraySize (typeof in1) defaultArraySize, lToA out] "copy" "" - _ -> handlePrimitivesError $ "Unknown type in makeAssignment:\n" ++ show (typeof in1) +makeAssignment :: Platform -> Expression () -> LeftValue () -> Int -> Instruction () +makeAssignment pfm in1 out defArrSize = makePrimitive pfm Assig [in1] [out] defArrSize -makePrimitive :: FunctionRole -> Int -> [ActualParameter ()] -> String -> String -> Instruction () -makePrimitive primType parNum as cFunName cOpName - | simpleType (typeof out) = AssignmentInstruction $ Assignment (AssignmentData out (FunctionCallExpression funCall)) () - | otherwise = ProcedureCallInstruction procCall +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 (primType, parNum) of - (SimpleFun, 1) -> FunctionCall (FunctionCallData SimpleFun (typeof out) completeFunName [in1]) () - (SimpleFun, 2) -> FunctionCall (FunctionCallData SimpleFun (typeof out) completeFunName [in1, in2]) () - (PrefixOp, 1) -> FunctionCall (FunctionCallData PrefixOp (typeof out) cOpName [in1]) () - (InfixOp, 2) -> FunctionCall (FunctionCallData InfixOp (typeof out) cOpName [in1, in2]) () - _ -> handlePrimitivesError $ "Invalid arguments:\n" ++ show (primType, parNum) - procCall = case (primType, parNum) of - (SimpleFun, 1) -> ProcedureCall (ProcedureCallData completeProcName [in1', out']) () - (SimpleFun, 2) -> ProcedureCall (ProcedureCallData completeProcName [in1', in2', out']) () - (PrefixOp, 1) -> ProcedureCall (ProcedureCallData completeProcName [in1', out']) () - (InfixOp, 2) -> ProcedureCall (ProcedureCallData completeProcName [in1', in2', out']) () - _ -> handlePrimitivesError $ "Invalid arguments:\n" ++ show (primType, parNum) - completeFunName = cFunName ++ "_fun_" ++ toFunName (typeof in1) - completeProcName = cFunName ++ "_" ++ toFunName (typeof in1) - (in1,in1') = case (filter isInparam as) of - x:_ -> (aToE x,x) - _ -> handlePrimitivesError $ "There is not any Input parameter:\n" ++ show as - (in2,in2') = case (filter isInparam as) of - _:x:_ -> (aToE x,x) - _ -> handlePrimitivesError $ "There is not enough Input parameter:\n" ++ show as - (out,out') = case (filter (not . isInparam) as) of - x:_ -> (aToL x,x) - _ -> handlePrimitivesError $ "There is not any Output parameter:\n" ++ show as + + 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 :: Type -> String -toFunName BoolType = "bool" -toFunName FloatType = "float" -toFunName (Numeric sig siz) = listprint id "_" [compToC sig, compToC siz] -toFunName (ImpArrayType _ t@(ImpArrayType _ _)) = toFunName t -toFunName (ImpArrayType _ t) = "arrayOf_" ++ toFunName t +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 -> Expression () -arraySize a@(ImpArrayType _ t) defaultArraySize - = ConstantExpression $ IntConstant $ IntConstantType (arraySize' a) () +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 @@ -203,16 +232,24 @@ -isInparam (InputActualParameter _) = True -isInparam (OutputActualParameter _) = False +isInparam (ActualParameter (InputActualParameter _) _) = True +isInparam (ActualParameter (OutputActualParameter _) _) = False -aToE (InputActualParameter x) = inputActualParameterExpression x -aToL (OutputActualParameter x) = outputActualParameterLeftValue x --- TODO create a simple wrapper interface based on these functions +aToE (ActualParameter (InputActualParameter x) ()) = x +aToL (ActualParameter (OutputActualParameter x) ()) = x -eToA x = InputActualParameter $ InputActualParameterType x () -lToA x = OutputActualParameter $ OutputActualParameterType 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 --- a/Feldspar/Compiler/Plugins/Precompilation.hs +++ b/Feldspar/Compiler/Plugins/Precompilation.hs @@ -1,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 #-} @@ -63,30 +59,31 @@ 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 LeftValueExpressionInfo PrecompilationSemanticInfo = () - type VariableInLeftValueInfo PrecompilationSemanticInfo = () - type ArrayElemReferenceInfo PrecompilationSemanticInfo = () - type InputActualParameterInfo PrecompilationSemanticInfo = () - type OutputActualParameterInfo PrecompilationSemanticInfo = () - type AssignmentInfo PrecompilationSemanticInfo = () - type ProcedureCallInfo PrecompilationSemanticInfo = () - type FunctionCallInfo PrecompilationSemanticInfo = () - type IntConstantInfo PrecompilationSemanticInfo = () - type FloatConstantInfo PrecompilationSemanticInfo = () - type BoolConstantInfo PrecompilationSemanticInfo = () - type ArrayConstantInfo PrecompilationSemanticInfo = () - type VariableInfo PrecompilationSemanticInfo = SignatureInformation + 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 @@ -97,7 +94,7 @@ type Upwards Precompilation = () downwardsProcedure Precompilation fromAbove procedure = fromAbove { generatedImperativeParameterNames = - map (variableName . variableData . formalParameterVariable) (inParameters procedure) + map (variableName . formalParameterVariable) (inParameters procedure) } transformProcedure Precompilation fromAbove originalProcedure fromBelow = Procedure { -- NOTE: fromAbove won't have the generated imperative parameter names right here @@ -108,6 +105,7 @@ procedureSemInf = () } transformVariable = myTransformVariable + transformVariableLeftValueInLeftValue = myTransformVariableLeftValueInLeftValue getVariableName :: SignatureInformation -> String -> String getVariableName signatureInformation origname = case (originalFeldsparParameterNames signatureInformation) of @@ -127,11 +125,12 @@ myTransformVariable :: Precompilation -> SignatureInformation -> Variable () -> Variable () myTransformVariable Precompilation fromAbove v = v { - variableData = (variableData v) { - variableName = getVariableName fromAbove (variableName $ variableData 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, diff --git a/Feldspar/Compiler/Plugins/PrettyPrint.hs b/Feldspar/Compiler/Plugins/PrettyPrint.hs --- a/Feldspar/Compiler/Plugins/PrettyPrint.hs +++ b/Feldspar/Compiler/Plugins/PrettyPrint.hs @@ -1,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 #-} @@ -68,28 +64,24 @@ transformLocalDeclaration _ (_,defArrSize) _ up = LocalDeclaration { - localDeclarationData = ldd{localVariable = addDefaultArraySizes v defArrSize}, + localVariable = addDefaultArraySizes v defArrSize, + localInitValue = recursivelyTransformedLocalInitValue up, localDeclarationSemInf = () } where - ldd = recursivelyTransformedLocalDeclarationData up - v = localVariable ldd + v = recursivelyTransformedLocalVariable up instance Plugin PrettyPrint where type ExternalInfo PrettyPrint = (Platform,Int) executePlugin PrettyPrint (platform,defArrSize) procedure = fst - $ executeTransformationPhase PrettyPrint (isRestrict,defArrSize) procedure where - isRestrict = case platform of - C99 -> Restrict - _ -> NoRestrict + $ executeTransformationPhase PrettyPrint (isRestrict platform,defArrSize) procedure where addDefaultArraySizes :: (SemanticInfo t) => Variable t -> Int -> Variable t -addDefaultArraySizes v defArrSize = v{variableData = vd{variableType = addDefaultArraySizes' t}} +addDefaultArraySizes v defArrSize = v{variableType = addDefaultArraySizes' t} where - vd = variableData v - t = variableType vd + 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 --- a/Feldspar/Compiler/Plugins/PropagationUtils.hs +++ b/Feldspar/Compiler/Plugins/PropagationUtils.hs @@ -1,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 #-} @@ -36,21 +32,48 @@ import Feldspar.Compiler.PluginArchitecture import qualified Data.Map as Map ---import qualified Data.Set as Set +import qualified Data.Set as Set import qualified Data.List as List -- ======================== --- VarStatistics +-- 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 (variableName v1) $ variableName v2 + 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) --(Maybe (Expression t,[String],Bool)) + { writeVar :: Occurrence (Maybe t) , readVar :: Occurrence () } deriving (Eq,Show) @@ -66,54 +89,54 @@ 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 + 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 + 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 + 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 + 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) ) + 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 + 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 + 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 @@ -136,114 +159,128 @@ defaultValue = Occurrence_read class OccurrenceDownwards node where - occurrenceDownwards :: node -> Occurrence_place + occurrenceDownwards :: node -> Occurrence_place instance OccurrenceDownwards (Branch t) where - occurrenceDownwards _ = Occurrence_notopt --condition variable OK + occurrenceDownwards _ = Occurrence_notopt --condition variable OK instance OccurrenceDownwards (SequentialLoop t) where - occurrenceDownwards _ = Occurrence_read --condition variable OK + occurrenceDownwards _ = Occurrence_read --condition variable OK instance OccurrenceDownwards (ParallelLoop t) where - occurrenceDownwards _ = Occurrence_notopt --condition variable OK + occurrenceDownwards _ = Occurrence_notopt --condition variable OK instance OccurrenceDownwards (FormalParameter t) where - occurrenceDownwards _ = Occurrence_notopt + occurrenceDownwards _ = Occurrence_notopt instance OccurrenceDownwards (LocalDeclaration t) where - occurrenceDownwards _ = Occurrence_declare + occurrenceDownwards _ = Occurrence_declare instance OccurrenceDownwards (Assignment t) where - occurrenceDownwards _ = Occurrence_write --left OK, right is expression -instance OccurrenceDownwards (InputActualParameterType t) where - occurrenceDownwards _ = Occurrence_read -instance OccurrenceDownwards (OutputActualParameterType t) where - occurrenceDownwards _ = Occurrence_write -instance OccurrenceDownwards (LeftValueInExpression t) where - occurrenceDownwards _ = Occurrence_read -- OK -instance OccurrenceDownwards (FunctionCall t) where - occurrenceDownwards _ = Occurrence_read -- OK - - + 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 -- ======================== -instance Default [VariableData] where - defaultValue = [] - - declaredVar :: (SemanticInfo t) => LocalDeclaration t -> VariableData -declaredVar = variableData.localVariable.localDeclarationData +declaredVar = variableData.localVariable declaredVars :: (SemanticInfo t) => Block t -> [VariableData] -declaredVars block = map declaredVar $ blockDeclarations $ blockData block +declaredVars block = map declaredVar $ blockDeclarations block -delUnusedDecl :: (ConvertAllInfos via to) => [VariableData] -> Block via -> BlockData to -> Block to -delUnusedDecl unusedList origblock partiallyTransformedBlock = - Block { - blockData = BlockData { - blockDeclarations = filter (\d -> not $ List.elem (declaredVar d) unusedList) $ blockDeclarations partiallyTransformedBlock, - blockInstructions = blockInstructions partiallyTransformedBlock - }, - blockSemInf = convert $ blockSemInf origblock - } +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 () + deleteSemInf :: (SemanticInfo t) => node t -> node () instance SemInfUtils Expression where - deleteSemInf (LeftValueExpression lve) = LeftValueExpression $ lve { - leftValueExpressionContents = deleteSemInf $ leftValueExpressionContents lve, - leftValueExpressionSemInf = () - } - deleteSemInf (ConstantExpression ce) = (ConstantExpression $ deleteSemInf ce) - deleteSemInf (FunctionCallExpression fce) = FunctionCallExpression $ fce { - functionCallData = (functionCallData fce) { - actualParametersOfFunctionToCall = map deleteSemInf $ actualParametersOfFunctionToCall $ functionCallData fce - }, - functionCallSemInf = () - } + 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 (VariableLeftValue vlv) = VariableLeftValue vlv { - variableLeftValueContents = deleteSemInf $ variableLeftValueContents vlv, - variableLeftValueSemInf = () - } - deleteSemInf (ArrayElemReferenceLeftValue aer) = ArrayElemReferenceLeftValue aer { - arrayElemReferenceData = (arrayElemReferenceData aer){ - arrayName = deleteSemInf $ arrayName $ arrayElemReferenceData aer, - arrayIndex = deleteSemInf $ arrayIndex $ arrayElemReferenceData aer - }, - arrayElemReferenceSemInf = () - } + 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 = () - } + deleteSemInf var = var { + variableSemInf = () + } instance SemInfUtils ActualParameter where - deleteSemInf (InputActualParameter iap) = InputActualParameter iap { - inputActualParameterExpression = deleteSemInf $ inputActualParameterExpression iap, - inputActualParameterSemInf = () - } - deleteSemInf (OutputActualParameter oap) = OutputActualParameter oap { - outputActualParameterLeftValue = deleteSemInf $ outputActualParameterLeftValue oap, - outputActualParameterSemInf = () - } + 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 (IntConstant ic) = IntConstant ic { - intConstantSemInf = () - } - deleteSemInf (FloatConstant fc) = FloatConstant fc { - floatConstantSemInf = () - } - deleteSemInf (BoolConstant bc) = BoolConstant bc { - boolConstantSemInf = () - } - deleteSemInf (ArrayConstant ac) = ArrayConstant ac { - arrayConstantValue = map deleteSemInf $ arrayConstantValue ac, - arrayConstantSemInf = () - } + 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 --- a/Feldspar/Compiler/Plugins/Unroll.hs +++ b/Feldspar/Compiler/Plugins/Unroll.hs @@ -1,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 #-} @@ -60,8 +56,8 @@ type To Unroll_1 = UnrollSemInf type Downwards Unroll_1 = Int type Upwards Unroll_1 = Bool - upwardsParallelLoop _ _ _ _ _ = True - transformParallelLoop Unroll_1 d pl u = trParLoop1 d pl u + upwardsParallelLoopProgramInProgram _ _ _ _ _ = True + transformParallelLoopProgramInProgram Unroll_1 d pl u = trParLoop1 d pl u data Unroll_2 = Unroll_2 instance TransformationPhase Unroll_2 where @@ -73,34 +69,36 @@ | programSemInf p == Nothing = d | otherwise = programSemInf p transformVariable Unroll_2 d v = trVariable d v - transformLeftValueExpression Unroll_2 d lvie u = trLVIE d lvie u + 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 LeftValueExpressionInfo UnrollSemInf = () - type VariableInLeftValueInfo UnrollSemInf = () - type ArrayElemReferenceInfo UnrollSemInf = () - type InputActualParameterInfo UnrollSemInf = () - type OutputActualParameterInfo UnrollSemInf = () - type AssignmentInfo UnrollSemInf = () - type ProcedureCallInfo UnrollSemInf = () - type FunctionCallInfo UnrollSemInf = () - type IntConstantInfo UnrollSemInf = () - type FloatConstantInfo UnrollSemInf = () - type BoolConstantInfo UnrollSemInf = () - type ArrayConstantInfo UnrollSemInf = () - type VariableInfo UnrollSemInf = () + 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 = (||) @@ -112,57 +110,56 @@ } deriving (Eq, Show) instance Default (Maybe SemInfPrg) where defaultValue = Nothing -trLVIE d lvie u = case d of +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 - leftValue = leftValueExpressionContents $ lvie name = case leftValue of - VariableLeftValue (VariableInLeftValue d _) -> Just $ getVarName d + VariableLeftValue d -> Just $ getVarName d otherwise -> Nothing result x = case name of Just n - | n == loopVar x -> FunctionCallExpression $ FunctionCall (FunctionCallData (InfixOp) (Numeric ImpSigned S32) ("+") ([loopVarPar, plusPar])) () + | n == loopVar x -> FunctionCallExpression $ FunctionCall InfixOp (Numeric ImpSigned S32) ("+") ([loopVarPar, plusPar]) () | otherwise -> orig otherwise -> orig where - loopVarPar = orig + loopVarPar = Expression orig () num = position x - plusPar = ConstantExpression $ IntConstant $ IntConstantType num () - orig = LeftValueExpression $ LeftValueInExpression (recursivelyTransformedLeftValueExpressionContents u ) () + plusPar = Expression (ConstantExpression $ Constant (IntConstant $ IntConstantType num ()) ()) () + orig = LeftValueExpression $ LeftValue (recursivelyTransformedLeftValueData u ) () trVariable d v - | d /= Nothing && elementOf (varNames (valueFromJust d)) (getVarName v) = v { variableData = (variableData v){ variableName = (variableName $ variableData v) ++ "_u" ++ (show $ position $ valueFromJust d) },variableSemInf = ()} + | 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 (ParallelLoop trPL ()) + | otherwise = ParallelLoopProgram trPl where - newParLoop = pl { parallelLoopData = ( trPL ) - { parallelLoopStep = unrollNum - , parallelLoopCore = newLoopCore} - , parallelLoopSemInf = ()} + newParLoop = trPl { parallelLoopStep = unrollNum + , parallelLoopCore = newLoopCore + , parallelLoopSemInf = ()} newLoopCore = origLoopCore - { blockData = (blockData origLoopCore) - { blockDeclarations = unrollDecls - , blockInstructions = unrollPrg - } + { 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 $ blockData origLoopCore + 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 $ blockData origLoopCore - origLoopCore = parallelLoopCore $ trPL - iterExpr = numberOfIterations $ trPL - trPL = recursivelyTransformedParallelLoopData u + origDecls = blockDeclarations $ origLoopCore + origLoopCore = recursivelyTransformedParallelLoopCore u + iterExpr = recursivelyTransformedNumberOfIterations u + loopCounter' = recursivelyTransformedParallelLoopConditionVariable u + trPl = ParallelLoop loopCounter' iterExpr (parallelLoopStep pl) origLoopCore () unrollNum = d - loopCounter = getVarName $ parallelLoopConditionVariable trPL + loopCounter = getVarName $ recursivelyTransformedParallelLoopConditionVariable u varNames = map (\d -> getVarNameDecl d) origDecls iterTemp = iterNumFromExpr iterExpr origIterNum = valueFromJust iterTemp @@ -171,14 +168,14 @@ varInExpr = not $ isJust iterTemp -- helper functions : -iterNumFromExpr (ConstantExpression (IntConstant (IntConstantType i _))) = Just i +iterNumFromExpr (Expression (ConstantExpression (Constant (IntConstant (IntConstantType i _)) _)) _) = Just i iterNumFromExpr _ = Nothing isJust (Just x) = True isJust _ = False -getVarNameDecl d = getVarName $ localVariable $ localDeclarationData $ d -getVarName v = variableName $ variableData v +getVarNameDecl d = getVarName $ localVariable d +getVarName v = variableName v valueFromJust (Just v) = v valueFromJust Nothing = error "This was Nothing" -renameDeclaration d n = d { localDeclarationData = (localDeclarationData d) { localVariable = renameVariable (localVariable $ localDeclarationData d) n } } -renameVariable v n = v { variableData = (variableData v) { variableName = n } } +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 --- a/Feldspar/Compiler/Precompiler/Precompiler.hs +++ b/Feldspar/Compiler/Precompiler/Precompiler.hs @@ -1,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 diff --git a/Feldspar/Compiler/Standalone/Constants.hs b/Feldspar/Compiler/Standalone/Constants.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Standalone/Constants.hs @@ -0,0 +1,42 @@ +-- +-- 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Standalone/Library.hs @@ -0,0 +1,71 @@ +-- +-- 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Compiler/Standalone/Options.hs @@ -0,0 +1,151 @@ +-- +-- 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 --- a/Feldspar/Compiler/Transformation/GraphToImperative.hs +++ b/Feldspar/Compiler/Transformation/GraphToImperative.hs @@ -1,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 #-} @@ -103,17 +99,15 @@ inParameters = inputDecls, outParameters = outputDecls, procedureBody = Block { - blockData = BlockData { - blockDeclarations = localDecls, - blockInstructions = Program { - programConstruction = SequenceProgram $ Sequence { - sequenceProgramList = ( map transformNodeToProgram pairs - ++ copyToOutput (interfaceOutput ifc) (interfaceOutputType ifc) True ), - sequenceSemInf = () - }, - programSemInf = () - } - }, + blockDeclarations = localDecls, + blockInstructions = Program { + programConstruction = SequenceProgram $ Sequence { + sequenceProgramList = ( map transformNodeToProgram pairs + ++ copyToOutput (interfaceOutput ifc) (interfaceOutputType ifc) True ), + sequenceSemInf = () + }, + programSemInf = () + }, blockSemInf = () }, procedureSemInf = () @@ -126,7 +120,7 @@ outputDecls = tupleWalk transformSourceToFormalParameter $ interfaceOutputType ifc transformSourceToFormalParameter :: [Int] -> StorableType -> FormalParameter InitSemInf transformSourceToFormalParameter path typ = FormalParameter { - formalParameterVariable = Representation.Variable (VariableData FunOut ctyp (outName path)) (), + formalParameterVariable = Representation.Variable FunOut ctyp (outName path) (), formalParameterSemInf = () } where ctyp = compileStorableType typ @@ -141,7 +135,7 @@ transformNodeToFormalParameter n = tupleWalk genDecl $ tupleZip (outTyps,initVals) where genDecl path (typ,ini) = FormalParameter { - formalParameterVariable = Representation.Variable (VariableData Value ctyp (varPrefix (nodeId n) ++ varPath path)) (), + formalParameterVariable = Representation.Variable Value ctyp (varPrefix (nodeId n) ++ varPath path) (), formalParameterSemInf = () } where ctyp = compileStorableType typ @@ -157,17 +151,13 @@ transformNodeToLocalDeclaration :: Node -> [LocalDeclaration InitSemInf] transformNodeToLocalDeclaration n = tupleWalk genDecl $ tupleZip (outTyps,initVals) where genDecl path (typ,ini) = LocalDeclaration { - localDeclarationData = LocalDeclarationData { - localVariable = Representation.Variable { - variableData = VariableData { - variableRole = Value, - variableType = ctyp, - variableName = (varPrefix (nodeId n) ++ varPath path) - }, - variableSemInf = () - }, - localInitValue = ini + localVariable = Representation.Variable { + variableRole = Value, + variableType = ctyp, + variableName = (varPrefix (nodeId n) ++ varPath path), + variableSemInf = () }, + localInitValue = ini, localDeclarationSemInf = () } where ctyp = compileStorableType typ @@ -193,14 +183,15 @@ Array _ -> Program (EmptyProgram $ Empty ()) () Function s -> Program { programConstruction = PrimitiveProgram $ Primitive { - primitiveInstruction = (ProcedureCallInstruction $ ProcedureCall { - procedureCallData = ProcedureCallData { - nameOfProcedureToCall = s, - actualParametersOfProcedureToCall = passInArgs (input n) (inputType n) ++ - passOutArgs (nodeId n) (outputType n) - }, - procedureCallSemInf = () - }), + primitiveInstruction = Instruction { + instructionData = (ProcedureCallInstruction $ ProcedureCall { + nameOfProcedureToCall = s, + actualParametersOfProcedureToCall = passInArgs (input n) (inputType n) ++ + passOutArgs (nodeId n) (outputType n), + procedureCallSemInf = () + }), + instructionSemInf = () + }, primitiveSemInf = False }, programSemInf = () @@ -210,14 +201,15 @@ -- actual arguments come from the node input and the node id NoInline s ifc -> Program { programConstruction = PrimitiveProgram $ Primitive { - primitiveInstruction = (ProcedureCallInstruction $ ProcedureCall { - procedureCallData = ProcedureCallData { - nameOfProcedureToCall = s, - actualParametersOfProcedureToCall = passInArgs (input n) (inputType n) ++ - passOutArgs (nodeId n) (outputType n) - }, - procedureCallSemInf = () - }), + primitiveInstruction = Instruction { + instructionData = (ProcedureCallInstruction $ ProcedureCall { + nameOfProcedureToCall = s, + actualParametersOfProcedureToCall = passInArgs (input n) (inputType n) ++ + passOutArgs (nodeId n) (outputType n), + procedureCallSemInf = () + }), + instructionSemInf = () + }, primitiveSemInf = False }, programSemInf = () @@ -235,11 +227,9 @@ -> error "Error in 'ifThenElse' node: node output is expected to be 'Bool'." | otherwise -> Program { programConstruction = BranchProgram $ Branch { - branchData = BranchData { - branchConditionVariable = condVar, - thenBlock = mkBranch n thenIfc thenH, - elseBlock = mkBranch n elseIfc elseH - }, + branchConditionVariable = condVar, + thenBlock = mkBranch n thenIfc thenH, + elseBlock = mkBranch n elseIfc elseH, branchSemInf = () }, programSemInf = () @@ -247,23 +237,21 @@ where mkBranch :: Node -> Interface -> Hierarchy -> Block InitSemInf mkBranch n ifc h@(Hierarchy pairs) = Block { - blockData = BlockData { - 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 = () - } + 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 (VariableData Value Representation.BoolType (varName 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" @@ -282,33 +270,34 @@ (copyResult (input n) (nodeId n) (outputType n) True ++ [Program { programConstruction = SequentialLoopProgram $ SequentialLoop { - sequentialLoopData = SequentialLoopData { - sequentialLoopCondition = (case interfaceOutput condIfc of - One (Graph.Variable (id,path)) -> varToExpr $ Representation.Variable (VariableData Value Representation.BoolType (varName id path)) () - _ -> error "Error in a while loop: Malformed interface output of condition calculation." - -- TODO: should this hold? - ), - conditionCalculation = Block { - blockData = BlockData { - blockDeclarations = (transformNodeListToLocalDeclarations condNodes), - blockInstructions = Program { - programConstruction = (SequenceProgram (Sequence (copyStateToCond ++ calculationCond) ())), - programSemInf = () - } - }, - blockSemInf = () - }, - sequentialLoopCore = Block { - blockData = BlockData { - blockDeclarations = (transformNodeListToLocalDeclarations bodyNodes), - blockInstructions = Program { - programConstruction = (SequenceProgram (Sequence (copyStateToBody ++ calculationBody ++ copyResultToState) ())), - programSemInf = () - } + 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 = () }, - blockSemInf = () + 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 = () @@ -336,9 +325,9 @@ -- body: embedded graph and its interface Parallel ifc -> Program { - programConstruction = ParallelLoopProgram (ParallelLoop (ParallelLoopData - (Representation.Variable (VariableData Value (Numeric ImpSigned S32) (varName inpId [])) ()) num 1 prg - ) ()), + programConstruction = ParallelLoopProgram $ ParallelLoop + (Representation.Variable Value (Numeric ImpSigned S32) (varName inpId []) ()) num 1 prg + (), programSemInf = () } where num = case (input n, inputType n) of @@ -368,43 +357,40 @@ outTypArrayImp = compileStorableType outTypArray outTypElemImp = compileStorableType outTypElem prg = Block { - blockData = BlockData { - blockDeclarations = declarations, - blockInstructions = Program { - programConstruction = SequenceProgram $ Sequence { - sequenceProgramList = map transformNodeToProgram notInps ++ - [ Program { - programConstruction = PrimitiveProgram $ Primitive { - primitiveInstruction = makeCopyFromExprs - (transformSourceToExpr outSrc outTypElem) - (LeftValueExpression $ LeftValueInExpression { - leftValueExpressionContents = ArrayElemReferenceLeftValue $ ArrayElemReference { - arrayElemReferenceData = ArrayElemReferenceData { - arrayName = VariableLeftValue $ VariableInLeftValue { - variableLeftValueContents = Representation.Variable { - variableData = VariableData { - variableRole = Value, - variableType = outTypArrayImp, - variableName = (varName (nodeId n) []) - }, - variableSemInf = () - }, - variableLeftValueSemInf = () + 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 = () }, - arrayIndex = (genVar inpId [] intType) + leftValueSemInf = () }, + arrayIndex = (genVar inpId [] intType), arrayElemReferenceSemInf = () - }, - leftValueExpressionSemInf = () - }), - primitiveSemInf = True - }, - programSemInf = () - } ], - sequenceSemInf = () - }, - programSemInf = () - } + }), + leftValueSemInf = () + }, + expressionSemInf = () + }), + primitiveSemInf = True + }, + programSemInf = () + } ], + sequenceSemInf = () + }, + programSemInf = () }, blockSemInf = () } @@ -428,15 +414,17 @@ -- Generates a variable genVar :: NodeId -> [Int] -> Type -> Expression InitSemInf -genVar id path typ = LeftValueExpression $ LeftValueInExpression { - leftValueExpressionContents = VariableLeftValue $ VariableInLeftValue { - variableLeftValueContents = Representation.Variable { - variableData = VariableData { variableRole = Value, variableType = typ, variableName = (varName id path) }, +genVar id path typ = Expression { + expressionData = LeftValueExpression $ LeftValue { + leftValueData = VariableLeftValue $ Representation.Variable { + variableRole = Value, + variableType = typ, + variableName = (varName id path), variableSemInf = () }, - variableLeftValueSemInf = () + leftValueSemInf = () }, - leftValueExpressionSemInf = () + expressionSemInf = () } -- Prefix of output parameters @@ -449,35 +437,37 @@ -- Generates an output variable genOut :: [Int] -> Type -> Expression InitSemInf -genOut path typ =LeftValueExpression $ LeftValueInExpression { - leftValueExpressionContents = VariableLeftValue $ VariableInLeftValue { - variableLeftValueContents = Representation.Variable { - variableData = VariableData { variableRole = FunOut, variableType = typ, variableName = (outName path) }, +genOut path typ = Expression { + expressionData = LeftValueExpression $ LeftValue { + leftValueData = VariableLeftValue $ Representation.Variable { + variableRole = FunOut, + variableType = typ, + variableName = (outName path), variableSemInf = () }, - variableLeftValueSemInf = () + leftValueSemInf = () }, - leftValueExpressionSemInf = () -} + 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 _ (Constant primData, StorableType _ typ) = InputActualParameter $ InputActualParameterType { - inputActualParameterExpression = compilePrimData primData typ, - inputActualParameterSemInf = () + genArg _ (Graph.Constant primData, StorableType _ typ) = ActualParameter { + actualParameterData = InputActualParameter $ compilePrimData primData typ, + actualParameterSemInf = () } - genArg _ (Graph.Variable (id, path), typ) = InputActualParameter $ InputActualParameterType { - inputActualParameterExpression = genVar id path (compileStorableType typ), - inputActualParameterSemInf = () + 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 = OutputActualParameter $ OutputActualParameterType { - outputActualParameterLeftValue = toLeftValue $ genVar id path (compileStorableType t), - outputActualParameterSemInf = () + genArg path t = ActualParameter { + actualParameterData = OutputActualParameter $ toLeftValue $ genVar id path (compileStorableType t), + actualParameterSemInf = () } ------------------------------------------------- @@ -508,34 +498,50 @@ 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) = ArrayConstant $ ArrayConstantType (map compileStorableDataToConst ds) () +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 ()) = BoolConstant $ BoolConstantType False () -compilePrimDataToConst (BoolData x) = BoolConstant $ BoolConstantType x () -compilePrimDataToConst (IntData x) = IntConstant $ IntConstantType (fromInteger x) () -compilePrimDataToConst (FloatData x) = FloatConstant $ FloatConstantType x () -- TODO +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 = (ConstantExpression $ compileStorableDataToConst a) +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 = ConstantExpression $ compilePrimDataToConst d +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 (Constant primData) (StorableType _ typ) = compilePrimData primData typ +transformSourceToExpr (Graph.Constant primData) (StorableType _ typ) = compilePrimData primData typ transformSourceToExpr (Graph.Variable (id,path)) typ = genVar id path ctyp where ctyp = compileStorableType typ @@ -552,18 +558,22 @@ -- Generates a copy call from two expressions. makeCopyFromExprs :: Expression InitSemInf -> Expression InitSemInf -> Instruction InitSemInf -makeCopyFromExprs from to = ProcedureCallInstruction $ - ProcedureCall { - procedureCallData = ProcedureCallData "copy" [InputActualParameter $ InputActualParameterType { - inputActualParameterExpression = from, - inputActualParameterSemInf = () - }, - OutputActualParameter $ OutputActualParameterType { - outputActualParameterLeftValue = (toLeftValue to), - outputActualParameterSemInf = () - }], +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] @@ -601,10 +611,10 @@ tupleWalk (\path (out,typ) -> Program { - programConstruction = PrimitiveProgram (Primitive { + programConstruction = PrimitiveProgram $ Primitive { primitiveInstruction = (makeCopyFromExprs (transformSourceToExpr out typ) (genOut path $ compileStorableType typ)), primitiveSemInf = isOutputCopying - }), + }, programSemInf = () } ) @@ -612,10 +622,10 @@ varToExpr :: Representation.Variable InitSemInf -> Expression InitSemInf -varToExpr v = - LeftValueExpression - (LeftValueInExpression - (VariableLeftValue $ - VariableInLeftValue v() ) - () - ) +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 --- a/Feldspar/Compiler/Transformation/GraphUtils.hs +++ b/Feldspar/Compiler/Transformation/GraphUtils.hs @@ -1,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 #-} diff --git a/Feldspar/Compiler/Transformation/Lifting.hs b/Feldspar/Compiler/Transformation/Lifting.hs --- a/Feldspar/Compiler/Transformation/Lifting.hs +++ b/Feldspar/Compiler/Transformation/Lifting.hs @@ -1,34 +1,30 @@ -{- - - 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. - -} +-- +-- 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 #-} diff --git a/Feldspar/Fs2dot.hs b/Feldspar/Fs2dot.hs --- a/Feldspar/Fs2dot.hs +++ b/Feldspar/Fs2dot.hs @@ -1,270 +1,266 @@ -{- - - 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. - -} +-- +-- 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 - +-- |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/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,31 @@ -module Main (main) where +-- +-- 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 :: IO () main = defaultMain diff --git a/feldspar-compiler.cabal b/feldspar-compiler.cabal --- a/feldspar-compiler.cabal +++ b/feldspar-compiler.cabal @@ -1,6 +1,6 @@ name: feldspar-compiler -version: 0.2.1 -cabal-version: >= 1.2.3 +version: 0.3 +cabal-version: >= 1.6 build-type: Simple license: BSD3 license-file: LICENSE @@ -9,7 +9,7 @@ Eotvos Lorand University Faculty of Informatics maintainer: deva@inf.elte.hu stability: experimental -homepage: http://feldspar.sourceforge.net/ +homepage: http://feldspar.inf.elte.hu/feldspar/ synopsis: Compiler for the Feldspar language description: Feldspar (**F**unctional **E**mbedded **L**anguage for **DSP** and **PAR**allelism) is an embedded DSL for describing digital @@ -28,7 +28,6 @@ Feldspar.Compiler.Imperative.Semantics Feldspar.Compiler.PluginArchitecture.DefaultConvert Feldspar.Compiler.Plugins.BackwardPropagation - Feldspar.Compiler.Plugins.ConstantFolding Feldspar.Compiler.Plugins.ForwardPropagation Feldspar.Compiler.Plugins.HandlePrimitives Feldspar.Compiler.Plugins.Precompilation @@ -42,13 +41,14 @@ Feldspar.Compiler.Compiler Feldspar.Compiler.Error Feldspar.Compiler.Options + Feldspar.Compiler.Platforms Feldspar.Compiler.PluginArchitecture Feldspar.Compiler Feldspar.Fs2dot build-depends: - feldspar-language == 0.2, - base >= 4.0 && < 4.2, + feldspar-language == 0.3, + base >= 4 && < 4.3, containers, haskell-src-exts, directory, @@ -72,11 +72,21 @@ ./Feldspar/C install-includes: - feldspar.h - feldspar.c + feldspar_c99.h + feldspar_c99.c + feldspar_tic64x.h + feldspar_tic64x.c executable feldspar main-is : ./Feldspar/Compiler/CompilerMain.hs + + other-modules: + Feldspar.Compiler.Standalone.Constants + Feldspar.Compiler.Standalone.Library + Feldspar.Compiler.Standalone.Options + + build-depends: + ansi-terminal extensions: CPP