├── tests ├── gold │ ├── not1.c │ ├── not1_ret.c │ ├── pairParam.c │ ├── noinline1.c │ ├── pairParam_ret.c │ ├── foreignEffect.c │ ├── example9.c │ ├── switcher.c │ ├── topLevelConsts.c │ ├── issue128_ex1.c │ ├── topLevelConsts_sics.c │ ├── issue128_ex2.c │ ├── topLevelConsts_native.c │ ├── pairParam2.c │ ├── not1.h │ ├── not1_ret.h │ ├── tuples.h │ ├── example9.h │ ├── issue128_ex3.c │ ├── foreignEffect.h │ ├── switcher.h │ ├── issue128_ex1.h │ ├── issue128_ex2.h │ ├── issue128_ex3.h │ ├── topLevelConsts.h │ ├── noinline1.h │ ├── fut1.h │ ├── topLevelConsts_sics.h │ ├── topLevelConsts_native.h │ ├── fut1_ret.h │ ├── ivartest.h │ ├── pairParam.h │ ├── pairParam_ret.h │ ├── complexWhileCond.h │ ├── fut1.c │ ├── arrayInStructInStruct.c │ ├── fut1_ret.c │ ├── ivartest.c │ ├── concatV.h │ ├── concatVM.h │ ├── arrayInStruct.h │ ├── complexWhileCond.c │ ├── ivartest2.h │ ├── ivartest2.c │ ├── arrayInStruct_openMP.h │ ├── arrayInStruct_wool.h │ ├── pairParam2.h │ ├── divConq3.h │ ├── scanlPush.h │ ├── arrayInStructInStruct.h │ ├── concatVM.c │ ├── metrics.h │ ├── arrayInStruct.c │ ├── concatV.c │ ├── arrayInStruct_openMP.c │ ├── tuples.c │ ├── arrayInStruct_wool.c │ ├── deepArrayCopy.h │ ├── scanlPush.c │ ├── metrics.c │ ├── divConq3.c │ └── deepArrayCopy.c └── CallingConvention.hs ├── benchs ├── MatMulC.h ├── BenchmarkUtils.hs ├── MatMulC.c ├── FFT.hs ├── FIR_Fusion.hs ├── CRC.hs └── MatMul.hs ├── .gitignore ├── README.md ├── src └── Feldspar │ ├── Compiler.hs │ ├── Runtime.hs │ └── Compiler │ ├── CallConv.hs │ ├── Error.hs │ ├── ExternalProgram.hs │ ├── Backend │ └── C │ │ ├── Library.hs │ │ ├── Options.hs │ │ ├── Tic64x.hs │ │ ├── Platforms.hs │ │ └── MachineLowering.hs │ ├── Marshal.hs │ ├── Plugin.hs │ ├── Compiler.hs │ ├── Frontend │ └── Interactive │ │ └── Interface.hs │ └── Imperative │ └── ArrayOps.hs ├── clib ├── feldspar_future.h ├── log.h ├── ivar.h ├── feldspar_array.h ├── taskpool.c ├── ivar.c └── taskpool.h ├── LICENSE ├── .travis.yml ├── Setup.hs └── feldspar-compiler.cabal /tests/gold/not1.c: -------------------------------------------------------------------------------- 1 | #include "not1.h" 2 | 3 | 4 | void not1(bool v0, bool * out) 5 | { 6 | *out = !(v0); 7 | } 8 | -------------------------------------------------------------------------------- /tests/gold/not1_ret.c: -------------------------------------------------------------------------------- 1 | #include "not1_ret.h" 2 | 3 | 4 | bool not1__ret(bool v0) 5 | { 6 | bool out; 7 | 8 | out = !(v0); 9 | return(out); 10 | } 11 | -------------------------------------------------------------------------------- /tests/gold/pairParam.c: -------------------------------------------------------------------------------- 1 | #include "pairParam.h" 2 | 3 | 4 | void pairParam(struct s_2_unsignedS32_unsignedS32 * v0, uint32_t * out) 5 | { 6 | *out = (*v0).member1; 7 | } 8 | -------------------------------------------------------------------------------- /benchs/MatMulC.h: -------------------------------------------------------------------------------- 1 | #ifndef _MATMULC_ 2 | #define _MATMULC_ 3 | 4 | void MatMulC(int, int, double *, double *, double *); 5 | 6 | void MatMulCopt(int, int, double *, double *, double *); 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /tests/gold/noinline1.c: -------------------------------------------------------------------------------- 1 | #include "noinline1.h" 2 | 3 | 4 | void noinline0(bool v0, bool * out) 5 | { 6 | *out = !(v0); 7 | } 8 | 9 | void noinline1(bool v0, bool * out) 10 | { 11 | noinline0(v0, out); 12 | } 13 | -------------------------------------------------------------------------------- /tests/gold/pairParam_ret.c: -------------------------------------------------------------------------------- 1 | #include "pairParam_ret.h" 2 | 3 | 4 | uint32_t pairParam__ret(struct s_2_unsignedS32_unsignedS32 * v0) 5 | { 6 | uint32_t out; 7 | 8 | out = (*v0).member1; 9 | return(out); 10 | } 11 | -------------------------------------------------------------------------------- /tests/gold/foreignEffect.c: -------------------------------------------------------------------------------- 1 | #include "foreignEffect.h" 2 | 3 | 4 | void foreignEffect(void * out) 5 | { 6 | float v77; 7 | 8 | alert(); 9 | v77 = getPos(); 10 | launchMissiles(v77); 11 | *out = cleanUp(); 12 | } 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | 18 | tests/*.[hc] 19 | tmp 20 | -------------------------------------------------------------------------------- /tests/gold/example9.c: -------------------------------------------------------------------------------- 1 | #include "example9.h" 2 | 3 | 4 | void example9(int32_t v0, int32_t * out) 5 | { 6 | int32_t v2; 7 | 8 | v2 = (v0 + 20); 9 | if ((v0 < 5)) 10 | { 11 | *out = (3 * v2); 12 | } 13 | else 14 | { 15 | *out = (30 * v2); 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /tests/gold/switcher.c: -------------------------------------------------------------------------------- 1 | #include "switcher.h" 2 | 3 | 4 | void switcher(uint8_t v0, bool v1, uint8_t * out) 5 | { 6 | switch (v1) 7 | { 8 | case true: 9 | *out = v0; 10 | break; 11 | case false: 12 | *out = 2; 13 | break; 14 | default: 15 | *out = 0; 16 | break; 17 | } 18 | } 19 | -------------------------------------------------------------------------------- /tests/gold/topLevelConsts.c: -------------------------------------------------------------------------------- 1 | #include "topLevelConsts.h" 2 | 3 | 4 | void topLevelConsts(uint32_t v1, uint32_t v2, uint32_t * out) 5 | { 6 | uint32_t v5; 7 | 8 | v5 = (v2 + 5); 9 | if ((v1 < 5)) 10 | { 11 | *out = ((uint32_t[]){2, 3, 4, 5, 6})[v5]; 12 | } 13 | else 14 | { 15 | *out = ((uint32_t[]){1, 2, 3, 4, 5})[v5]; 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /tests/gold/issue128_ex1.c: -------------------------------------------------------------------------------- 1 | #include "issue128_ex1.h" 2 | 3 | 4 | void issue128__ex1(uint32_t v0, uint32_t * out) 5 | { 6 | bool v1; 7 | 8 | v1 = (1 == v0); 9 | if (v1) 10 | { 11 | if (v1) 12 | { 13 | *out = 10; 14 | } 15 | else 16 | { 17 | *out = 45; 18 | } 19 | } 20 | else 21 | { 22 | *out = v0; 23 | } 24 | } 25 | -------------------------------------------------------------------------------- /tests/gold/topLevelConsts_sics.c: -------------------------------------------------------------------------------- 1 | #include "topLevelConsts_sics.h" 2 | 3 | 4 | void topLevelConsts__sics(uint32_t v1, uint32_t v2, uint32_t * out) 5 | { 6 | uint32_t v5; 7 | 8 | v5 = (v2 + 5); 9 | if ((v1 < 5)) 10 | { 11 | *out = ((uint32_t[]){2, 3, 4, 5, 6})[v5]; 12 | } 13 | else 14 | { 15 | *out = ((uint32_t[]){1, 2, 3, 4, 5})[v5]; 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /tests/gold/issue128_ex2.c: -------------------------------------------------------------------------------- 1 | #include "issue128_ex2.h" 2 | 3 | 4 | void issue128__ex2(uint32_t v0, uint32_t * out) 5 | { 6 | if ((2 == v0)) 7 | { 8 | switch (v0) 9 | { 10 | case 1: 11 | *out = 20; 12 | break; 13 | default: 14 | *out = 45; 15 | break; 16 | } 17 | } 18 | else 19 | { 20 | *out = v0; 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /tests/gold/topLevelConsts_native.c: -------------------------------------------------------------------------------- 1 | #include "topLevelConsts_native.h" 2 | 3 | 4 | void topLevelConsts__native(uint32_t v1, uint32_t v2, uint32_t * out) 5 | { 6 | uint32_t v5; 7 | 8 | v5 = (v2 + 5); 9 | if ((v1 < 5)) 10 | { 11 | *out = ((uint32_t[]){2, 3, 4, 5, 6})[v5]; 12 | } 13 | else 14 | { 15 | *out = ((uint32_t[]){1, 2, 3, 4, 5})[v5]; 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /tests/gold/pairParam2.c: -------------------------------------------------------------------------------- 1 | #include "pairParam2.h" 2 | 3 | 4 | void pairParam2(struct s_2_signedS16_signedS16 * v0, struct s_2_s_2_signedS16_signedS16_s_2_signedS16_signedS16 * out) 5 | { 6 | ((*out).member1).member1 = (*v0).member1; 7 | ((*out).member1).member2 = (*v0).member2; 8 | ((*out).member2).member1 = (*v0).member1; 9 | ((*out).member2).member2 = (*v0).member2; 10 | } 11 | -------------------------------------------------------------------------------- /tests/gold/not1.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_NOT1_H 2 | #define TESTS_NOT1_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void not1(bool v0, bool * out); 17 | 18 | #endif // TESTS_NOT1_H 19 | -------------------------------------------------------------------------------- /tests/gold/not1_ret.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_NOT1_RET_H 2 | #define TESTS_NOT1_RET_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | bool not1__ret(bool v0); 17 | 18 | #endif // TESTS_NOT1_RET_H 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Feldspar Compiler 2 | ================= 3 | 4 | [![Build Status](https://travis-ci.org/Feldspar/feldspar-compiler.svg?branch=master)](https://travis-ci.org/Feldspar/feldspar-compiler) 5 | 6 | This is the compiler for the Feldspar Language. 7 | 8 | The goal of the Feldspar project is to define a high-level language that 9 | allows description of high-performance digital signal processing 10 | algorithms. 11 | 12 | 13 | -------------------------------------------------------------------------------- /tests/gold/tuples.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_TUPLES_H 2 | #define TESTS_TUPLES_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void tuples(int32_t v0, int32_t * out); 17 | 18 | #endif // TESTS_TUPLES_H 19 | -------------------------------------------------------------------------------- /tests/gold/example9.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_EXAMPLE9_H 2 | #define TESTS_EXAMPLE9_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void example9(int32_t v0, int32_t * out); 17 | 18 | #endif // TESTS_EXAMPLE9_H 19 | -------------------------------------------------------------------------------- /tests/gold/issue128_ex3.c: -------------------------------------------------------------------------------- 1 | #include "issue128_ex3.h" 2 | 3 | 4 | void issue128__ex3(uint32_t v0, uint32_t * out) 5 | { 6 | uint32_t e1; 7 | uint32_t e2; 8 | 9 | switch (v0) 10 | { 11 | case 1: 12 | e1 = 10; 13 | break; 14 | default: 15 | e1 = 45; 16 | break; 17 | } 18 | if ((2 == v0)) 19 | { 20 | e2 = 2; 21 | } 22 | else 23 | { 24 | e2 = v0; 25 | } 26 | *out = (e1 + e2); 27 | } 28 | -------------------------------------------------------------------------------- /tests/gold/foreignEffect.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_FOREIGNEFFECT_H 2 | #define TESTS_FOREIGNEFFECT_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void foreignEffect(void * out); 17 | 18 | #endif // TESTS_FOREIGNEFFECT_H 19 | -------------------------------------------------------------------------------- /tests/gold/switcher.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_SWITCHER_H 2 | #define TESTS_SWITCHER_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void switcher(uint8_t v0, bool v1, uint8_t * out); 17 | 18 | #endif // TESTS_SWITCHER_H 19 | -------------------------------------------------------------------------------- /tests/gold/issue128_ex1.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_ISSUE128_EX1_H 2 | #define TESTS_ISSUE128_EX1_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void issue128__ex1(uint32_t v0, uint32_t * out); 17 | 18 | #endif // TESTS_ISSUE128_EX1_H 19 | -------------------------------------------------------------------------------- /tests/gold/issue128_ex2.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_ISSUE128_EX2_H 2 | #define TESTS_ISSUE128_EX2_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void issue128__ex2(uint32_t v0, uint32_t * out); 17 | 18 | #endif // TESTS_ISSUE128_EX2_H 19 | -------------------------------------------------------------------------------- /tests/gold/issue128_ex3.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_ISSUE128_EX3_H 2 | #define TESTS_ISSUE128_EX3_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void issue128__ex3(uint32_t v0, uint32_t * out); 17 | 18 | #endif // TESTS_ISSUE128_EX3_H 19 | -------------------------------------------------------------------------------- /tests/gold/topLevelConsts.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_TOPLEVELCONSTS_H 2 | #define TESTS_TOPLEVELCONSTS_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void topLevelConsts(uint32_t v1, uint32_t v2, uint32_t * out); 17 | 18 | #endif // TESTS_TOPLEVELCONSTS_H 19 | -------------------------------------------------------------------------------- /tests/gold/noinline1.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_NOINLINE1_H 2 | #define TESTS_NOINLINE1_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void noinline0(bool v0, bool * out); 17 | 18 | void noinline1(bool v0, bool * out); 19 | 20 | #endif // TESTS_NOINLINE1_H 21 | -------------------------------------------------------------------------------- /tests/gold/fut1.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_FUT1_H 2 | #define TESTS_FUT1_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void task_core0(struct ivar e3); 17 | 18 | void task0(void * params); 19 | 20 | void fut1(struct ivar v0, struct ivar * out); 21 | 22 | #endif // TESTS_FUT1_H 23 | -------------------------------------------------------------------------------- /tests/gold/topLevelConsts_sics.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_TOPLEVELCONSTS_SICS_H 2 | #define TESTS_TOPLEVELCONSTS_SICS_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void topLevelConsts__sics(uint32_t v1, uint32_t v2, uint32_t * out); 17 | 18 | #endif // TESTS_TOPLEVELCONSTS_SICS_H 19 | -------------------------------------------------------------------------------- /tests/gold/topLevelConsts_native.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_TOPLEVELCONSTS_NATIVE_H 2 | #define TESTS_TOPLEVELCONSTS_NATIVE_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void topLevelConsts__native(uint32_t v1, uint32_t v2, uint32_t * out); 17 | 18 | #endif // TESTS_TOPLEVELCONSTS_NATIVE_H 19 | -------------------------------------------------------------------------------- /tests/gold/fut1_ret.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_FUT1_RET_H 2 | #define TESTS_FUT1_RET_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void task_core0(struct ivar e3); 17 | 18 | void task0(void * params); 19 | 20 | void fut1__ret(struct ivar v0, struct ivar * out); 21 | 22 | #endif // TESTS_FUT1_RET_H 23 | -------------------------------------------------------------------------------- /tests/gold/ivartest.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_IVARTEST_H 2 | #define TESTS_IVARTEST_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | void task_core0(uint32_t v0, struct ivar e2); 17 | 18 | void task0(void * params); 19 | 20 | void ivartest(uint32_t v0, uint32_t * out); 21 | 22 | #endif // TESTS_IVARTEST_H 23 | -------------------------------------------------------------------------------- /tests/gold/pairParam.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_PAIRPARAM_H 2 | #define TESTS_PAIRPARAM_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct s_2_unsignedS32_unsignedS32 17 | { 18 | uint32_t member1; 19 | uint32_t member2; 20 | }; 21 | 22 | void pairParam(struct s_2_unsignedS32_unsignedS32 * v0, uint32_t * out); 23 | 24 | #endif // TESTS_PAIRPARAM_H 25 | -------------------------------------------------------------------------------- /tests/gold/pairParam_ret.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_PAIRPARAM_RET_H 2 | #define TESTS_PAIRPARAM_RET_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct s_2_unsignedS32_unsignedS32 17 | { 18 | uint32_t member1; 19 | uint32_t member2; 20 | }; 21 | 22 | uint32_t pairParam__ret(struct s_2_unsignedS32_unsignedS32 * v0); 23 | 24 | #endif // TESTS_PAIRPARAM_RET_H 25 | -------------------------------------------------------------------------------- /tests/gold/complexWhileCond.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_COMPLEXWHILECOND_H 2 | #define TESTS_COMPLEXWHILECOND_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct s_2_signedS32_signedS32 17 | { 18 | int32_t member1; 19 | int32_t member2; 20 | }; 21 | 22 | void complexWhileCond(int32_t v0, struct s_2_signedS32_signedS32 * out); 23 | 24 | #endif // TESTS_COMPLEXWHILECOND_H 25 | -------------------------------------------------------------------------------- /tests/gold/fut1.c: -------------------------------------------------------------------------------- 1 | #include "fut1.h" 2 | 3 | 4 | void task_core0(struct ivar e3) 5 | { 6 | int32_t e4; 7 | 8 | ivar_get(int32_t, &e4, e3); 9 | ivar_put(int32_t, e3, &e4); 10 | } 11 | 12 | void task0(void * params) 13 | { 14 | run1(task_core0, struct ivar); 15 | } 16 | 17 | void fut1(struct ivar v0, struct ivar * out) 18 | { 19 | struct ivar e3; 20 | 21 | taskpool_init(4, 4, 4); 22 | e3 = *out; 23 | e3 = v0; 24 | for (uint32_t v1 = 0; v1 < 20; v1 += 1) 25 | { 26 | ivar_init(&e3); 27 | spawn1(task0, struct ivar, e3); 28 | } 29 | *out = e3; 30 | taskpool_shutdown(); 31 | } 32 | -------------------------------------------------------------------------------- /tests/gold/arrayInStructInStruct.c: -------------------------------------------------------------------------------- 1 | #include "arrayInStructInStruct.h" 2 | 3 | 4 | void arrayInStructInStruct(struct s_2_unsignedS32_s_2_unsignedS32_awl_unsignedS32 * v0, struct s_2_unsignedS32_s_2_unsignedS32_awl_unsignedS32 * out) 5 | { 6 | (*out).member1 = (*v0).member1; 7 | ((*out).member2).member1 = ((*v0).member2).member1; 8 | (((*out).member2).member2).buffer = initCopyArray((((*out).member2).member2).buffer, (((*out).member2).member2).length, sizeof(uint32_t), (((*v0).member2).member2).buffer, (((*v0).member2).member2).length); 9 | (((*out).member2).member2).length = (((*v0).member2).member2).length; 10 | } 11 | -------------------------------------------------------------------------------- /tests/gold/fut1_ret.c: -------------------------------------------------------------------------------- 1 | #include "fut1_ret.h" 2 | 3 | 4 | void task_core0(struct ivar e3) 5 | { 6 | int32_t e4; 7 | 8 | ivar_get(int32_t, &e4, e3); 9 | ivar_put(int32_t, e3, &e4); 10 | } 11 | 12 | void task0(void * params) 13 | { 14 | run1(task_core0, struct ivar); 15 | } 16 | 17 | void fut1__ret(struct ivar v0, struct ivar * out) 18 | { 19 | struct ivar e3; 20 | 21 | taskpool_init(4, 4, 4); 22 | e3 = *out; 23 | e3 = v0; 24 | for (uint32_t v1 = 0; v1 < 20; v1 += 1) 25 | { 26 | ivar_init(&e3); 27 | spawn1(task0, struct ivar, e3); 28 | } 29 | *out = e3; 30 | taskpool_shutdown(); 31 | } 32 | -------------------------------------------------------------------------------- /tests/gold/ivartest.c: -------------------------------------------------------------------------------- 1 | #include "ivartest.h" 2 | 3 | 4 | void task_core0(uint32_t v0, struct ivar e2) 5 | { 6 | uint32_t e3; 7 | 8 | e3 = (v0 + 1); 9 | ivar_put(uint32_t, e2, &e3); 10 | } 11 | 12 | void task0(void * params) 13 | { 14 | run2(task_core0, uint32_t, struct ivar); 15 | } 16 | 17 | void ivartest(uint32_t v0, uint32_t * out) 18 | { 19 | uint32_t e1; 20 | struct ivar e2; 21 | 22 | taskpool_init(4, 4, 4); 23 | ivar_init(&e2); 24 | spawn2(task0, uint32_t, v0, struct ivar, e2); 25 | ivar_get_nontask(uint32_t, &e1, e2); 26 | *out = (e1 << 1); 27 | taskpool_shutdown(); 28 | ivar_destroy(&e2); 29 | } 30 | -------------------------------------------------------------------------------- /tests/gold/concatV.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_CONCATV_H 2 | #define TESTS_CONCATV_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct awl_signedS32 17 | { 18 | int32_t * buffer; 19 | uint32_t length; 20 | }; 21 | 22 | struct awl_awl_signedS32 23 | { 24 | struct awl_signedS32 * buffer; 25 | uint32_t length; 26 | }; 27 | 28 | void concatV(struct awl_awl_signedS32 * v1, struct awl_signedS32 * out); 29 | 30 | #endif // TESTS_CONCATV_H 31 | -------------------------------------------------------------------------------- /tests/gold/concatVM.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_CONCATVM_H 2 | #define TESTS_CONCATVM_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct awl_signedS32 17 | { 18 | int32_t * buffer; 19 | uint32_t length; 20 | }; 21 | 22 | struct awl_awl_signedS32 23 | { 24 | struct awl_signedS32 * buffer; 25 | uint32_t length; 26 | }; 27 | 28 | void concatVM(struct awl_awl_signedS32 * v1, struct awl_signedS32 * out); 29 | 30 | #endif // TESTS_CONCATVM_H 31 | -------------------------------------------------------------------------------- /tests/gold/arrayInStruct.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_ARRAYINSTRUCT_H 2 | #define TESTS_ARRAYINSTRUCT_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct awl_unsignedS32 17 | { 18 | uint32_t * buffer; 19 | uint32_t length; 20 | }; 21 | 22 | struct s_2_unsignedS32_awl_unsignedS32 23 | { 24 | uint32_t member1; 25 | struct awl_unsignedS32 member2; 26 | }; 27 | 28 | void arrayInStruct(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * out); 29 | 30 | #endif // TESTS_ARRAYINSTRUCT_H 31 | -------------------------------------------------------------------------------- /tests/gold/complexWhileCond.c: -------------------------------------------------------------------------------- 1 | #include "complexWhileCond.h" 2 | 3 | 4 | void complexWhileCond(int32_t v0, struct s_2_signedS32_signedS32 * out) 5 | { 6 | struct s_2_signedS32_signedS32 e10 = { 0 }; 7 | struct s_2_signedS32_signedS32 v9 = { 0 }; 8 | int32_t v3; 9 | int32_t v5; 10 | bool v2; 11 | 12 | (e10).member1 = 0; 13 | (e10).member2 = v0; 14 | v3 = (e10).member1; 15 | v5 = ((e10).member2 - v3); 16 | v2 = ((v3 * v3) != (v5 * v5)); 17 | while (v2) 18 | { 19 | (v9).member1 = ((e10).member1 + 1); 20 | (v9).member2 = (e10).member2; 21 | e10 = v9; 22 | v3 = (e10).member1; 23 | v5 = ((e10).member2 - v3); 24 | v2 = ((v3 * v3) != (v5 * v5)); 25 | } 26 | *out = e10; 27 | } 28 | -------------------------------------------------------------------------------- /tests/gold/ivartest2.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_IVARTEST2_H 2 | #define TESTS_IVARTEST2_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct s_2_unsignedS32_unsignedS32 17 | { 18 | uint32_t member1; 19 | uint32_t member2; 20 | }; 21 | 22 | void task_core0(struct s_2_unsignedS32_unsignedS32 * v0, struct ivar e1); 23 | 24 | void task0(void * params); 25 | 26 | void ivartest2(struct s_2_unsignedS32_unsignedS32 * v0, struct s_2_unsignedS32_unsignedS32 * out); 27 | 28 | #endif // TESTS_IVARTEST2_H 29 | -------------------------------------------------------------------------------- /tests/gold/ivartest2.c: -------------------------------------------------------------------------------- 1 | #include "ivartest2.h" 2 | 3 | 4 | void task_core0(struct s_2_unsignedS32_unsignedS32 * v0, struct ivar e1) 5 | { 6 | ivar_put(struct s_2_unsignedS32_unsignedS32, e1, &*v0); 7 | } 8 | 9 | void task0(void * params) 10 | { 11 | run2(task_core0, struct s_2_unsignedS32_unsignedS32 *, struct ivar); 12 | } 13 | 14 | void ivartest2(struct s_2_unsignedS32_unsignedS32 * v0, struct s_2_unsignedS32_unsignedS32 * out) 15 | { 16 | struct ivar e1; 17 | 18 | taskpool_init(4, 4, 4); 19 | ivar_init(&e1); 20 | spawn2(task0, struct s_2_unsignedS32_unsignedS32 *, v0, struct ivar, e1); 21 | ivar_get_nontask(struct s_2_unsignedS32_unsignedS32, &*out, e1); 22 | taskpool_shutdown(); 23 | ivar_destroy(&e1); 24 | } 25 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler.hs: -------------------------------------------------------------------------------- 1 | module Feldspar.Compiler 2 | ( compile 3 | , compileUT 4 | , icompile 5 | , icompileWith 6 | , icompile' 7 | , program 8 | , programOpts 9 | , programOptsArgs 10 | , getCore 11 | , printCore 12 | , Options(..) 13 | , defaultOptions 14 | , sicsOptions 15 | , sicsOptions2 16 | , sicsOptions3 17 | , FeldOpts(..) 18 | , Target(..) 19 | , c99PlatformOptions 20 | , c99OpenMpPlatformOptions 21 | , tic64xPlatformOptions 22 | ) where 23 | 24 | import Feldspar.Compiler.Backend.C.Options 25 | import Feldspar.Compiler.Compiler 26 | import Feldspar.Compiler.Frontend.Interactive.Interface 27 | import Feldspar.Core.Interpretation (FeldOpts(..), Target(..)) 28 | -------------------------------------------------------------------------------- /tests/gold/arrayInStruct_openMP.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_ARRAYINSTRUCT_OPENMP_H 2 | #define TESTS_ARRAYINSTRUCT_OPENMP_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct awl_unsignedS32 17 | { 18 | uint32_t * buffer; 19 | uint32_t length; 20 | }; 21 | 22 | struct s_2_unsignedS32_awl_unsignedS32 23 | { 24 | uint32_t member1; 25 | struct awl_unsignedS32 member2; 26 | }; 27 | 28 | void arrayInStruct__openMP(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * out); 29 | 30 | #endif // TESTS_ARRAYINSTRUCT_OPENMP_H 31 | -------------------------------------------------------------------------------- /tests/gold/arrayInStruct_wool.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_ARRAYINSTRUCT_WOOL_H 2 | #define TESTS_ARRAYINSTRUCT_WOOL_H 3 | 4 | #include "wool.h" 5 | #include "feldspar_c99.h" 6 | #include "feldspar_array.h" 7 | #include "feldspar_future.h" 8 | #include "ivar.h" 9 | #include "taskpool.h" 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | 16 | 17 | struct awl_unsignedS32 18 | { 19 | uint32_t * buffer; 20 | uint32_t length; 21 | }; 22 | 23 | struct s_2_unsignedS32_awl_unsignedS32 24 | { 25 | uint32_t member1; 26 | struct awl_unsignedS32 member2; 27 | }; 28 | 29 | void arrayInStruct__wool(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * out); 30 | 31 | #endif // TESTS_ARRAYINSTRUCT_WOOL_H 32 | -------------------------------------------------------------------------------- /tests/gold/pairParam2.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_PAIRPARAM2_H 2 | #define TESTS_PAIRPARAM2_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct s_2_signedS16_signedS16 17 | { 18 | int16_t member1; 19 | int16_t member2; 20 | }; 21 | 22 | struct s_2_s_2_signedS16_signedS16_s_2_signedS16_signedS16 23 | { 24 | struct s_2_signedS16_signedS16 member1; 25 | struct s_2_signedS16_signedS16 member2; 26 | }; 27 | 28 | void pairParam2(struct s_2_signedS16_signedS16 * v0, struct s_2_s_2_signedS16_signedS16_s_2_signedS16_signedS16 * out); 29 | 30 | #endif // TESTS_PAIRPARAM2_H 31 | -------------------------------------------------------------------------------- /tests/gold/divConq3.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_DIVCONQ3_H 2 | #define TESTS_DIVCONQ3_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct awl_i_awl_signedS32 17 | { 18 | struct ivar * buffer; 19 | uint32_t length; 20 | }; 21 | 22 | struct awl_signedS32 23 | { 24 | int32_t * buffer; 25 | uint32_t length; 26 | }; 27 | 28 | void task_core0(uint32_t v8, uint32_t v3, struct awl_signedS32 * v1, struct awl_i_awl_signedS32 v24); 29 | 30 | void task0(void * params); 31 | 32 | void divConq3(struct awl_signedS32 * v1, struct awl_signedS32 * out); 33 | 34 | #endif // TESTS_DIVCONQ3_H 35 | -------------------------------------------------------------------------------- /src/Feldspar/Runtime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | A module provinding a linker hook that can be referenced to ensure 4 | -- that the runtime support files are linked. 5 | 6 | module Feldspar.Runtime 7 | ( feldspar_compiler_hook 8 | ) 9 | where 10 | 11 | feldspar_compiler_hook :: Int 12 | 13 | #ifdef CABAL_IS_USED 14 | 15 | feldspar_compiler_hook = sum [ feldspar_c99_hook 16 | , feldspar_ivar_hook 17 | , feldspar_taskpool_hook 18 | ] 19 | 20 | foreign import ccall safe "feldspar_c99_hook" 21 | feldspar_c99_hook :: Int 22 | 23 | foreign import ccall safe "feldspar_ivar_hook" 24 | feldspar_ivar_hook :: Int 25 | 26 | foreign import ccall safe "feldspar_taskpool_hook" 27 | feldspar_taskpool_hook :: Int 28 | 29 | #else 30 | 31 | feldspar_compiler_hook = 0 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /benchs/BenchmarkUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module BenchmarkUtils where 4 | 5 | import Feldspar.Compiler.Plugin (pack) 6 | import Control.Exception (evaluate) 7 | import Criterion.Main 8 | import Criterion.Types 9 | import Data.List (intercalate) 10 | 11 | mkConfig report = defaultConfig { forceGC = True 12 | , reportFile = Just report 13 | } 14 | 15 | dimToString ls = intercalate "x" (map show ls) 16 | 17 | mkData ds ls = do putStrLn $ unwords ["Alloc array with", dimToString ls, "elements"] 18 | evaluate =<< pack (take (fromIntegral $ product ls) ds) 19 | 20 | mkData2 ds ls = do putStrLn $ unwords ["Alloc array with", dimToString ls, "elements"] 21 | evaluate =<< pack (ls,take (fromIntegral $ product ls) ds) 22 | 23 | mkBench name ls fun = bench (name ++ "_" ++ dimToString ls) fun 24 | -------------------------------------------------------------------------------- /tests/gold/scanlPush.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_SCANLPUSH_H 2 | #define TESTS_SCANLPUSH_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct awl_unsignedS32 17 | { 18 | uint32_t * buffer; 19 | uint32_t length; 20 | }; 21 | 22 | struct awl_awl_unsignedS32 23 | { 24 | struct awl_unsignedS32 * buffer; 25 | uint32_t length; 26 | }; 27 | 28 | struct awl_unsignedS32 * initArray_awl_unsignedS32(struct awl_unsignedS32 * dst, uint32_t oldLen, uint32_t newLen); 29 | 30 | void freeArray_awl_unsignedS32(struct awl_unsignedS32 * src, int32_t srcLen); 31 | 32 | void scanlPush(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * v1, struct awl_awl_unsignedS32 * out); 33 | 34 | #endif // TESTS_SCANLPUSH_H 35 | -------------------------------------------------------------------------------- /tests/gold/arrayInStructInStruct.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_ARRAYINSTRUCTINSTRUCT_H 2 | #define TESTS_ARRAYINSTRUCTINSTRUCT_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct awl_unsignedS32 17 | { 18 | uint32_t * buffer; 19 | uint32_t length; 20 | }; 21 | 22 | struct s_2_unsignedS32_awl_unsignedS32 23 | { 24 | uint32_t member1; 25 | struct awl_unsignedS32 member2; 26 | }; 27 | 28 | struct s_2_unsignedS32_s_2_unsignedS32_awl_unsignedS32 29 | { 30 | uint32_t member1; 31 | struct s_2_unsignedS32_awl_unsignedS32 member2; 32 | }; 33 | 34 | void arrayInStructInStruct(struct s_2_unsignedS32_s_2_unsignedS32_awl_unsignedS32 * v0, struct s_2_unsignedS32_s_2_unsignedS32_awl_unsignedS32 * out); 35 | 36 | #endif // TESTS_ARRAYINSTRUCTINSTRUCT_H 37 | -------------------------------------------------------------------------------- /tests/gold/concatVM.c: -------------------------------------------------------------------------------- 1 | #include "concatVM.h" 2 | 3 | 4 | void concatVM(struct awl_awl_signedS32 * v1, struct awl_signedS32 * out) 5 | { 6 | uint32_t len22; 7 | struct awl_signedS32 e23 = { 0 }; 8 | struct awl_signedS32 v7 = { 0 }; 9 | uint32_t v12; 10 | uint32_t v10; 11 | uint32_t len24; 12 | struct awl_signedS32 e25 = { 0 }; 13 | 14 | len22 = (*v1).length; 15 | e23 = *out; 16 | (e23).buffer = initArray((e23).buffer, (e23).length, sizeof(int32_t), 0); 17 | (e23).length = 0; 18 | for (uint32_t v6 = 0; v6 < len22; v6 += 1) 19 | { 20 | v12 = (e23).length; 21 | v10 = ((*v1).buffer[v6]).length; 22 | len24 = (v12 + v10); 23 | (v7).buffer = initArray((v7).buffer, (v7).length, sizeof(int32_t), len24); 24 | (v7).length = len24; 25 | for (uint32_t v17 = 0; v17 < v12; v17 += 1) 26 | { 27 | (v7).buffer[v17] = (e23).buffer[v17]; 28 | } 29 | for (uint32_t v21 = 0; v21 < v10; v21 += 1) 30 | { 31 | (v7).buffer[(v21 + v12)] = ((*v1).buffer[v6]).buffer[v21]; 32 | } 33 | e25 = e23; 34 | e23 = v7; 35 | v7 = e25; 36 | } 37 | *out = e23; 38 | freeArray((v7).buffer); 39 | } 40 | -------------------------------------------------------------------------------- /tests/gold/metrics.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_METRICS_H 2 | #define TESTS_METRICS_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct awl_signedS32 17 | { 18 | int32_t * buffer; 19 | uint32_t length; 20 | }; 21 | 22 | struct awl_awl_signedS32 23 | { 24 | struct awl_signedS32 * buffer; 25 | uint32_t length; 26 | }; 27 | 28 | struct s_2_unsignedS32_unsignedS32 29 | { 30 | uint32_t member1; 31 | uint32_t member2; 32 | }; 33 | 34 | struct awl_s_2_unsignedS32_unsignedS32 35 | { 36 | struct s_2_unsignedS32_unsignedS32 * buffer; 37 | uint32_t length; 38 | }; 39 | 40 | struct awl_awl_s_2_unsignedS32_unsignedS32 41 | { 42 | struct awl_s_2_unsignedS32_unsignedS32 * buffer; 43 | uint32_t length; 44 | }; 45 | 46 | struct awl_signedS32 * initArray_awl_signedS32(struct awl_signedS32 * dst, uint32_t oldLen, uint32_t newLen); 47 | 48 | void freeArray_awl_signedS32(struct awl_signedS32 * src, int32_t srcLen); 49 | 50 | void metrics(struct awl_signedS32 * v1, struct awl_signedS32 * v2, struct awl_awl_s_2_unsignedS32_unsignedS32 * v3, struct awl_awl_signedS32 * out); 51 | 52 | #endif // TESTS_METRICS_H 53 | -------------------------------------------------------------------------------- /tests/gold/arrayInStruct.c: -------------------------------------------------------------------------------- 1 | #include "arrayInStruct.h" 2 | 3 | 4 | void arrayInStruct(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * out) 5 | { 6 | struct s_2_unsignedS32_awl_unsignedS32 e10 = { 0 }; 7 | struct s_2_unsignedS32_awl_unsignedS32 v6 = { 0 }; 8 | uint32_t len11; 9 | struct awl_unsignedS32 e12 = { 0 }; 10 | bool v3; 11 | 12 | (e10).member1 = (*v0).length; 13 | ((e10).member2).buffer = initCopyArray(((e10).member2).buffer, ((e10).member2).length, sizeof(uint32_t), (*v0).buffer, (*v0).length); 14 | ((e10).member2).length = (*v0).length; 15 | v3 = ((e10).member1 > 0); 16 | while (v3) 17 | { 18 | (v6).member1 = ((e10).member1 - 1); 19 | len11 = ((e10).member2).length; 20 | ((v6).member2).buffer = initArray(((v6).member2).buffer, ((v6).member2).length, sizeof(uint32_t), len11); 21 | ((v6).member2).length = len11; 22 | for (uint32_t v9 = 0; v9 < len11; v9 += 1) 23 | { 24 | ((v6).member2).buffer[v9] = (((e10).member2).buffer[v9] + 5); 25 | } 26 | e12 = (e10).member2; 27 | e10 = v6; 28 | (v6).member2 = e12; 29 | v3 = ((e10).member1 > 0); 30 | } 31 | (*out).buffer = initCopyArray((*out).buffer, (*out).length, sizeof(uint32_t), ((e10).member2).buffer, ((e10).member2).length); 32 | (*out).length = ((e10).member2).length; 33 | freeArray(((e10).member2).buffer); 34 | freeArray(((v6).member2).buffer); 35 | } 36 | -------------------------------------------------------------------------------- /tests/gold/concatV.c: -------------------------------------------------------------------------------- 1 | #include "concatV.h" 2 | 3 | 4 | void concatV(struct awl_awl_signedS32 * v1, struct awl_signedS32 * out) 5 | { 6 | struct awl_signedS32 v26 = { 0 }; 7 | uint32_t len31; 8 | struct awl_signedS32 v6 = { 0 }; 9 | uint32_t v11; 10 | uint32_t v9; 11 | uint32_t len32; 12 | struct awl_signedS32 e33 = { 0 }; 13 | uint32_t v27; 14 | 15 | len31 = (*v1).length; 16 | (v26).buffer = initArray((v26).buffer, (v26).length, sizeof(int32_t), 0); 17 | (v26).length = 0; 18 | for (uint32_t v5 = 0; v5 < len31; v5 += 1) 19 | { 20 | v11 = (v26).length; 21 | v9 = ((*v1).buffer[v5]).length; 22 | len32 = (v11 + v9); 23 | (v6).buffer = initArray((v6).buffer, (v6).length, sizeof(int32_t), len32); 24 | (v6).length = len32; 25 | for (uint32_t v16 = 0; v16 < v11; v16 += 1) 26 | { 27 | (v6).buffer[v16] = (v26).buffer[v16]; 28 | } 29 | for (uint32_t v20 = 0; v20 < v9; v20 += 1) 30 | { 31 | (v6).buffer[(v20 + v11)] = ((*v1).buffer[v5]).buffer[v20]; 32 | } 33 | e33 = v26; 34 | v26 = v6; 35 | v6 = e33; 36 | } 37 | v27 = (v26).length; 38 | (*out).buffer = initArray((*out).buffer, (*out).length, sizeof(int32_t), v27); 39 | (*out).length = v27; 40 | for (uint32_t v30 = 0; v30 < v27; v30 += 1) 41 | { 42 | (*out).buffer[v30] = (v26).buffer[v30]; 43 | } 44 | freeArray((v26).buffer); 45 | freeArray((v6).buffer); 46 | } 47 | -------------------------------------------------------------------------------- /tests/gold/arrayInStruct_openMP.c: -------------------------------------------------------------------------------- 1 | #include "arrayInStruct_openMP.h" 2 | 3 | 4 | void arrayInStruct__openMP(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * out) 5 | { 6 | struct s_2_unsignedS32_awl_unsignedS32 e10 = { 0 }; 7 | struct s_2_unsignedS32_awl_unsignedS32 v6 = { 0 }; 8 | bool v3; 9 | 10 | (e10).member1 = (*v0).length; 11 | ((e10).member2).buffer = initCopyArray(((e10).member2).buffer, ((e10).member2).length, sizeof(uint32_t), (*v0).buffer, (*v0).length); 12 | ((e10).member2).length = (*v0).length; 13 | v3 = ((e10).member1 > 0); 14 | while (v3) 15 | { 16 | uint32_t len11; 17 | struct awl_unsignedS32 e12 = { 0 }; 18 | 19 | (v6).member1 = ((e10).member1 - 1); 20 | len11 = ((e10).member2).length; 21 | ((v6).member2).buffer = initArray(((v6).member2).buffer, ((v6).member2).length, sizeof(uint32_t), len11); 22 | ((v6).member2).length = len11; 23 | #pragma omp parallel for 24 | for (uint32_t v9 = 0; v9 < len11; v9 += 1) 25 | { 26 | ((v6).member2).buffer[v9] = (((e10).member2).buffer[v9] + 5); 27 | } 28 | e12 = (e10).member2; 29 | e10 = v6; 30 | (v6).member2 = e12; 31 | v3 = ((e10).member1 > 0); 32 | } 33 | (*out).buffer = initCopyArray((*out).buffer, (*out).length, sizeof(uint32_t), ((e10).member2).buffer, ((e10).member2).length); 34 | (*out).length = ((e10).member2).length; 35 | freeArray(((e10).member2).buffer); 36 | freeArray(((v6).member2).buffer); 37 | } 38 | -------------------------------------------------------------------------------- /tests/gold/tuples.c: -------------------------------------------------------------------------------- 1 | #include "tuples.h" 2 | 3 | 4 | void tuples(int32_t v0, int32_t * out) 5 | { 6 | int32_t v1; 7 | int32_t v7; 8 | int32_t v13; 9 | int32_t v23; 10 | int32_t v6; 11 | int32_t v15; 12 | int32_t v22; 13 | int32_t v36; 14 | int32_t v14; 15 | int32_t v24; 16 | int32_t v33; 17 | int32_t v51; 18 | int32_t v25; 19 | int32_t v35; 20 | int32_t v49; 21 | int32_t v68; 22 | int32_t v37; 23 | int32_t v48; 24 | int32_t v34; 25 | int32_t v46; 26 | int32_t v67; 27 | int32_t v47; 28 | int32_t v66; 29 | int32_t v64; 30 | int32_t v50; 31 | int32_t v63; 32 | int32_t v62; 33 | int32_t v61; 34 | 35 | v1 = (v0 * 3); 36 | v7 = (v0 + v1); 37 | v13 = (v1 + v7); 38 | v23 = (v13 + v1); 39 | v6 = (v1 + v0); 40 | v15 = (v6 + v1); 41 | v22 = (v15 + v13); 42 | v36 = (v22 + v23); 43 | v14 = (v7 + v6); 44 | v24 = (v1 + v14); 45 | v33 = (v23 + v24); 46 | v51 = (v36 + v33); 47 | v25 = (v14 + v15); 48 | v35 = (v25 + v22); 49 | v49 = (v35 + v36); 50 | v68 = (v49 + v51); 51 | v37 = (v1 + v25); 52 | v48 = (v37 + v1); 53 | v34 = (v24 + v1); 54 | v46 = (v34 + v37); 55 | v67 = (v46 + v48); 56 | v47 = (v1 + v35); 57 | v66 = (v47 + v1); 58 | v64 = (v1 + v49); 59 | v50 = (v33 + v34); 60 | v63 = (v51 + v50); 61 | v62 = (v50 + v46); 62 | v61 = (v48 + v47); 63 | *out = ((((((((((((((v68 + v63) + v62) + v67) + v61) + v66) + v64) + v68) + v63) + v62) + v67) + v61) + v66) + v64) + (v1 * v49)); 64 | } 65 | -------------------------------------------------------------------------------- /benchs/MatMulC.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "MatMulC.h" 3 | 4 | void MatMulC(int rows, int len, double *a, double *bin, double *c) 5 | { 6 | int i,j,k; 7 | double *b = malloc(len * sizeof(double)); 8 | 9 | // Transpose bin with result in b. 10 | for(int n = 0; n < len; n++ ) { 11 | b[n] = bin[rows * (n % rows) + (n / rows)]; 12 | } 13 | 14 | for( i = 0; i < rows; i++ ) { 15 | for( j = 0; j < rows; j++ ) { 16 | double sum = 0.0; 17 | for( k = 0; k < rows; k++ ) { 18 | sum += a[i*rows+k] * b[j*rows + k]; 19 | } 20 | c[i*rows + j] = sum; 21 | } 22 | } 23 | 24 | free(b); 25 | } 26 | 27 | /** 28 | * Same code as above with middle loop unrolled once to improve the balance 29 | * between computation and memory reads. 30 | */ 31 | void MatMulCopt(int rows, int len, double *a, double *bin, double *c) 32 | { 33 | int i,j,k; 34 | double *b = malloc(len * sizeof(double)); 35 | 36 | // Transpose bin with result in b. 37 | for(int n = 0; n < len; n++ ) { 38 | b[n] = bin[rows * (n % rows) + (n / rows)]; 39 | } 40 | 41 | for( i = 0; i < rows; i++ ) { 42 | for( j = 0; j < rows; j+=2 ) { 43 | double sum0 = 0.0; 44 | double sum1 = 0.0; 45 | for( k = 0; k < rows; k++ ) { 46 | sum0 += a[i*rows+k] * b[j*rows + k]; 47 | sum1 += a[i*rows+k] * b[(j + 1)*rows + k]; 48 | } 49 | c[i*rows + j] = sum0; 50 | c[i*rows + j+1] = sum1; 51 | } 52 | } 53 | 54 | free(b); 55 | } 56 | -------------------------------------------------------------------------------- /benchs/FFT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | 5 | module Main where 6 | 7 | import Feldspar (Length,Complex) 8 | import Feldspar.Algorithm.FFT 9 | import Feldspar.Compiler 10 | import Feldspar.Compiler.Plugin 11 | import Feldspar.Compiler.Marshal 12 | 13 | import Foreign.Ptr 14 | import Foreign.Marshal (new) 15 | import Control.DeepSeq (NFData(..)) 16 | import Control.Exception (evaluate) 17 | 18 | import BenchmarkUtils 19 | import Criterion.Main 20 | 21 | testdata :: [Complex Float] 22 | testdata = cycle [1,2,3,4] 23 | 24 | loadFunOpts ["-optc=-O2"] ['fft] 25 | loadFunOpts ["-optc=-O2"] ['ifft] 26 | 27 | len :: Length 28 | len = 4096 29 | 30 | sizes :: [[Length]] 31 | sizes = map (map (*len)) [[1],[2],[4],[8]] 32 | 33 | instance NFData (Ptr a) where rnf !_ = () 34 | 35 | setupPlugins :: IO () 36 | setupPlugins = do 37 | _ <- evaluate c_fft_builder 38 | return () 39 | 40 | -- setupData :: [Length] -> IO (Ptr (SA Length), Ptr (SA (Complex Float))) 41 | setupData lengths = do 42 | d <- mkData testdata lengths 43 | ls <- pack lengths 44 | ds <- allocSA $ fromIntegral $ product lengths :: IO (Ptr (SA (Complex Float))) 45 | o <- new ds 46 | return (o,d) 47 | 48 | mkComp :: [Length] -> Benchmark 49 | mkComp ls = env (setupData ls) $ \ ~(o,d) -> 50 | mkBench "c_fft" ls (whnfIO $ c_fft_raw d o) 51 | 52 | main :: IO () 53 | main = defaultMainWith (mkConfig "report_fft.html") 54 | [ env setupPlugins $ \_ -> bgroup "compiled" $ map mkComp sizes 55 | ] 56 | -------------------------------------------------------------------------------- /tests/gold/arrayInStruct_wool.c: -------------------------------------------------------------------------------- 1 | #include "arrayInStruct_wool.h" 2 | 3 | 4 | LOOP_BODY_2(wool0, 5 | LARGE_BODY, 6 | uint32_t, 7 | v9, 8 | struct s_2_unsignedS32_awl_unsignedS32, 9 | e10, 10 | struct s_2_unsignedS32_awl_unsignedS32, 11 | v6) 12 | { 13 | ((v6).member2).buffer[v9] = (((e10).member2).buffer[v9] + 5); 14 | } 15 | 16 | void arrayInStruct__wool(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * out) 17 | { 18 | struct s_2_unsignedS32_awl_unsignedS32 e10 = { 0 }; 19 | struct s_2_unsignedS32_awl_unsignedS32 v6 = { 0 }; 20 | bool v3; 21 | 22 | (e10).member1 = (*v0).length; 23 | ((e10).member2).buffer = initCopyArray(((e10).member2).buffer, ((e10).member2).length, sizeof(uint32_t), (*v0).buffer, (*v0).length); 24 | ((e10).member2).length = (*v0).length; 25 | v3 = ((e10).member1 > 0); 26 | while (v3) 27 | { 28 | uint32_t len11; 29 | struct awl_unsignedS32 e12 = { 0 }; 30 | 31 | (v6).member1 = ((e10).member1 - 1); 32 | len11 = ((e10).member2).length; 33 | ((v6).member2).buffer = initArray(((v6).member2).buffer, ((v6).member2).length, sizeof(uint32_t), len11); 34 | ((v6).member2).length = len11; 35 | FOR(wool0, 0, len11, e10, v6); 36 | e12 = (e10).member2; 37 | e10 = v6; 38 | (v6).member2 = e12; 39 | v3 = ((e10).member1 > 0); 40 | } 41 | (*out).buffer = initCopyArray((*out).buffer, (*out).length, sizeof(uint32_t), ((e10).member2).buffer, ((e10).member2).length); 42 | (*out).length = ((e10).member2).length; 43 | freeArray(((e10).member2).buffer); 44 | freeArray(((v6).member2).buffer); 45 | } 46 | -------------------------------------------------------------------------------- /clib/feldspar_future.h: -------------------------------------------------------------------------------- 1 | // 2 | // Copyright (c) 2009-2011, ERICSSON AB 3 | // All rights reserved. 4 | // 5 | // Redistribution and use in source and binary forms, with or without 6 | // modification, are permitted provided that the following conditions are met: 7 | // 8 | // * Redistributions of source code must retain the above copyright notice, 9 | // this list of conditions and the following disclaimer. 10 | // * Redistributions in binary form must reproduce the above copyright 11 | // notice, this list of conditions and the following disclaimer in the 12 | // documentation and/or other materials provided with the distribution. 13 | // * Neither the name of the ERICSSON AB nor the names of its contributors 14 | // may be used to endorse or promote products derived from this software 15 | // without specific prior written permission. 16 | // 17 | // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | // AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | // IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | // DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | // FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | // DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | // SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | // CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | // OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | // 28 | 29 | #include 30 | 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2015, Emil Axelsson, Peter Jonsson, Anders Persson and 2 | Josef Svenningsson 3 | Copyright (c) 2012, Emil Axelsson, Gergely Dévai, Anders Persson and 4 | Josef Svenningsson 5 | Copyright (c) 2009-2011, ERICSSON AB 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions are met: 10 | 11 | * Redistributions of source code must retain the above copyright notice, 12 | this list of conditions and the following disclaimer. 13 | * Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | * Neither the name of the ERICSSON AB nor the names of its contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/CallConv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | -- | Type rewriting for Feldspar programs 6 | module Feldspar.Compiler.CallConv 7 | ( rewriteType 8 | , buildHaskellType 9 | , buildCType 10 | ) 11 | where 12 | 13 | 14 | import Language.Haskell.TH 15 | 16 | import System.Plugins.MultiStage hiding (ref) 17 | 18 | import Foreign.Ptr (Ptr) 19 | 20 | import Feldspar (Syntactic(..)) 21 | 22 | -- | Normalize the type (expand type synonyms and type families) 23 | rewriteType :: Type -> Q Type 24 | rewriteType t = applyTF ''Internal t 25 | 26 | haskellCC :: CallConv 27 | haskellCC = CallConv { arg = return 28 | , res = appT (conT ''IO) . return 29 | } 30 | 31 | feldsparCC :: CallConv 32 | feldsparCC = CallConv { arg = ref . rep . return 33 | , res = toIO . appT (conT ''Ptr) . rep . return 34 | } 35 | where 36 | ref = appT (conT ''Ref) 37 | rep = appT (conT ''Rep) 38 | toIO t = appT (appT arrowT t) (appT (conT ''IO) (tupleT 0)) 39 | 40 | -- | Construct the corresponding Haskell type of a foreign Feldspar 41 | -- function 42 | -- 43 | -- > prog1 :: Data Index -> Vector1 Index 44 | -- > 45 | -- > sigD (mkName "h_prog1") $ loadFunType 'prog1 >>= rewriteType >>= buildHaskellType 46 | -- 47 | -- becomes 48 | -- 49 | -- > h_prog1 :: Index -> IO [Index] 50 | -- 51 | buildHaskellType :: Type -> Q Type 52 | buildHaskellType = buildType haskellCC 53 | 54 | -- | Construct the corresponding C type of a compiled Feldspar function 55 | -- 56 | -- > sigD (mkName "c_prog1_fun") $ loadFunType 'prog1 >>= rewriteType 57 | -- >>= buildCType 58 | -- 59 | -- becomes 60 | -- 61 | -- > c_prog1_fun :: Word32 -> Ptr (SA Word32) -> IO () 62 | -- 63 | buildCType :: Type -> Q Type 64 | buildCType = buildType feldsparCC 65 | 66 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/Error.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (c) 2009-2011, ERICSSON AB 3 | -- All rights reserved. 4 | -- 5 | -- Redistribution and use in source and binary forms, with or without 6 | -- modification, are permitted provided that the following conditions are met: 7 | -- 8 | -- * Redistributions of source code must retain the above copyright notice, 9 | -- this list of conditions and the following disclaimer. 10 | -- * Redistributions in binary form must reproduce the above copyright 11 | -- notice, this list of conditions and the following disclaimer in the 12 | -- documentation and/or other materials provided with the distribution. 13 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 14 | -- may be used to endorse or promote products derived from this software 15 | -- without specific prior written permission. 16 | -- 17 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -- 28 | 29 | module Feldspar.Compiler.Error where 30 | 31 | data ErrorClass = InvariantViolation | InternalError | Warning 32 | deriving (Show, Eq) 33 | 34 | handleError :: String -> ErrorClass -> String -> a 35 | handleError place errorClass message = error $ "[" ++ show errorClass ++ " @ " ++ place ++ "]: " ++ message 36 | -------------------------------------------------------------------------------- /benchs/FIR_Fusion.hs: -------------------------------------------------------------------------------- 1 | -- This module implements FIR filters, and compositions of them. 2 | 3 | -- The generated code looks OK, but the use of `force` leads to different space/time 4 | -- characteristics. 5 | -- 6 | -- In order to fuse filters without forcing the entire intermediate vector, one should use streams 7 | -- with a cyclic buffer; see example in the Stream library. 8 | 9 | import qualified Prelude 10 | import Feldspar 11 | import Feldspar.Vector 12 | import Feldspar.Matrix 13 | import Feldspar.Compiler 14 | 15 | 16 | 17 | causalMap :: Syntax a => (Vector a -> a) -> Vector a -> Vector a 18 | causalMap f = map (f . reverse) . inits 19 | 20 | -- | FIR filter 21 | fir 22 | :: Vector1 Float -- ^ Coefficients 23 | -> Vector1 Float -- ^ Input 24 | -> Vector1 Float 25 | fir coeffs = causalMap (coeffs***) 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- 30 | -- Composing filters 31 | 32 | composition boundary as bs = fir as . boundary . fir bs 33 | 34 | test1 :: Vector1 Float -> Vector1 Float -> Vector1 Float -> Vector1 Float 35 | test1 = composition id -:: newLen 10 >-> newLen 10 >-> newLen 100 >-> id 36 | -- Loop structure: 37 | -- 38 | -- parallel 100 39 | -- forLoop 10 40 | -- forLoop 10 41 | 42 | test2 :: Vector1 Float -> Vector1 Float -> Vector1 Float -> Vector1 Float 43 | test2 = composition force -:: newLen 10 >-> newLen 10 >-> newLen 100 >-> id 44 | -- Loop structure: 45 | -- 46 | -- parallel 100 47 | -- forLoop 10 48 | -- parallel 100 49 | -- forLoop 10 50 | 51 | 52 | 53 | -------------------------------------------------------------------------------- 54 | -- Filters with hard-coded coefficients 55 | 56 | composition2 boundary = fir (value [0.3,0.4,0.5,0.6]) . boundary . fir (value [0.3,-0.4,0.5,-0.6]) 57 | 58 | test3 :: Vector1 Float -> Vector1 Float 59 | test3 = composition2 id -:: newLen 100 >-> id 60 | 61 | test4 :: Vector1 Float -> Vector1 Float 62 | test4 = composition2 force -:: newLen 100 >-> id 63 | 64 | -------------------------------------------------------------------------------- /benchs/CRC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | import Feldspar 5 | import Feldspar.Vector 6 | import Feldspar.Compiler.Plugin 7 | import Feldspar.Compiler.Marshal (SA(..)) 8 | import Feldspar.Algorithm.CRC 9 | 10 | import Foreign.Ptr 11 | import Foreign.Marshal (malloc) 12 | import Control.DeepSeq (NFData(..),force) 13 | import Control.Exception (evaluate) 14 | 15 | import BenchmarkUtils 16 | import Criterion.Main 17 | 18 | len :: Length 19 | len = 16 * 1024 20 | 21 | testdata :: [Word8] 22 | testdata = Prelude.take (fromIntegral len) $ cycle [1,2,3,4] 23 | 24 | naive :: Pull1 Word8 -> Data Word16 25 | naive = crcNaive 0x8005 0 26 | 27 | normal :: Pull1 Word8 -> Data Word16 28 | normal v = share (makeCrcTable 0x8005) $ \t -> crcNormal t 0 v 29 | 30 | h_naive :: [Word8] -> Word16 31 | h_naive = eval naive 32 | loadFun ['naive] 33 | 34 | h_normal :: [Word8] -> Word16 35 | h_normal = eval normal 36 | loadFun ['normal] 37 | 38 | instance NFData (Ptr a) where rnf !_ = () 39 | 40 | setupPlugins :: IO () 41 | setupPlugins = do 42 | putStrLn "Compiling plugins" 43 | _ <- evaluate c_naive_builder 44 | _ <- evaluate c_normal_builder 45 | return () 46 | 47 | setupData :: Length -> IO [Word8] 48 | setupData l = return $ Prelude.take (fromIntegral l) testdata 49 | 50 | setupRaw :: Length -> IO (Ptr Word16, Ptr (SA Word8)) 51 | setupRaw l = do 52 | o <- malloc 53 | pd <- pack (Prelude.take (fromIntegral l) testdata) 54 | return (o,pd) 55 | 56 | main :: IO () 57 | main = 58 | defaultMainWith (mkConfig "report_crc.html") 59 | [ 60 | env (setupData 1024) $ \ ~d -> 61 | bgroup "evaluated" 62 | [ bench "h_naive" $ nf h_naive d 63 | , bench "h_normal" $ nf h_normal d 64 | ] 65 | , env setupPlugins $ \_ -> bgroup "compiled" 66 | [ env (setupData len) $ \ ~d -> bgroup "marshal" 67 | [ bench "c_naive" $ whnfIO $ c_naive_worker d 68 | , bench "c_normal" $ whnfIO $ c_normal_worker d 69 | ] 70 | , env (setupRaw len) $ \ ~(o,pd) -> bgroup "raw" 71 | [ bench "c_naive" $ whnfIO $ c_naive_raw pd o 72 | , bench "c_normal" $ whnfIO $ c_normal_raw pd o 73 | ] 74 | ] 75 | ] 76 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | cache: 4 | directories: 5 | - .cabal-sandbox 6 | 7 | matrix: 8 | include: 9 | - env: CABALVER=1.24 GHCVER=8.0.2 10 | addons: {apt: {sources: [hvr-ghc], packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7]}} 11 | - env: CABALVER=2.2 GHCVER=8.4.4 12 | addons: {apt: {sources: [hvr-ghc], packages: [cabal-install-2.2,ghc-8.4.4,happy-1.19.5,alex-3.1.7]}} 13 | 14 | before_install: 15 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 16 | - export PATH=/opt/alex/3.1.7/bin:/opt/happy/1.19.5/bin:$PATH 17 | - env 18 | # Fetch the latest feldspar-language from github 19 | # Note that we will fetch a branch with the same name as the current 20 | # branch in feldspar-compiler. This is to support CI of new features 21 | # depending on features in feldspar-language. 22 | - git clone -v https://github.com/Feldspar/feldspar-language 23 | - cd feldspar-language && git checkout $TRAVIS_BRANCH || git checkout master 24 | - echo "Using feldspar-language from " && git rev-parse HEAD 25 | - cd $TRAVIS_BUILD_DIR 26 | 27 | install: 28 | - cabal --version 29 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 30 | - travis_retry cabal update 31 | - cabal sandbox init 32 | - cabal sandbox add-source feldspar-language 33 | - cabal install --only-dependencies --enable-tests --force-reinstalls 34 | 35 | # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. 36 | script: 37 | - if [ -f configure.ac ]; then autoreconf -i; fi 38 | - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging 39 | - cabal build -j # this builds all libraries and executables (including tests/benchmarks) 40 | - cabal test -j 41 | - cabal check 42 | - cabal sdist # tests that a source-distribution can be generated 43 | 44 | # Check that the resulting source distribution can be built & installed. 45 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 46 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 47 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 48 | (cd dist && cabal sandbox init --sandbox=../.cabal-sandbox && cabal install -j --force-reinstalls "$SRC_TGZ") 49 | -------------------------------------------------------------------------------- /clib/log.h: -------------------------------------------------------------------------------- 1 | // 2 | // Copyright (c) 2009-2011, ERICSSON AB 3 | // All rights reserved. 4 | // 5 | // Redistribution and use in source and binary forms, with or without 6 | // modification, are permitted provided that the following conditions are met: 7 | // 8 | // * Redistributions of source code must retain the above copyright notice, 9 | // this list of conditions and the following disclaimer. 10 | // * Redistributions in binary form must reproduce the above copyright 11 | // notice, this list of conditions and the following disclaimer in the 12 | // documentation and/or other materials provided with the distribution. 13 | // * Neither the name of the ERICSSON AB nor the names of its contributors 14 | // may be used to endorse or promote products derived from this software 15 | // without specific prior written permission. 16 | // 17 | // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | // AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | // IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | // DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | // FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | // DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | // SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | // CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | // OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | // 28 | 29 | #ifndef LOG_H 30 | #define LOG_H 31 | 32 | #include 33 | 34 | #ifdef LOG 35 | #define log_0(text) printf(text) 36 | #define log_1(text,x1) printf(text,x1) 37 | #define log_2(text,x1,x2) printf(text,x1,x2) 38 | #define log_3(text,x1,x2,x3) printf(text,x1,x2,x3) 39 | #define log_4(text,x1,x2,x3,x4) printf(text,x1,x2,x3,x4) 40 | #define log_5(text,x1,x2,x3,x4,x5) printf(text,x1,x2,x3,x4,x5) 41 | #else 42 | #define log_0(text) 43 | #define log_1(text,x1) 44 | #define log_2(text,x1,x2) 45 | #define log_3(text,x1,x2,x3) 46 | #define log_4(text,x1,x2,x3,x4) 47 | #define log_5(text,x1,x2,x3,x4,x5) 48 | #endif 49 | 50 | #endif /* LOG_H */ 51 | -------------------------------------------------------------------------------- /tests/gold/deepArrayCopy.h: -------------------------------------------------------------------------------- 1 | #ifndef TESTS_DEEPARRAYCOPY_H 2 | #define TESTS_DEEPARRAYCOPY_H 3 | 4 | #include "feldspar_c99.h" 5 | #include "feldspar_array.h" 6 | #include "feldspar_future.h" 7 | #include "ivar.h" 8 | #include "taskpool.h" 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | 15 | 16 | struct awl_unsignedS32 17 | { 18 | uint32_t * buffer; 19 | uint32_t length; 20 | }; 21 | 22 | struct awl_awl_unsignedS32 23 | { 24 | struct awl_unsignedS32 * buffer; 25 | uint32_t length; 26 | }; 27 | 28 | struct awl_awl_awl_unsignedS32 29 | { 30 | struct awl_awl_unsignedS32 * buffer; 31 | uint32_t length; 32 | }; 33 | 34 | struct s_2_awl_awl_awl_unsignedS32_awl_awl_awl_unsignedS32 35 | { 36 | struct awl_awl_awl_unsignedS32 member1; 37 | struct awl_awl_awl_unsignedS32 member2; 38 | }; 39 | 40 | struct awl_awl_unsignedS32 * copyArrayPos_awl_awl_unsignedS32(struct awl_awl_unsignedS32 * dst, int32_t dstLen, struct awl_awl_unsignedS32 * src, int32_t srcLen, int32_t pos); 41 | 42 | struct awl_awl_unsignedS32 * copyArray_awl_awl_unsignedS32(struct awl_awl_unsignedS32 * dst, int32_t dstLen, struct awl_awl_unsignedS32 * src, int32_t srcLen); 43 | 44 | struct awl_awl_unsignedS32 * initCopyArray_awl_awl_unsignedS32(struct awl_awl_unsignedS32 * dst, int32_t dstLen, struct awl_awl_unsignedS32 * src, int32_t srcLen); 45 | 46 | struct awl_unsignedS32 * copyArrayPos_awl_unsignedS32(struct awl_unsignedS32 * dst, int32_t dstLen, struct awl_unsignedS32 * src, int32_t srcLen, int32_t pos); 47 | 48 | struct awl_unsignedS32 * copyArray_awl_unsignedS32(struct awl_unsignedS32 * dst, int32_t dstLen, struct awl_unsignedS32 * src, int32_t srcLen); 49 | 50 | struct awl_unsignedS32 * initCopyArray_awl_unsignedS32(struct awl_unsignedS32 * dst, int32_t dstLen, struct awl_unsignedS32 * src, int32_t srcLen); 51 | 52 | struct awl_awl_unsignedS32 * initArray_awl_awl_unsignedS32(struct awl_awl_unsignedS32 * dst, uint32_t oldLen, uint32_t newLen); 53 | 54 | void freeArray_awl_awl_unsignedS32(struct awl_awl_unsignedS32 * src, int32_t srcLen); 55 | 56 | struct awl_unsignedS32 * initArray_awl_unsignedS32(struct awl_unsignedS32 * dst, uint32_t oldLen, uint32_t newLen); 57 | 58 | void freeArray_awl_unsignedS32(struct awl_unsignedS32 * src, int32_t srcLen); 59 | 60 | void deepArrayCopy(struct awl_awl_awl_unsignedS32 * v0, struct s_2_awl_awl_awl_unsignedS32_awl_awl_awl_unsignedS32 * out); 61 | 62 | #endif // TESTS_DEEPARRAYCOPY_H 63 | -------------------------------------------------------------------------------- /tests/gold/scanlPush.c: -------------------------------------------------------------------------------- 1 | #include "scanlPush.h" 2 | 3 | 4 | struct awl_unsignedS32 * initArray_awl_unsignedS32(struct awl_unsignedS32 * dst, uint32_t oldLen, uint32_t newLen) 5 | { 6 | if ((oldLen != newLen)) 7 | { 8 | if ((oldLen < newLen)) 9 | { 10 | dst = resizeArray(dst, sizeof(struct awl_unsignedS32), newLen); 11 | for (int32_t i = oldLen; i < newLen; i += 1) 12 | { 13 | struct awl_unsignedS32 null_arr_0 = { 0 }; 14 | 15 | dst[i] = null_arr_0; 16 | } 17 | } 18 | else 19 | { 20 | for (int32_t i = newLen; i < oldLen; i += 1) 21 | { 22 | freeArray((dst[i]).buffer); 23 | } 24 | dst = resizeArray(dst, sizeof(struct awl_unsignedS32), newLen); 25 | } 26 | } 27 | return(dst); 28 | } 29 | 30 | void freeArray_awl_unsignedS32(struct awl_unsignedS32 * src, int32_t srcLen) 31 | { 32 | for (int32_t i = 0; i < srcLen; i += 1) 33 | { 34 | freeArray((src[i]).buffer); 35 | } 36 | freeArray(src); 37 | } 38 | 39 | void scanlPush(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * v1, struct awl_awl_unsignedS32 * out) 40 | { 41 | uint32_t v9; 42 | uint32_t v2; 43 | struct awl_unsignedS32 v12 = { 0 }; 44 | uint32_t v15; 45 | struct awl_unsignedS32 v23 = { 0 }; 46 | uint32_t v24; 47 | struct awl_unsignedS32 e27 = { 0 }; 48 | 49 | v9 = (*v1).length; 50 | (*out).buffer = initArray_awl_unsignedS32((*out).buffer, (*out).length, v9); 51 | (*out).length = v9; 52 | v2 = (*v0).length; 53 | (v12).buffer = initArray((v12).buffer, (v12).length, sizeof(uint32_t), v2); 54 | (v12).length = v2; 55 | for (uint32_t v4 = 0; v4 < v2; v4 += 1) 56 | { 57 | (v12).buffer[v4] = (*v0).buffer[v4]; 58 | } 59 | for (uint32_t v13 = 0; v13 < v9; v13 += 1) 60 | { 61 | v15 = (v12).length; 62 | (v12).buffer = initArray((v12).buffer, (v12).length, sizeof(uint32_t), v15); 63 | (v12).length = v15; 64 | (v23).buffer = initCopyArray((v23).buffer, (v23).length, sizeof(uint32_t), (v12).buffer, (v12).length); 65 | (v23).length = (v12).length; 66 | v24 = (v23).length; 67 | (e27).buffer = initArray((e27).buffer, (e27).length, sizeof(uint32_t), v24); 68 | (e27).length = v24; 69 | for (uint32_t v26 = 0; v26 < v24; v26 += 1) 70 | { 71 | (e27).buffer[v26] = (v23).buffer[v26]; 72 | } 73 | ((*out).buffer[v13]).buffer = initCopyArray(((*out).buffer[v13]).buffer, ((*out).buffer[v13]).length, sizeof(uint32_t), (e27).buffer, (e27).length); 74 | ((*out).buffer[v13]).length = (e27).length; 75 | } 76 | freeArray((v12).buffer); 77 | freeArray((v23).buffer); 78 | freeArray((e27).buffer); 79 | } 80 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/ExternalProgram.hs: -------------------------------------------------------------------------------- 1 | module Feldspar.Compiler.ExternalProgram 2 | ( icompileFile 3 | , compileFile 4 | ) 5 | where 6 | 7 | import qualified Data.ByteString.Char8 as B 8 | 9 | import Feldspar.Compiler.Compiler 10 | import Feldspar.Compiler.Backend.C.Options (Options(..), Platform(..)) 11 | import Feldspar.Compiler.Imperative.Representation (Module(..)) 12 | import Feldspar.Compiler.Imperative.ExternalProgram (parseFile) 13 | import Feldspar.Compiler.Frontend.Interactive.Interface (writeFiles) 14 | 15 | icompileFile :: FilePath -> IO () 16 | icompileFile filename = do 17 | let hfilename = filename ++ ".h" 18 | cfilename = filename ++ ".c" 19 | h <- B.readFile hfilename 20 | c <- B.readFile cfilename 21 | let comp = compileFile' defaultOptions (hfilename, h) (cfilename, c) 22 | case comp of 23 | (Nothing, _) -> putStrLn $ "Could not parse " ++ hfilename 24 | (_, Nothing) -> putStrLn $ "Could not parse " ++ cfilename 25 | (_, Just cprg) -> putStrLn $ sourceCode cprg 26 | 27 | 28 | compileFile :: FilePath -> FilePath -> Options -> IO () 29 | compileFile fileName outFile opts = do 30 | let hfilename = fileName ++ ".h" 31 | cfilename = fileName ++ ".c" 32 | h <- B.readFile hfilename 33 | c <- B.readFile cfilename 34 | let comp = compileFile' opts (hfilename, h) (cfilename, c) 35 | case comp of 36 | (Nothing, _) -> print $ "Could not parse " ++ hfilename 37 | (_, Nothing) -> putStrLn $ "Could not parse " ++ cfilename 38 | (Just hprg, Just cprg) -> writeFiles prg outFile (codeGenerator $ platform opts) 39 | where prg = SplitModule cprg hprg 40 | 41 | compileFile' :: Options -> (String, B.ByteString) -> (String, B.ByteString) 42 | -> (Maybe CompiledModule, Maybe CompiledModule) 43 | compileFile' opts (hfilename, hfile) (cfilename, cfile) = 44 | case parseFile hfilename hfile [] of 45 | Nothing -> (Nothing, Nothing) 46 | Just hprg -> case parseFile cfilename cfile (entities hprg) of 47 | Nothing -> (Just hres, Nothing) 48 | Just cprg -> (Just hres', Just cres) 49 | where res = compileToCCore' opts cprg 50 | cres = implementation res 51 | -- Un-duplicated hres. 52 | hres' = interface res 53 | where -- Will result in duplicate function declarations, but we 54 | -- just failed parsing the c file and return nothing for 55 | -- that so the user is probably not that picky on 56 | -- potential duplicate declarations if they had succeeded. 57 | hres = interface $ compileToCCore' opts hprg 58 | 59 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/Backend/C/Library.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (c) 2009-2011, ERICSSON AB 3 | -- All rights reserved. 4 | -- 5 | -- Redistribution and use in source and binary forms, with or without 6 | -- modification, are permitted provided that the following conditions are met: 7 | -- 8 | -- * Redistributions of source code must retain the above copyright notice, 9 | -- this list of conditions and the following disclaimer. 10 | -- * Redistributions in binary form must reproduce the above copyright 11 | -- notice, this list of conditions and the following disclaimer in the 12 | -- documentation and/or other materials provided with the distribution. 13 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 14 | -- may be used to endorse or promote products derived from this software 15 | -- without specific prior written permission. 16 | -- 17 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -- 28 | 29 | module Feldspar.Compiler.Backend.C.Library where 30 | 31 | import Data.List (isPrefixOf) 32 | import System.FilePath ((<.>)) 33 | 34 | -- =========================================================================== 35 | -- == String tools 36 | -- =========================================================================== 37 | 38 | replace :: Eq a => [a] -> [a] -> [a] -> [a] 39 | replace [] _ _ = [] 40 | replace s find repl | find `isPrefixOf` s = repl ++ replace (drop (length find) s) find repl 41 | | otherwise = head s : replace (tail s) find repl 42 | 43 | -- | Encode special characters in function names. 44 | encodeFunctionName :: String -> String 45 | encodeFunctionName functionName = replace (replace functionName "_" "__") "'" "_prime" 46 | 47 | makeDebugFileName :: String -> String 48 | makeDebugFileName = (<.> "dbg.txt") 49 | 50 | makeHFileName :: String -> String 51 | makeHFileName = (<.> "h") 52 | 53 | makeCFileName :: String -> String 54 | makeCFileName = (<.> "c") 55 | 56 | -------------------------------------------------------------------------------- /tests/gold/metrics.c: -------------------------------------------------------------------------------- 1 | #include "metrics.h" 2 | 3 | 4 | struct awl_signedS32 * initArray_awl_signedS32(struct awl_signedS32 * dst, uint32_t oldLen, uint32_t newLen) 5 | { 6 | if ((oldLen != newLen)) 7 | { 8 | if ((oldLen < newLen)) 9 | { 10 | dst = resizeArray(dst, sizeof(struct awl_signedS32), newLen); 11 | for (int32_t i = oldLen; i < newLen; i += 1) 12 | { 13 | struct awl_signedS32 null_arr_0 = { 0 }; 14 | 15 | dst[i] = null_arr_0; 16 | } 17 | } 18 | else 19 | { 20 | for (int32_t i = newLen; i < oldLen; i += 1) 21 | { 22 | freeArray((dst[i]).buffer); 23 | } 24 | dst = resizeArray(dst, sizeof(struct awl_signedS32), newLen); 25 | } 26 | } 27 | return(dst); 28 | } 29 | 30 | void freeArray_awl_signedS32(struct awl_signedS32 * src, int32_t srcLen) 31 | { 32 | for (int32_t i = 0; i < srcLen; i += 1) 33 | { 34 | freeArray((src[i]).buffer); 35 | } 36 | freeArray(src); 37 | } 38 | 39 | void metrics(struct awl_signedS32 * v1, struct awl_signedS32 * v2, struct awl_awl_s_2_unsignedS32_unsignedS32 * v3, struct awl_awl_signedS32 * out) 40 | { 41 | uint32_t v10; 42 | uint32_t v9; 43 | struct awl_awl_signedS32 v33 = { 0 }; 44 | uint32_t v19; 45 | struct awl_signedS32 st41 = { 0 }; 46 | struct awl_signedS32 * v14 = NULL; 47 | uint32_t v37; 48 | 49 | v10 = (*v3).length; 50 | v9 = (*v1).length; 51 | (st41).buffer = initArray((st41).buffer, (st41).length, sizeof(int32_t), 8); 52 | (st41).length = 8; 53 | for (uint32_t v6 = 0; v6 < 8; v6 += 1) 54 | { 55 | (st41).buffer[v6] = -32678; 56 | } 57 | v14 = &st41; 58 | (v33).buffer = initArray_awl_signedS32((v33).buffer, (v33).length, v10); 59 | (v33).length = v10; 60 | for (uint32_t v13 = 0; v13 < v10; v13 += 1) 61 | { 62 | v19 = min(((*v3).buffer[v13]).length, v9); 63 | ((v33).buffer[v13]).buffer = initArray(((v33).buffer[v13]).buffer, ((v33).buffer[v13]).length, sizeof(int32_t), v19); 64 | ((v33).buffer[v13]).length = v19; 65 | for (uint32_t v24 = 0; v24 < v19; v24 += 1) 66 | { 67 | ((v33).buffer[v13]).buffer[v24] = (*v14).buffer[(((*v3).buffer[v13]).buffer[v24]).member1]; 68 | } 69 | v14 = &(v33).buffer[v13]; 70 | } 71 | (*out).buffer = initArray_awl_signedS32((*out).buffer, (*out).length, v10); 72 | (*out).length = v10; 73 | for (uint32_t v34 = 0; v34 < v10; v34 += 1) 74 | { 75 | v37 = ((v33).buffer[v34]).length; 76 | ((*out).buffer[v34]).buffer = initArray(((*out).buffer[v34]).buffer, ((*out).buffer[v34]).length, sizeof(int32_t), v37); 77 | ((*out).buffer[v34]).length = v37; 78 | for (uint32_t v40 = 0; v40 < v37; v40 += 1) 79 | { 80 | ((*out).buffer[v34]).buffer[v40] = ((v33).buffer[v34]).buffer[v40]; 81 | } 82 | } 83 | freeArray_awl_signedS32((v33).buffer, (v33).length); 84 | freeArray((st41).buffer); 85 | } 86 | -------------------------------------------------------------------------------- /tests/gold/divConq3.c: -------------------------------------------------------------------------------- 1 | #include "divConq3.h" 2 | 3 | 4 | void task_core0(uint32_t v8, uint32_t v3, struct awl_signedS32 * v1, struct awl_i_awl_signedS32 v24) 5 | { 6 | uint32_t v9; 7 | uint32_t v12; 8 | struct awl_signedS32 e54 = { 0 }; 9 | 10 | v9 = (v8 << 10); 11 | v12 = min(1024, (v3 - v9)); 12 | (e54).buffer = initArray((e54).buffer, (e54).length, sizeof(int32_t), v12); 13 | (e54).length = v12; 14 | for (uint32_t v15 = 0; v15 < v12; v15 += 1) 15 | { 16 | (e54).buffer[v15] = ((*v1).buffer[(v15 + v9)] + 1); 17 | } 18 | ivar_put_array_shallow((v24).buffer[v8], &e54, sizeof(int32_t)); 19 | } 20 | 21 | void task0(void * params) 22 | { 23 | run4(task_core0, uint32_t, uint32_t, struct awl_signedS32 *, struct awl_i_awl_signedS32); 24 | } 25 | 26 | void divConq3(struct awl_signedS32 * v1, struct awl_signedS32 * out) 27 | { 28 | uint32_t v3; 29 | uint32_t v4; 30 | struct awl_i_awl_signedS32 v24 = { 0 }; 31 | struct awl_signedS32 v49 = { 0 }; 32 | uint32_t len55; 33 | struct awl_signedS32 v28 = { 0 }; 34 | uint32_t v34; 35 | struct awl_signedS32 v31 = { 0 }; 36 | struct ivar e56; 37 | uint32_t v32; 38 | uint32_t len57; 39 | struct awl_signedS32 e58 = { 0 }; 40 | uint32_t v50; 41 | 42 | taskpool_init(4, 4, 4); 43 | v3 = (*v1).length; 44 | v4 = (v3 >> 10); 45 | (v24).buffer = initArray((v24).buffer, (v24).length, sizeof(struct ivar), v4); 46 | (v24).length = v4; 47 | for (uint32_t v8 = 0; v8 < v4; v8 += 1) 48 | { 49 | ivar_init(&(v24).buffer[v8]); 50 | spawn4(task0, uint32_t, v8, uint32_t, v3, struct awl_signedS32 *, v1, struct awl_i_awl_signedS32, v24); 51 | } 52 | len55 = (v24).length; 53 | (v49).buffer = initArray((v49).buffer, (v49).length, sizeof(int32_t), 0); 54 | (v49).length = 0; 55 | for (uint32_t v27 = 0; v27 < len55; v27 += 1) 56 | { 57 | v34 = (v49).length; 58 | e56 = (v24).buffer[v27]; 59 | ivar_get_array_shallow_nontask(&v31, e56, sizeof(int32_t)); 60 | v32 = (v31).length; 61 | len57 = (v34 + v32); 62 | (v28).buffer = initArray((v28).buffer, (v28).length, sizeof(int32_t), len57); 63 | (v28).length = len57; 64 | for (uint32_t v39 = 0; v39 < v34; v39 += 1) 65 | { 66 | (v28).buffer[v39] = (v49).buffer[v39]; 67 | } 68 | for (uint32_t v43 = 0; v43 < v32; v43 += 1) 69 | { 70 | (v28).buffer[(v43 + v34)] = (v31).buffer[v43]; 71 | } 72 | e58 = v49; 73 | v49 = v28; 74 | v28 = e58; 75 | } 76 | v50 = (v49).length; 77 | (*out).buffer = initArray((*out).buffer, (*out).length, sizeof(int32_t), v50); 78 | (*out).length = v50; 79 | for (uint32_t v53 = 0; v53 < v50; v53 += 1) 80 | { 81 | (*out).buffer[v53] = (v49).buffer[v53]; 82 | } 83 | taskpool_shutdown(); 84 | freeArray((v24).buffer); 85 | freeArray((v49).buffer); 86 | freeArray((v28).buffer); 87 | freeArray((v31).buffer); 88 | ivar_destroy(&e56); 89 | } 90 | -------------------------------------------------------------------------------- /benchs/MatMul.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE ForeignFunctionInterface #-} 4 | 5 | module Main where 6 | 7 | import Feldspar (Data(..),Length,WordN) 8 | import Feldspar.Vector (mmMult, Pull(..), DIM2) 9 | import Feldspar.Compiler 10 | import Feldspar.Compiler.Plugin (loadFunOpts,loadFunOptsWith,pack) 11 | import Feldspar.Compiler.Marshal (Marshal(..),SA(..),allocSA) 12 | 13 | import Foreign.Marshal (new,newArray,mallocArray) 14 | -- Terrible error messages if constructors are not imported. See 15 | -- https://ghc.haskell.org/trac/ghc/ticket/5610 for more information. 16 | import Foreign.C.Types (CInt(..), CDouble(..)) 17 | import Foreign.Ptr (Ptr(..)) 18 | import Control.DeepSeq (NFData(..)) 19 | import Control.Exception (evaluate) 20 | 21 | import BenchmarkUtils 22 | import Criterion.Main 23 | 24 | testdata :: [Double] 25 | testdata = cycle [1.1,2.2,3.3,4.4] 26 | 27 | foreign import ccall unsafe "MatMulC.h MatMulC" matMulC :: CInt -> CInt -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO () 28 | 29 | foreign import ccall unsafe "MatMulC.h MatMulCopt" matMulCopt :: CInt -> CInt -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO () 30 | 31 | matmul :: Pull DIM2 (Data Double) -> Pull DIM2 (Data Double) -> Pull DIM2 (Data Double) 32 | matmul = mmMult True 33 | 34 | loadFunOpts ["-optc=-O2", "-optc=-fno-vectorize"] ['matmul] 35 | loadFunOptsWith "_sics" sicsOptions ["-optc=-O2", "-optc=-fno-vectorize"] ['matmul] 36 | 37 | len :: Length 38 | len = 64 39 | 40 | sizes :: [[Length]] 41 | sizes = map (map (*len)) [[1,1],[2,2],[4,4],[8,8]] 42 | 43 | instance NFData (Ptr a) where rnf !_ = () 44 | 45 | setupPlugins = do 46 | putStrLn "Compiling c_matmul plugin" 47 | evaluate c_matmul_builder 48 | evaluate c_matmul_sics_builder 49 | 50 | setupRefEnv :: [Length] -> IO (Ptr CDouble, Ptr CDouble) 51 | setupRefEnv ls = do 52 | let len = fromIntegral $ product ls 53 | let td = take len (map realToFrac testdata) 54 | o <- mallocArray len 55 | d <- newArray td 56 | return (o,d) 57 | 58 | allocOut :: [Length] -> IO (Ptr (Ptr (SA Length),Ptr (SA Double))) 59 | allocOut lengths = do 60 | ls <- pack lengths 61 | ds <- allocSA $ fromIntegral $ product lengths :: IO (Ptr (SA Double)) 62 | new (ls,ds) 63 | 64 | setupCompEnv ls = do 65 | o <- allocOut ls 66 | d <- mkData2 testdata ls 67 | return (o,d) 68 | 69 | mkReferenceBench :: [Length] -> [Benchmark] 70 | mkReferenceBench ls = 71 | [ env (setupRefEnv ls) $ \ ~(o,d) -> 72 | bench "C/matmul" (whnfIO $ matMulC (fromIntegral $ head ls) (fromIntegral $ product ls) d d o) 73 | , env (setupRefEnv ls) $ \ ~(o,d) -> 74 | bench "C/matmul_opt" (whnfIO $ matMulCopt (fromIntegral $ head ls) (fromIntegral $ product ls) d d o) 75 | ] 76 | 77 | mkCompiledBench :: [Length] -> [Benchmark] 78 | mkCompiledBench ls = 79 | [ env (setupCompEnv ls) $ \ ~(o,d) -> 80 | bench "Feldspar_C/matmul" (whnfIO $ c_matmul_raw d d o) 81 | , env (setupCompEnv ls) $ \ ~(o,d) -> 82 | bench "Feldspar_C/matmul_sics" (whnfIO $ c_matmul_sics_raw d d o) 83 | ] 84 | 85 | -- | Create a benchmark that compares references and Feldspar for a specific 86 | -- input. 87 | mkComparison :: [Length] -> Benchmark 88 | mkComparison ls = bgroup (dimToString ls) $ 89 | mkReferenceBench ls ++ mkCompiledBench ls 90 | 91 | main :: IO () 92 | main = do 93 | setupPlugins 94 | defaultMainWith (mkConfig "report_matmul.html") $ map mkComparison sizes 95 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/Backend/C/Options.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (c) 2009-2011, ERICSSON AB 3 | -- All rights reserved. 4 | -- 5 | -- Redistribution and use in source and binary forms, with or without 6 | -- modification, are permitted provided that the following conditions are met: 7 | -- 8 | -- * Redistributions of source code must retain the above copyright notice, 9 | -- this list of conditions and the following disclaimer. 10 | -- * Redistributions in binary form must reproduce the above copyright 11 | -- notice, this list of conditions and the following disclaimer in the 12 | -- documentation and/or other materials provided with the distribution. 13 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 14 | -- may be used to endorse or promote products derived from this software 15 | -- without specific prior written permission. 16 | -- 17 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -- 28 | 29 | {-# LANGUAGE GADTs #-} 30 | {-# LANGUAGE FlexibleContexts #-} 31 | {-# LANGUAGE FlexibleInstances #-} 32 | {-# LANGUAGE TypeSynonymInstances #-} 33 | {-# LANGUAGE MultiParamTypeClasses #-} 34 | 35 | module Feldspar.Compiler.Backend.C.Options where 36 | 37 | import Feldspar.Core.Interpretation (FeldOpts) 38 | import Feldspar.Compiler.Imperative.Representation (Type, Constant) 39 | 40 | data Options = 41 | Options 42 | { platform :: Platform 43 | , printHeader :: Bool 44 | , useNativeArrays :: Bool 45 | , useNativeReturns :: Bool -- ^ Should the generated function return by value or by 46 | -- reference (fast return)? This option will be ignored for 47 | -- types that can't be fast-returned. 48 | , frontendOpts :: FeldOpts -- ^ Options for the front end optimization chain 49 | , safetyLimit :: Integer -- ^ Threshold to stop when the size information gets lost. 50 | , nestSize :: Int -- ^ Indentation size for PrettyPrinting 51 | } 52 | 53 | data Platform = Platform { 54 | name :: String, 55 | types :: [(Type, String)], 56 | values :: [(Type, ShowValue)], 57 | includes :: [String], 58 | varFloating :: Bool, 59 | codeGenerator :: String 60 | } deriving (Show) 61 | 62 | type ShowValue = Constant () -> String 63 | 64 | -- * Renamer data types to avoid cyclic imports. 65 | 66 | type Rename = (String, [(Which, Destination)]) 67 | 68 | data Predicate = Complex | Float | Signed32 | Unsigned32 69 | deriving Show 70 | 71 | data Which = All | Only Predicate 72 | deriving Show 73 | 74 | data WhichType = FunType | ArgType 75 | deriving Show 76 | 77 | data Destination = 78 | Name String 79 | | Extend WhichType Platform 80 | | ExtendRename WhichType Platform String 81 | deriving Show 82 | -------------------------------------------------------------------------------- /clib/ivar.h: -------------------------------------------------------------------------------- 1 | // 2 | // Copyright (c) 2009-2011, ERICSSON AB 3 | // All rights reserved. 4 | // 5 | // Redistribution and use in source and binary forms, with or without 6 | // modification, are permitted provided that the following conditions are met: 7 | // 8 | // * Redistributions of source code must retain the above copyright notice, 9 | // this list of conditions and the following disclaimer. 10 | // * Redistributions in binary form must reproduce the above copyright 11 | // notice, this list of conditions and the following disclaimer in the 12 | // documentation and/or other materials provided with the distribution. 13 | // * Neither the name of the ERICSSON AB nor the names of its contributors 14 | // may be used to endorse or promote products derived from this software 15 | // without specific prior written permission. 16 | // 17 | // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | // AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | // IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | // DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | // FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | // DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | // SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | // CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | // OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | // 28 | 29 | #ifndef IVAR_H 30 | #define IVAR_H 31 | 32 | #include 33 | #include "feldspar_array.h" 34 | 35 | int feldspar_ivar_hook(void); 36 | 37 | struct ivar_internals 38 | { 39 | pthread_mutex_t mutex; 40 | pthread_cond_t cond; 41 | int full; 42 | void *data; 43 | }; 44 | 45 | struct ivar 46 | { 47 | struct ivar_internals *internals; 48 | struct ivar *self; 49 | }; 50 | 51 | /* Initializes 'iv'. */ 52 | void ivar_init( struct ivar *iv ); 53 | 54 | /* Deinitializes ivar 'iv'. */ 55 | void ivar_destroy( struct ivar *iv ); 56 | 57 | /* Copies the data at 'd' of size 'size' into the ivar 'iv'. Ivars are 58 | * allowed to be written only once! */ 59 | void ivar_put_with_size( struct ivar iv, void *d, int size ); 60 | 61 | /* Wrapper to 'ivar_put_with_size'. */ 62 | #define ivar_put(typ,iv,d) ivar_put_with_size(iv,d,sizeof(typ)) 63 | 64 | /* Specialized version for arrays. */ 65 | void ivar_put_array( struct ivar iv, void *d, void* cf ); 66 | void ivar_put_array_shallow( struct ivar iv, void *d, int32_t size ); 67 | 68 | /* Copies the data of size 'size' of the ivar 'iv' to 'var'. Ivars are 69 | * allowed to be read any number of times. Reading an empty ivar blocks 70 | * the thread, but a new worker thread is started instead. 71 | * Use this function only inside tasks! */ 72 | void ivar_get_with_size( void *var, struct ivar iv, int size ); 73 | 74 | /* Wrapper to 'ivar_get_with_size'. */ 75 | #define ivar_get(typ,var,iv) ivar_get_with_size(var,iv,sizeof(typ)) 76 | 77 | /* Specialized version for arrays. */ 78 | void ivar_get_array( void *var, struct ivar iv, void* cf ); 79 | void ivar_get_array_shallow( void *var, struct ivar iv, int32_t size ); 80 | 81 | /* Copies the data of size 'size' of the ivar 'iv' to 'var'. Ivars are 82 | * allowed to be read any number of times. Reading an empty ivar blocks 83 | * the thread. 84 | * Use this function only outside tasks, eg. the main thread or similar! */ 85 | void ivar_get_nontask_with_size( void *var, struct ivar iv, int size ); 86 | 87 | /* Wrapper to 'ivar_get_nontask_with_size'. */ 88 | #define ivar_get_nontask(typ,var,iv) ivar_get_nontask_with_size(var,iv,sizeof(typ)) 89 | 90 | /* Specialized version for arrays. */ 91 | void ivar_get_array_nontask( void *var, struct ivar iv, void* vcf ); 92 | void ivar_get_array_shallow_nontask( void *var, struct ivar iv, int32_t size ); 93 | 94 | #endif /* IVAR_H */ 95 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (c) 2009-2011, ERICSSON AB 3 | -- All rights reserved. 4 | -- 5 | -- Redistribution and use in source and binary forms, with or without 6 | -- modification, are permitted provided that the following conditions are met: 7 | -- 8 | -- * Redistributions of source code must retain the above copyright notice, 9 | -- this list of conditions and the following disclaimer. 10 | -- * Redistributions in binary form must reproduce the above copyright 11 | -- notice, this list of conditions and the following disclaimer in the 12 | -- documentation and/or other materials provided with the distribution. 13 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 14 | -- may be used to endorse or promote products derived from this software 15 | -- without specific prior written permission. 16 | -- 17 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -- 28 | 29 | import Distribution.Simple 30 | import Distribution.Simple.Setup 31 | import Distribution.Simple.LocalBuildInfo 32 | import Distribution.Simple.Program.Db 33 | import Distribution.Simple.Program.GHC 34 | import Distribution.Simple.Program.Builtin 35 | import Distribution.Simple.Program.Types 36 | import Distribution.Verbosity (verbose) 37 | import Distribution.PackageDescription 38 | 39 | import System.Process ( readProcessWithExitCode ) 40 | import System.FilePath ( replaceExtension ) 41 | import Control.Monad ( unless ) 42 | 43 | main = defaultMainWithHooks simpleUserHooks{ buildHook = buildH } 44 | 45 | -- | Custom build hook that builds C-sources for benchmarks with x-cc-name set. 46 | buildH :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () 47 | buildH pd lbi user_hooks flags = do 48 | benchmarks' <- mapM (checkIfAndCompile lbi) $ benchmarks pd 49 | -- Build the remaining things the regular way. 50 | buildHook simpleUserHooks pd{ benchmarks = benchmarks' } lbi user_hooks flags 51 | return () 52 | 53 | -- | Checks if x-cc-name is set, and compiles c-sources with that compiler name. 54 | checkIfAndCompile :: LocalBuildInfo -> Benchmark -> IO Benchmark 55 | checkIfAndCompile lbi bench = do 56 | let bench_bi = benchmarkBuildInfo bench 57 | case lookup "x-cc-name" $ customFieldsBI bench_bi of 58 | Nothing -> return bench 59 | Just cc_name -> do 60 | let c_srcs = cSources bench_bi 61 | cc_opts = ccOptions bench_bi 62 | inc_dirs = includeDirs bench_bi 63 | -- Compile C/C++ sources 64 | putStrLn "Invoking icc compiler" 65 | mapM_ (compile lbi bench cc_name cc_opts inc_dirs) c_srcs 66 | -- Remove C source code from the hooked build (don't change libs) 67 | return $ bench{ benchmarkBuildInfo = bench_bi{ cSources = [] } } 68 | 69 | -- | Compiles a C file with the given options. 70 | compile :: LocalBuildInfo -> Benchmark -> String -> [String] -> [String] -> FilePath -> IO () 71 | compile lbi bench cc_name opts inc_dirs srcfile = do 72 | let args = [ "-optc -std=c99" 73 | , "-optc -Wall" 74 | , "-w" 75 | , "-c" 76 | , "-pgmc " ++ cc_name 77 | ] ++ map ("-optc " ++) opts 78 | objfile = replaceExtension srcfile "o" 79 | fullargs = args ++ ["-o", objfile, srcfile] 80 | (ghcProg,_) <- requireProgram verbose ghcProgram (withPrograms lbi) 81 | let ghc = programPath ghcProg 82 | print $ unwords $ ["Calling:",ghc] ++ fullargs 83 | (_, stdout, stderr) <- readProcessWithExitCode ghc fullargs "" 84 | let output = stdout ++ stderr 85 | unless (null output) $ putStrLn output 86 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/Backend/C/Tic64x.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE PatternGuards #-} 3 | module Feldspar.Compiler.Backend.C.Tic64x (adaptTic64x) where 4 | 5 | import Feldspar.Compiler.Imperative.Representation 6 | import Feldspar.Compiler.Imperative.Frontend 7 | import Feldspar.Compiler.Backend.C.Options 8 | import Feldspar.Compiler.Backend.C.Platforms (extend, tic64x) 9 | 10 | -- This module does two major things: 11 | -- 12 | -- 1) Replaces all single argument functions where the argument is of complex 13 | -- type with a single named function. The renamer can't currently match on 14 | -- that. 15 | -- 2) Replaces complex typed "/=" and "bitCount" with an expression. 16 | -- 17 | -- TODO: Extend the renamer to cope with #1. 18 | 19 | -- | External interface for tic64x specific fixes. 20 | adaptTic64x :: Options -> Module () -> Module () 21 | adaptTic64x opts m 22 | | "tic64x" == (name $ platform opts) = adaptTic64x' m 23 | | otherwise = m 24 | 25 | -- | Internal interface for renaming. 26 | adaptTic64x' :: Module () -> Module () 27 | adaptTic64x' (Module ents) = Module $ map adaptTic64xEnt ents 28 | 29 | -- | Adapts entities. 30 | adaptTic64xEnt :: Entity () -> Entity () 31 | adaptTic64xEnt p@Proc{..} 32 | | Just body <- procBody = p { procBody = Just $ adaptTic64xBlock body } 33 | adaptTic64xEnt e = e 34 | 35 | -- | Adapts blocks. 36 | adaptTic64xBlock :: Block () -> Block () 37 | adaptTic64xBlock (Block vs p) = Block (map adaptTic64xDecl vs) (adaptTic64xProg p) 38 | 39 | -- | Adapts declarations. 40 | adaptTic64xDecl :: Declaration () -> Declaration () 41 | adaptTic64xDecl (Declaration v (Just e)) = Declaration v (Just $ adaptTic64xExp e) 42 | adaptTic64xDecl d = d 43 | 44 | -- | Adapts programs. 45 | adaptTic64xProg :: Program () -> Program () 46 | adaptTic64xProg e@Empty = e 47 | adaptTic64xProg c@Comment{} = c 48 | adaptTic64xProg (Assign lhs rhs) = Assign (adaptTic64xExp lhs) (adaptTic64xExp rhs) 49 | adaptTic64xProg (ProcedureCall n ps) = ProcedureCall n (map adaptTic64xParam ps) 50 | adaptTic64xProg (Sequence ps) = Sequence $ map adaptTic64xProg ps 51 | adaptTic64xProg (Switch scrut alts) 52 | = Switch (adaptTic64xExp scrut) (map adaptTic64xAlt alts) 53 | adaptTic64xProg (SeqLoop cond calc block) 54 | = SeqLoop (adaptTic64xExp cond) (adaptTic64xBlock calc) (adaptTic64xBlock block) 55 | adaptTic64xProg (ParLoop p v e0 e1 e2 b) 56 | = ParLoop p v (adaptTic64xExp e0) (adaptTic64xExp e1) (adaptTic64xExp e2) (adaptTic64xBlock b) 57 | adaptTic64xProg (BlockProgram b) = BlockProgram $ adaptTic64xBlock b 58 | 59 | -- | Adapts expressions. 60 | adaptTic64xExp :: Expression () -> Expression () 61 | adaptTic64xExp v@VarExpr{} = v 62 | adaptTic64xExp (ArrayElem e es) = ArrayElem (adaptTic64xExp e) $ map adaptTic64xExp es 63 | adaptTic64xExp (StructField e s) = StructField (adaptTic64xExp e) s 64 | adaptTic64xExp c@ConstExpr{} = c 65 | adaptTic64xExp (FunctionCall (Function "/=" t) [arg1,arg2]) | isComplex (typeof arg1) 66 | = fun t "!" [fun t (extend tic64x "equal" $ typeof arg1) [arg1, arg2]] 67 | adaptTic64xExp (FunctionCall (Function "bitCount" t) [arg]) | isComplex (typeof arg) 68 | = fun t "_dotpu4" [fun t "_bitc4" [arg], litI32 0x01010101] 69 | adaptTic64xExp (FunctionCall f es) 70 | = FunctionCall (adaptTic64xFun argtype (length es) f) $ map adaptTic64xExp es 71 | where argtype = typeof $ head es 72 | adaptTic64xExp (Cast t e) = Cast t $ adaptTic64xExp e 73 | adaptTic64xExp (AddrOf e) = AddrOf $ adaptTic64xExp e 74 | adaptTic64xExp s@SizeOf{} = s 75 | adaptTic64xExp (Deref e) = Deref $ adaptTic64xExp e 76 | 77 | -- | Adapts parameters. 78 | adaptTic64xParam :: ActualParameter () -> ActualParameter () 79 | adaptTic64xParam (ValueParameter e) = ValueParameter $ adaptTic64xExp e 80 | adaptTic64xParam p = p 81 | 82 | -- | Adapts switch alternatives. 83 | adaptTic64xAlt :: (Pattern (), Block ()) -> (Pattern (), Block ()) 84 | adaptTic64xAlt (p, b) = (p, adaptTic64xBlock b) 85 | 86 | -- | Adapts functions that should be adapted Identity function on others. 87 | adaptTic64xFun :: Type -> Int -> Function -> Function 88 | adaptTic64xFun argtype args f@(Function _ t) 89 | | isComplex argtype 90 | , args == 1 -- TODO: This transformation looks dangerous. 91 | = Function (extend tic64x "creal" argtype) t 92 | | otherwise = f 93 | -------------------------------------------------------------------------------- /clib/feldspar_array.h: -------------------------------------------------------------------------------- 1 | // 2 | // Copyright (c) 2009-2011, ERICSSON AB 3 | // All rights reserved. 4 | // 5 | // Redistribution and use in source and binary forms, with or without 6 | // modification, are permitted provided that the following conditions are met: 7 | // 8 | // * Redistributions of source code must retain the above copyright notice, 9 | // this list of conditions and the following disclaimer. 10 | // * Redistributions in binary form must reproduce the above copyright 11 | // notice, this list of conditions and the following disclaimer in the 12 | // documentation and/or other materials provided with the distribution. 13 | // * Neither the name of the ERICSSON AB nor the names of its contributors 14 | // may be used to endorse or promote products derived from this software 15 | // without specific prior written permission. 16 | // 17 | // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | // AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | // IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | // DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | // FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | // DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | // SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | // CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | // OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | // 28 | 29 | #ifndef FELDSPAR_ARRAY_H 30 | #define FELDSPAR_ARRAY_H 31 | 32 | #include 33 | #include 34 | #include 35 | #include 36 | //#define LOG 37 | #include "log.h" 38 | 39 | /* This library contains operations on flat arrays, arrays that do not contain 40 | (pointers to) other arrays. For non-flat arrays, these array operations are 41 | implemented by code generated from the program by the ArrayOps module. 42 | The size argument is always the size in bytes of each element. 43 | */ 44 | 45 | /* TODO qualify the names to avoid clashes with Haskell names */ 46 | 47 | struct array 48 | { 49 | void* buffer; /* pointer to the buffer of elements */ 50 | int32_t length; /* number of elements in the array */ 51 | }; 52 | 53 | /// Allocate and initialize a struct array if we did not have one already 54 | static inline struct array* allocArray( struct array* src ) 55 | { 56 | log_1( "allocArray %p\n", src ); 57 | if( src == NULL ) { 58 | src = malloc( sizeof(struct array) ); 59 | src->buffer = NULL; 60 | src->length = 0; 61 | } 62 | return src; 63 | } 64 | 65 | /// Resizing an existing array. 66 | static inline void* resizeArray( void* arr, int32_t size, int32_t len ) 67 | { 68 | log_3( "resize %p with size %d and len %d\n", arr, size, len ); 69 | return realloc( arr, len*size ); 70 | } 71 | 72 | /// Array (re)initialization for flat arrays. 73 | static inline void* initArray( void* arr, int32_t arrLen, int32_t size, int32_t newLen ) 74 | { 75 | log_4( "initArray %p with arrlen %d size %d newLen %d\n", arr, arrLen, size, newLen ); 76 | if( newLen != arrLen ) { 77 | arr = resizeArray( arr, size, newLen ); 78 | } 79 | return arr; 80 | } 81 | 82 | /// Free a flat array or an array where all the arrays it contains have been free'd already. 83 | // TODO: Think about arrays escaping from their scope. 84 | static inline void freeArray( void* arr ) 85 | { 86 | log_1( "freeArray %p\n", arr ); 87 | free( arr ); 88 | } 89 | 90 | /// Deep array copy to a given position for flat arrays. 91 | static inline void* copyArrayPos( void* dst, int32_t dstLen, int32_t size, void* src, int32_t srcLen, int32_t pos ) 92 | { 93 | if( srcLen > 0 ) { 94 | memcpy( dst + pos * size, src, srcLen * size ); 95 | } 96 | return dst; 97 | } 98 | 99 | /// Deep array copy for flat arrays. 100 | static inline void* copyArray( void* dst, int32_t dstLen, int32_t size, void* src, int32_t srcLen ) 101 | { 102 | return copyArrayPos( dst, dstLen, size, src, srcLen, 0 ); 103 | } 104 | 105 | /// Combined init and copy for flat arrays. 106 | static inline void* initCopyArray( void* dst, int32_t dstLen, int32_t size, void* src, int32_t srcLen ) 107 | { 108 | assert((src || !srcLen) && "source array not initialized" ); 109 | assert((src != dst || srcLen == dstLen) && "same source as destination but with different lengths" ); 110 | 111 | dst = initArray( dst, dstLen, size, srcLen ); 112 | return copyArrayPos( dst, dstLen, size, src, srcLen, 0 ); 113 | } 114 | #endif 115 | -------------------------------------------------------------------------------- /tests/gold/deepArrayCopy.c: -------------------------------------------------------------------------------- 1 | #include "deepArrayCopy.h" 2 | 3 | 4 | struct awl_awl_unsignedS32 * copyArrayPos_awl_awl_unsignedS32(struct awl_awl_unsignedS32 * dst, int32_t dstLen, struct awl_awl_unsignedS32 * src, int32_t srcLen, int32_t pos) 5 | { 6 | for (int32_t i = 0; i < srcLen; i += 1) 7 | { 8 | (dst[(pos + i)]).buffer = initCopyArray_awl_unsignedS32((dst[(pos + i)]).buffer, (dst[(pos + i)]).length, (src[i]).buffer, (src[i]).length); 9 | (dst[(pos + i)]).length = (src[i]).length; 10 | } 11 | return(dst); 12 | } 13 | 14 | struct awl_awl_unsignedS32 * copyArray_awl_awl_unsignedS32(struct awl_awl_unsignedS32 * dst, int32_t dstLen, struct awl_awl_unsignedS32 * src, int32_t srcLen) 15 | { 16 | dst = copyArrayPos_awl_awl_unsignedS32(dst, dstLen, src, srcLen, 0); 17 | return(dst); 18 | } 19 | 20 | struct awl_awl_unsignedS32 * initCopyArray_awl_awl_unsignedS32(struct awl_awl_unsignedS32 * dst, int32_t dstLen, struct awl_awl_unsignedS32 * src, int32_t srcLen) 21 | { 22 | dst = initArray_awl_awl_unsignedS32(dst, dstLen, srcLen); 23 | dstLen = srcLen; 24 | dst = copyArrayPos_awl_awl_unsignedS32(dst, dstLen, src, srcLen, 0); 25 | return(dst); 26 | } 27 | 28 | struct awl_unsignedS32 * copyArrayPos_awl_unsignedS32(struct awl_unsignedS32 * dst, int32_t dstLen, struct awl_unsignedS32 * src, int32_t srcLen, int32_t pos) 29 | { 30 | for (int32_t i = 0; i < srcLen; i += 1) 31 | { 32 | (dst[(pos + i)]).buffer = initCopyArray((dst[(pos + i)]).buffer, (dst[(pos + i)]).length, sizeof(uint32_t), (src[i]).buffer, (src[i]).length); 33 | (dst[(pos + i)]).length = (src[i]).length; 34 | } 35 | return(dst); 36 | } 37 | 38 | struct awl_unsignedS32 * copyArray_awl_unsignedS32(struct awl_unsignedS32 * dst, int32_t dstLen, struct awl_unsignedS32 * src, int32_t srcLen) 39 | { 40 | dst = copyArrayPos_awl_unsignedS32(dst, dstLen, src, srcLen, 0); 41 | return(dst); 42 | } 43 | 44 | struct awl_unsignedS32 * initCopyArray_awl_unsignedS32(struct awl_unsignedS32 * dst, int32_t dstLen, struct awl_unsignedS32 * src, int32_t srcLen) 45 | { 46 | dst = initArray_awl_unsignedS32(dst, dstLen, srcLen); 47 | dstLen = srcLen; 48 | dst = copyArrayPos_awl_unsignedS32(dst, dstLen, src, srcLen, 0); 49 | return(dst); 50 | } 51 | 52 | struct awl_awl_unsignedS32 * initArray_awl_awl_unsignedS32(struct awl_awl_unsignedS32 * dst, uint32_t oldLen, uint32_t newLen) 53 | { 54 | if ((oldLen != newLen)) 55 | { 56 | if ((oldLen < newLen)) 57 | { 58 | dst = resizeArray(dst, sizeof(struct awl_awl_unsignedS32), newLen); 59 | for (int32_t i = oldLen; i < newLen; i += 1) 60 | { 61 | struct awl_awl_unsignedS32 null_arr_0 = { 0 }; 62 | 63 | dst[i] = null_arr_0; 64 | } 65 | } 66 | else 67 | { 68 | for (int32_t i = newLen; i < oldLen; i += 1) 69 | { 70 | freeArray_awl_unsignedS32((dst[i]).buffer, (dst[i]).length); 71 | } 72 | dst = resizeArray(dst, sizeof(struct awl_awl_unsignedS32), newLen); 73 | } 74 | } 75 | return(dst); 76 | } 77 | 78 | void freeArray_awl_awl_unsignedS32(struct awl_awl_unsignedS32 * src, int32_t srcLen) 79 | { 80 | for (int32_t i = 0; i < srcLen; i += 1) 81 | { 82 | freeArray_awl_unsignedS32((src[i]).buffer, (src[i]).length); 83 | } 84 | freeArray(src); 85 | } 86 | 87 | struct awl_unsignedS32 * initArray_awl_unsignedS32(struct awl_unsignedS32 * dst, uint32_t oldLen, uint32_t newLen) 88 | { 89 | if ((oldLen != newLen)) 90 | { 91 | if ((oldLen < newLen)) 92 | { 93 | dst = resizeArray(dst, sizeof(struct awl_unsignedS32), newLen); 94 | for (int32_t i = oldLen; i < newLen; i += 1) 95 | { 96 | struct awl_unsignedS32 null_arr_0 = { 0 }; 97 | 98 | dst[i] = null_arr_0; 99 | } 100 | } 101 | else 102 | { 103 | for (int32_t i = newLen; i < oldLen; i += 1) 104 | { 105 | freeArray((dst[i]).buffer); 106 | } 107 | dst = resizeArray(dst, sizeof(struct awl_unsignedS32), newLen); 108 | } 109 | } 110 | return(dst); 111 | } 112 | 113 | void freeArray_awl_unsignedS32(struct awl_unsignedS32 * src, int32_t srcLen) 114 | { 115 | for (int32_t i = 0; i < srcLen; i += 1) 116 | { 117 | freeArray((src[i]).buffer); 118 | } 119 | freeArray(src); 120 | } 121 | 122 | void deepArrayCopy(struct awl_awl_awl_unsignedS32 * v0, struct s_2_awl_awl_awl_unsignedS32_awl_awl_awl_unsignedS32 * out) 123 | { 124 | ((*out).member1).buffer = initCopyArray_awl_awl_unsignedS32(((*out).member1).buffer, ((*out).member1).length, (*v0).buffer, (*v0).length); 125 | ((*out).member1).length = (*v0).length; 126 | ((*out).member2).buffer = initCopyArray_awl_awl_unsignedS32(((*out).member2).buffer, ((*out).member2).length, (*v0).buffer, (*v0).length); 127 | ((*out).member2).length = (*v0).length; 128 | } 129 | -------------------------------------------------------------------------------- /tests/CallingConvention.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE ForeignFunctionInterface #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | 8 | -- | Test that the compiler respects the calling conventions of Feldspar 9 | 10 | module Main where 11 | 12 | import qualified Prelude 13 | 14 | import Test.Tasty 15 | import Test.Tasty.QuickCheck 16 | import Test.QuickCheck 17 | 18 | import Feldspar hiding (assert) 19 | import Feldspar.Vector 20 | import Feldspar.Compiler 21 | import Feldspar.Compiler.Plugin 22 | import Feldspar.Core.NestedTuples 23 | 24 | import Control.Applicative 25 | 26 | -- | Arbitrary instances for nested tuples 27 | instance Arbitrary (Tuple TNil) where 28 | arbitrary = return TNil 29 | 30 | instance (Arbitrary a, Arbitrary (Tuple b)) => Arbitrary (Tuple (a :* b)) where 31 | arbitrary = do a <- arbitrary 32 | b <- arbitrary 33 | return (a :* b) 34 | 35 | vector1D :: Length -> Gen a -> Gen [a] 36 | vector1D l = vectorOf (Prelude.fromIntegral l) 37 | 38 | pairArg :: (Data Word8,Data IntN) -> Data IntN 39 | pairArg (a,b) = i2n a + b 40 | 41 | pairRes :: Data Word16 -> (Data WordN, Data IntN) 42 | pairRes a = (i2n a, i2n a) 43 | 44 | vecId :: Pull1 Word32 -> Pull1 Word32 45 | vecId = id 46 | 47 | vectorInPair :: (Pull1 WordN, Data WordN) -> (Data WordN, Pull1 WordN) 48 | vectorInPair (v,a) = (a,v) 49 | 50 | vectorInVector :: Pull DIM1 (Pull1 WordN) -> Data WordN 51 | vectorInVector v = fromZero $ sum $ map (fromZero . sum) v 52 | 53 | vectorInPairInVector :: Data WordN -> Pull DIM1 (Data WordN, Pull1 WordN) 54 | vectorInPairInVector l = indexed1 l $ \i -> (i, indexed1 i id) 55 | 56 | shTest :: Data Length -> Data Length 57 | shTest n = runMutable $ do 58 | a <- newArr n 1 59 | c <- newArr n 2 60 | let d = n<5 ? a $ c 61 | setArr d 0 n 62 | b <- getArr a $ 0 63 | return b 64 | 65 | arrayInStructR :: Data [Length] -> Data [Length] 66 | arrayInStructR a = snd $ whileLoop (getLength a, a) (\(n,_) -> (n>0)) (\(n,a) -> (n-1, parallel (getLength a) (\ i -> a!i + 5))) 67 | 68 | pairParamR :: (Data Index, Data Index) -> Data Index 69 | pairParamR (x, _) = x 70 | 71 | pairParam2R :: (Data Int16, Data Int16) -> 72 | ((Data Int16, Data Int16), (Data Int16, Data Int16)) 73 | pairParam2R c = (c, c) 74 | 75 | copyPushR :: Pull1 Index -> DPush DIM1 Index 76 | copyPushR v = let pv = toPush v in pv ++ pv 77 | 78 | complexWhileCondR :: Data Int32 -> (Data Int32, Data Int32) 79 | complexWhileCondR y = whileLoop (0,y) (\(a,b) -> ((\a b -> a * a < b * b) a (b-a))) (\(a,b) -> (a+1,b)) 80 | 81 | deepArrayCopyTest :: Data [[[Length]]] -> (Data [[[Length]]], Data [[[Length]]]) 82 | deepArrayCopyTest xs = (xs, xs) 83 | 84 | loadFun ['pairArg] 85 | loadFun ['pairRes] 86 | loadFun ['vecId] 87 | loadFun ['vectorInPair] 88 | loadFun ['vectorInVector] 89 | loadFun ['vectorInPairInVector] 90 | loadFun ['shTest] 91 | loadFun ['arrayInStructR] 92 | loadFun ['pairParamR] 93 | loadFun ['pairParam2R] 94 | loadFun ['copyPushR] 95 | loadFun ['complexWhileCondR] 96 | loadFun ['deepArrayCopyTest] 97 | 98 | prop_pairArg = eval pairArg ==== c_pairArg 99 | prop_pairRes = eval pairRes ==== c_pairRes 100 | prop_vecId (Small l) = 101 | forAll (vector1D l arbitrary) $ \xs -> 102 | eval vecId xs ==== c_vecId xs 103 | prop_vectorInPair (Small l) = 104 | forAll (npair <$> vector1D l arbitrary <*> arbitrary) $ \p -> 105 | eval vectorInPair p ==== c_vectorInPair p 106 | prop_vectorInVector (Small l1) (Small l2) = 107 | forAll (vector1D l1 (vector1D l2 arbitrary)) $ \v -> 108 | eval vectorInVector v ==== c_vectorInVector v 109 | prop_vectorInPairInVector (Small l) = eval vectorInPairInVector l ==== c_vectorInPairInVector l 110 | prop_shTest (Positive n) = eval shTest n ==== c_shTest n 111 | prop_deepArrayCopyTest = eval deepArrayCopyTest ==== c_deepArrayCopyTest 112 | 113 | prop_arrayInStruct = eval arrayInStructR ==== c_arrayInStructR 114 | prop_pairParam = eval pairParamR ==== c_pairParamR 115 | prop_pairParam2 = eval pairParam2R ==== c_pairParam2R 116 | prop_copyPush = eval copyPushR ==== c_copyPushR 117 | prop_complexWhileCond (Small n) = eval complexWhileCondR n ==== c_complexWhileCondR n 118 | 119 | tests :: TestTree 120 | tests = testGroup "CallingConvention" 121 | [ testProperty "pairArg" prop_pairArg 122 | , testProperty "pairRes" prop_pairRes 123 | , testProperty "vecId" prop_vecId 124 | , testProperty "vectorInPair" prop_vectorInPair 125 | , testProperty "vectorInVector" prop_vectorInVector 126 | -- TODO: This test case will cause a segmentation fault due to issue #145 127 | -- , testProperty "vectorInPairInVector" prop_vectorInPairInVector 128 | , testProperty "arrayInStruct" prop_arrayInStruct 129 | , testProperty "pairParam" prop_pairParam 130 | , testProperty "pairParam2" prop_pairParam2 131 | , testProperty "copyPush" prop_copyPush 132 | , testProperty "complexWhileCond" prop_complexWhileCond 133 | , testProperty "deepArrayCopy" prop_deepArrayCopyTest 134 | ] 135 | 136 | main :: IO () 137 | main = defaultMain tests 138 | -------------------------------------------------------------------------------- /feldspar-compiler.cabal: -------------------------------------------------------------------------------- 1 | name: feldspar-compiler 2 | version: 0.6.1.0 3 | cabal-version: 1.24 4 | build-type: Custom 5 | license: BSD3 6 | license-file: LICENSE 7 | copyright: Copyright (c) 2013-2015 Emil Axelsson, Peter Jonsson, 8 | Anders Persson, Josef Svenningsson 9 | Copyright (c) 2012 Emil Axelsson, Gergely Dévai, 10 | Anders Persson, Josef Svenningsson 11 | Copyright (c) 2009-2011, ERICSSON AB 12 | author: Feldspar group, 13 | Eotvos Lorand University Faculty of Informatics 14 | maintainer: Emil Axelsson , 15 | Anders Persson 16 | stability: experimental 17 | homepage: http://feldspar.github.com 18 | bug-reports: https://github.com/feldspar/feldspar-compiler/issues 19 | synopsis: Compiler for the Feldspar language 20 | description: Feldspar (**F**unctional **E**mbedded **L**anguage for **DSP** 21 | and **PAR**allelism) is an embedded DSL for describing digital 22 | signal processing algorithms. 23 | This library (FeldsparCompiler) contains a prototype compiler 24 | that supports C code generation from programs written in this 25 | language both according to ANSI C and also targeted to a real 26 | DSP HW. 27 | category: Compiler 28 | 29 | source-repository head 30 | type: git 31 | location: git://github.com/Feldspar/feldspar-compiler.git 32 | 33 | Flag UseICC 34 | Description: Use ICC for compiling benchmarks. 35 | Default: False 36 | 37 | library 38 | hs-source-dirs: src 39 | 40 | exposed-modules: 41 | Feldspar.Compiler 42 | Feldspar.Compiler.Imperative.ArrayOps 43 | Feldspar.Compiler.Imperative.Representation 44 | Feldspar.Compiler.Imperative.ExternalProgram 45 | Feldspar.Compiler.Imperative.FromCore 46 | Feldspar.Compiler.Imperative.FromCore.Interpretation 47 | Feldspar.Compiler.Imperative.Frontend 48 | Feldspar.Compiler.Backend.C.CodeGeneration 49 | Feldspar.Compiler.Backend.C.Library 50 | Feldspar.Compiler.Backend.C.MachineLowering 51 | Feldspar.Compiler.Backend.C.Tic64x 52 | Feldspar.Compiler.Backend.C.Options 53 | Feldspar.Compiler.Backend.C.Platforms 54 | Feldspar.Compiler.Backend.C.RuntimeLibrary 55 | Feldspar.Compiler.Frontend.Interactive.Interface 56 | Feldspar.Compiler.Plugin 57 | Feldspar.Compiler.Marshal 58 | Feldspar.Compiler.CallConv 59 | Feldspar.Compiler.Compiler 60 | Feldspar.Compiler.Error 61 | Feldspar.Compiler.ExternalProgram 62 | Feldspar.Runtime 63 | 64 | default-language: Haskell2010 65 | 66 | build-depends: 67 | base == 4.*, 68 | base-compat >= 0.8, 69 | Cabal, 70 | ghc, 71 | ghc-paths, 72 | plugins-multistage >= 0.6.3 && < 0.7, 73 | feldspar-language >= 0.6.1 && < 0.7, 74 | language-c-quote >= 0.12 && < 0.13, 75 | bytestring >= 0.9 && < 0.11, 76 | srcloc, 77 | mtl, 78 | pretty, 79 | filepath, 80 | containers, 81 | process, 82 | directory >= 1.1, 83 | template-haskell, 84 | data-default >= 0.5, 85 | storable-tuple >= 0.0.2, 86 | storable-record >= 0.0.2.5 87 | 88 | if impl(ghc >= 8.0.0) 89 | build-depends: 90 | ghci 91 | 92 | default-extensions: 93 | 94 | include-dirs: 95 | ./clib 96 | 97 | cpp-options: -DCABAL_IS_USED 98 | -- Is there already such a symbol defined? 99 | 100 | c-sources: 101 | clib/feldspar_c99.c 102 | clib/taskpool.c 103 | clib/ivar.c 104 | 105 | cc-options: -std=c99 -Wall -fPIC 106 | 107 | if os(linux) 108 | extra-libraries: gcc_s pthread 109 | -- pthread needed on Emil's Ubuntu (15.04), but apparently not on Travis 110 | 111 | install-includes: 112 | feldspar_array.h 113 | feldspar_c99.h 114 | feldspar_c99.c 115 | feldspar_tic64x.h 116 | feldspar_tic64x.c 117 | feldspar_future.h 118 | log.h 119 | ivar.h 120 | ivar.c 121 | taskpool.h 122 | taskpool.c 123 | 124 | ghc-options: -freduction-depth=100 125 | 126 | test-suite regression 127 | type: exitcode-stdio-1.0 128 | 129 | hs-source-dirs: tests 130 | 131 | main-is: RegressionTests.hs 132 | 133 | default-language: Haskell2010 134 | 135 | build-depends: 136 | feldspar-language, 137 | feldspar-compiler, 138 | mtl, 139 | base, 140 | Cabal, 141 | process, 142 | bytestring >= 0.9 && < 0.11, 143 | stringsearch >= 0.3, 144 | tasty >= 0.3, 145 | tasty-golden >= 2.3.0.1, 146 | tasty-quickcheck >= 0.3, 147 | QuickCheck >= 2.7.1 && < 3.0 148 | 149 | test-suite callconv 150 | type: exitcode-stdio-1.0 151 | 152 | hs-source-dirs: tests 153 | 154 | main-is: CallingConvention.hs 155 | 156 | default-language: Haskell2010 157 | 158 | build-depends: 159 | feldspar-language, 160 | feldspar-compiler, 161 | base, 162 | tasty >= 0.3, 163 | tasty-quickcheck >= 0.3, 164 | QuickCheck >= 2.7.1 && < 3.0 165 | 166 | benchmark crc 167 | type: exitcode-stdio-1.0 168 | 169 | hs-source-dirs: benchs 170 | 171 | main-is: CRC.hs 172 | 173 | default-language: Haskell2010 174 | 175 | ghc-options: -O2 176 | 177 | build-depends: 178 | feldspar-language, 179 | feldspar-compiler, 180 | data-default >= 0.5.3 && < 0.6, 181 | base, 182 | deepseq, 183 | criterion >= 1.0 184 | 185 | benchmark fft 186 | type: exitcode-stdio-1.0 187 | 188 | hs-source-dirs: benchs 189 | 190 | main-is: FFT.hs 191 | 192 | default-language: Haskell2010 193 | 194 | ghc-options: -O2 195 | 196 | build-depends: 197 | feldspar-language, 198 | feldspar-compiler, 199 | data-default >= 0.5.3 && < 0.6, 200 | base, 201 | deepseq, 202 | criterion 203 | 204 | benchmark matmul 205 | type: exitcode-stdio-1.0 206 | 207 | hs-source-dirs: benchs 208 | 209 | main-is: MatMul.hs 210 | 211 | c-sources: benchs/MatMulC.c 212 | 213 | default-language: Haskell2010 214 | 215 | ghc-options: -O2 216 | 217 | CC-Options: -fno-vectorize 218 | if flag(UseICC) 219 | x-cc-name: icc 220 | 221 | build-depends: 222 | feldspar-language, 223 | feldspar-compiler, 224 | plugins-multistage, 225 | data-default >= 0.5.3 && < 0.6, 226 | base, 227 | deepseq, 228 | criterion 229 | 230 | custom-setup 231 | setup-depends: 232 | base, 233 | Cabal, 234 | filepath, 235 | process 236 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/Backend/C/Platforms.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (c) 2009-2011, ERICSSON AB 3 | -- All rights reserved. 4 | -- 5 | -- Redistribution and use in source and binary forms, with or without 6 | -- modification, are permitted provided that the following conditions are met: 7 | -- 8 | -- * Redistributions of source code must retain the above copyright notice, 9 | -- this list of conditions and the following disclaimer. 10 | -- * Redistributions in binary form must reproduce the above copyright 11 | -- notice, this list of conditions and the following disclaimer in the 12 | -- documentation and/or other materials provided with the distribution. 13 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 14 | -- may be used to endorse or promote products derived from this software 15 | -- without specific prior written permission. 16 | -- 17 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -- 28 | 29 | {-# LANGUAGE RecordWildCards #-} 30 | 31 | module Feldspar.Compiler.Backend.C.Platforms 32 | ( availablePlatforms 33 | , platformFromName 34 | , c99 35 | , c99OpenMp 36 | , c99Wool 37 | , tic64x 38 | , extend 39 | ) where 40 | 41 | import Data.Maybe (fromMaybe) 42 | 43 | import Feldspar.Compiler.Backend.C.Options 44 | import Feldspar.Compiler.Imperative.Representation 45 | import Feldspar.Compiler.Imperative.Frontend 46 | 47 | availablePlatforms :: [Platform] 48 | availablePlatforms = [ c99, c99OpenMp, c99Wool, ba, tic64x ] 49 | 50 | platformFromName :: String -> Platform 51 | platformFromName str = head $ [pf | pf <- availablePlatforms, name pf == str] 52 | ++ error ("Platform.platformFromName: No platform named " ++ str) 53 | 54 | c99 :: Platform 55 | c99 = Platform { 56 | name = "c99", 57 | types = 58 | [ (1 :# (NumType Signed S8), "int8_t") 59 | , (1 :# (NumType Signed S16), "int16_t") 60 | , (1 :# (NumType Signed S32), "int32_t") 61 | , (1 :# (NumType Signed S64), "int64_t") 62 | , (1 :# (NumType Unsigned S8), "uint8_t") 63 | , (1 :# (NumType Unsigned S16), "uint16_t") 64 | , (1 :# (NumType Unsigned S32), "uint32_t") 65 | , (1 :# (NumType Unsigned S64), "uint64_t") 66 | , (1 :# BoolType, "bool") 67 | , (1 :# FloatType, "float") 68 | , (1 :# DoubleType, "double") 69 | , (1 :# (ComplexType (1 :# FloatType)), "float complex") 70 | , (1 :# (ComplexType (1 :# DoubleType)), "double complex") 71 | ] , 72 | values = 73 | [ (1 :# (ComplexType (1 :# FloatType)), \cx -> "(" ++ showRe cx ++ "+" ++ showIm cx ++ "i)") 74 | , (1 :# (ComplexType (1 :# DoubleType)), \cx -> "(" ++ showRe cx ++ "+" ++ showIm cx ++ "i)") 75 | , (1 :# BoolType, \b -> if boolValue b then "true" else "false") 76 | ] , 77 | includes = 78 | [ "feldspar_c99.h" 79 | , "feldspar_array.h" 80 | , "feldspar_future.h" 81 | , "ivar.h" 82 | , "taskpool.h" 83 | , "" 84 | , "" 85 | , "" 86 | , "" 87 | , ""], 88 | varFloating = True, 89 | codeGenerator = "c" 90 | } 91 | 92 | c99OpenMp :: Platform 93 | c99OpenMp = c99 { name = "c99OpenMp" 94 | , varFloating = False 95 | } 96 | 97 | c99Wool :: Platform 98 | c99Wool = c99 { name = "c99Wool" 99 | , includes = "wool.h":includes c99 100 | , varFloating = False 101 | } 102 | 103 | ba :: Platform 104 | ba = c99 { name = "ba" 105 | , codeGenerator = "ba" 106 | } 107 | 108 | tic64x :: Platform 109 | tic64x = Platform { 110 | name = "tic64x", 111 | types = 112 | [ (1 :# (NumType Signed S8), "char") 113 | , (1 :# (NumType Signed S16), "short") 114 | , (1 :# (NumType Signed S32), "int") 115 | , (1 :# (NumType Signed S40), "long") 116 | , (1 :# (NumType Signed S64), "long long") 117 | , (1 :# (NumType Unsigned S8), "unsigned char") 118 | , (1 :# (NumType Unsigned S16), "unsigned short") 119 | , (1 :# (NumType Unsigned S32), "unsigned") 120 | , (1 :# (NumType Unsigned S40), "unsigned long") 121 | , (1 :# (NumType Unsigned S64), "unsigned long long") 122 | , (1 :# BoolType, "int") 123 | , (1 :# FloatType, "float") 124 | , (1 :# DoubleType, "double") 125 | , (1 :# (ComplexType (1 :# FloatType)), "complexOf_float") 126 | , (1 :# (ComplexType (1 :# DoubleType)), "complexOf_double") 127 | ] , 128 | values = 129 | [ (1 :# (ComplexType (1 :# FloatType)), \cx -> "complex_fun_float(" ++ showRe cx ++ "," ++ showIm cx ++ ")") 130 | , (1 :# (ComplexType (1 :# DoubleType)), \cx -> "complex_fun_double(" ++ showRe cx ++ "," ++ showIm cx ++ ")") 131 | , (1 :# BoolType, \b -> if boolValue b then "1" else "0") 132 | ] , 133 | includes = [ "feldspar_tic64x.h", "feldspar_array.h", "", "" 134 | , ""], 135 | varFloating = True, 136 | codeGenerator = "c" 137 | } 138 | 139 | showRe, showIm :: Constant t -> String 140 | showRe = showConstant . realPartComplexValue 141 | showIm = showConstant . imagPartComplexValue 142 | 143 | showConstant :: Constant t -> String 144 | showConstant (DoubleConst c) = show c ++ "f" 145 | showConstant (FloatConst c) = show c ++ "f" 146 | showConstant c = show c 147 | 148 | extend :: Platform -> String -> Type -> String 149 | extend Platform{..} s t = s ++ "_fun_" ++ fromMaybe (show t) (lookup t types) 150 | 151 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/Marshal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | -- | Marshaling between Feldspar and C99 types 10 | -- 11 | module Feldspar.Compiler.Marshal 12 | ( SA(..) 13 | , allocSA 14 | , Marshal(..) 15 | ) 16 | where 17 | 18 | import System.Plugins.MultiStage 19 | import Feldspar.Core.Types (IntN(..), WordN(..), Tuple(..), (:*), TNil) 20 | import Feldspar.Core.NestedTuples (npair) 21 | 22 | import Data.Int (Int32) 23 | import Data.Word (Word32) 24 | import Data.Complex (Complex(..)) 25 | import Data.Default 26 | import Control.Applicative 27 | 28 | import Foreign.Ptr 29 | import Foreign.Marshal (free, new, newArray, peekArray,mallocBytes) 30 | import Foreign.Storable (Storable(..)) 31 | import Foreign.Storable.Tuple () 32 | import qualified Foreign.Storable.Record as Store 33 | 34 | instance Reference IntN where type Ref IntN = IntN 35 | instance Reference WordN where type Ref WordN = WordN 36 | instance Reference (Complex a) where type Ref (Complex a) = Complex a 37 | 38 | instance Marshal IntN where type Rep IntN = IntN 39 | instance Marshal WordN where type Rep WordN = WordN 40 | instance Marshal (Complex a) where type Rep (Complex a) = Complex a 41 | 42 | instance Default (Ptr a) where def = nullPtr 43 | 44 | instance (Storable (Rep a), Marshal a) => Marshal [a] 45 | where 46 | type Rep [a] = SA (Rep a) 47 | to xs = do 48 | let len = fromIntegral $ length xs 49 | let size = fromIntegral $ sizeOf (undefined :: Rep a) 50 | ys <- mapM to xs 51 | buffer <- newArray ys 52 | return $ SA buffer len 53 | from p | elems p == 0 = return [] 54 | from p = go p 55 | where 56 | go SA{..} = do 57 | res <- mapM from =<< peekArray (fromIntegral elems) buf 58 | free buf 59 | return res 60 | 61 | 62 | -- | Buffer descriptor for Feldspar arrays 63 | data SA a = SA { buf :: Ptr a 64 | , elems :: Int32 65 | } 66 | deriving (Eq, Show) 67 | 68 | instance Default (SA a) where 69 | def = SA nullPtr def 70 | 71 | allocSA :: forall a. Storable a => Int -> IO (Ptr (SA a)) 72 | allocSA len = do 73 | let size = fromIntegral $ sizeOf (undefined :: a) 74 | let bytes = len * size 75 | buffer <- mallocBytes bytes 76 | new $ SA buffer (fromIntegral len) 77 | 78 | storeSA :: Storable a => Store.Dictionary (SA a) 79 | storeSA = Store.run $ SA 80 | <$> Store.element buf 81 | <*> Store.element elems 82 | 83 | instance Storable a => Storable (SA a) 84 | where 85 | sizeOf = Store.sizeOf storeSA 86 | alignment = Store.alignment storeSA 87 | peek = Store.peek storeSA 88 | poke = Store.poke storeSA 89 | 90 | instance Reference (Ptr a) 91 | where 92 | type Ref (Ptr a) = Ptr a 93 | ref = return 94 | deref = return 95 | 96 | instance (Storable a) => Reference (SA a) 97 | where 98 | type Ref (SA a) = Ptr (SA a) 99 | ref = new 100 | deref = peek 101 | 102 | instance (Storable (a,b)) => Reference (a,b) 103 | where 104 | type Ref (a,b) = Ptr (a,b) 105 | ref = new 106 | deref = peek 107 | 108 | instance (Storable (a,b,c)) => Reference (a,b,c) 109 | where 110 | type Ref (a,b,c) = Ptr (a,b,c) 111 | ref = new 112 | deref = peek 113 | 114 | instance (Storable (a,b,c,d)) => Reference (a,b,c,d) 115 | where 116 | type Ref (a,b,c,d) = Ptr (a,b,c,d) 117 | ref = new 118 | deref = peek 119 | 120 | instance (Storable (a,b,c,d,e)) => Reference (a,b,c,d,e) 121 | where 122 | type Ref (a,b,c,d,e) = Ptr (a,b,c,d,e) 123 | ref = new 124 | deref = peek 125 | 126 | instance (Storable (a,b,c,d,e,f)) => Reference (a,b,c,d,e,f) 127 | where 128 | type Ref (a,b,c,d,e,f) = Ptr (a,b,c,d,e,f) 129 | ref = new 130 | deref = peek 131 | 132 | instance (Storable (a,b,c,d,e,f,g)) => Reference (a,b,c,d,e,f,g) 133 | where 134 | type Ref (a,b,c,d,e,f,g) = Ptr (a,b,c,d,e,f,g) 135 | ref = new 136 | deref = peek 137 | 138 | instance ( Marshal a 139 | , Marshal b 140 | ) => Marshal (a,b) 141 | where 142 | type Rep (a,b) = (Rep a,Rep b) 143 | to (a,b) = (,) <$> to a <*> to b 144 | from (a,b) = (,) <$> from a <*> from b 145 | 146 | instance ( Marshal a 147 | , Marshal b 148 | , Marshal c 149 | ) => Marshal (a,b,c) 150 | where 151 | type Rep (a,b,c) = (Rep a,Rep b,Rep c) 152 | to (a,b,c) = (,,) <$> to a <*> to b <*> to c 153 | from (a,b,c) = (,,) <$> from a <*> from b <*> from c 154 | 155 | instance ( Marshal a 156 | , Marshal b 157 | , Marshal c 158 | , Marshal d 159 | ) => Marshal (a,b,c,d) 160 | where 161 | type Rep (a,b,c,d) = (Rep a,Rep b,Rep c,Rep d) 162 | to (a,b,c,d) = 163 | (,,,) <$> to a <*> to b <*> to c <*> to d 164 | from (a,b,c,d) = 165 | (,,,) <$> from a <*> from b <*> from c <*> from d 166 | 167 | instance ( Marshal a 168 | , Marshal b 169 | , Marshal c 170 | , Marshal d 171 | , Marshal e 172 | ) => Marshal (a,b,c,d,e) 173 | where 174 | type Rep (a,b,c,d,e) = (Rep a,Rep b,Rep c,Rep d,Rep e) 175 | to (a,b,c,d,e) = 176 | (,,,,) <$> to a <*> to b <*> to c <*> to d <*> to e 177 | from (a,b,c,d,e) = 178 | (,,,,) <$> from a <*> from b <*> from c <*> from d <*> from e 179 | 180 | instance ( Marshal a 181 | , Marshal b 182 | , Marshal c 183 | , Marshal d 184 | , Marshal e 185 | , Marshal f 186 | ) => Marshal (a,b,c,d,e,f) 187 | where 188 | type Rep (a,b,c,d,e,f) = (Rep a,Rep b,Rep c,Rep d,Rep e,Rep f) 189 | to (a,b,c,d,e,f) = 190 | (,,,,,) <$> to a <*> to b <*> to c <*> to d <*> to e <*> to f 191 | from (a,b,c,d,e,f) = 192 | (,,,,,) <$> from a <*> from b <*> from c <*> from d <*> from e <*> from f 193 | 194 | instance ( Marshal a 195 | , Marshal b 196 | , Marshal c 197 | , Marshal d 198 | , Marshal e 199 | , Marshal f 200 | , Marshal g 201 | ) => Marshal (a,b,c,d,e,f,g) 202 | where 203 | type Rep (a,b,c,d,e,f,g) = (Rep a,Rep b,Rep c,Rep d,Rep e,Rep f,Rep g) 204 | to (a,b,c,d,e,f,g) = 205 | (,,,,,,) <$> to a <*> to b <*> to c <*> to d <*> to e <*> to f <*> to g 206 | from (a,b,c,d,e,f,g) = 207 | (,,,,,,) <$> from a <*> from b <*> from c <*> from d <*> from e <*> from f <*> from g 208 | 209 | instance (Marshal a, Marshal b) => Marshal (Tuple (a :* b :* TNil)) where 210 | type Rep (Tuple (a :* b :* TNil)) = (Rep a, Rep b) 211 | to (a :* b :* TNil) = (,) <$> to a <*> to b 212 | from (a, b) = npair <$> from a <*> from b 213 | 214 | -------------------------------------------------------------------------------- /clib/taskpool.c: -------------------------------------------------------------------------------- 1 | // 2 | // Copyright (c) 2009-2011, ERICSSON AB 3 | // All rights reserved. 4 | // 5 | // Redistribution and use in source and binary forms, with or without 6 | // modification, are permitted provided that the following conditions are met: 7 | // 8 | // * Redistributions of source code must retain the above copyright notice, 9 | // this list of conditions and the following disclaimer. 10 | // * Redistributions in binary form must reproduce the above copyright 11 | // notice, this list of conditions and the following disclaimer in the 12 | // documentation and/or other materials provided with the distribution. 13 | // * Neither the name of the ERICSSON AB nor the names of its contributors 14 | // may be used to endorse or promote products derived from this software 15 | // without specific prior written permission. 16 | // 17 | // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | // AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | // IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | // DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | // FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | // DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | // SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | // CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | // OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | // 28 | 29 | #include 30 | #include 31 | #include 32 | #include "taskpool.h" 33 | //#define LOG 34 | #include "log.h" 35 | 36 | int feldspar_taskpool_hook(void) 37 | { 38 | return 0; 39 | } 40 | 41 | /* Definition of the Feldspar application's global taskpool. */ 42 | typedef struct 43 | { 44 | int capacity; 45 | int num_threads, act_threads, min_threads, max_threads; 46 | int head, tail; 47 | void **closures; 48 | int shutdown; 49 | pthread_mutex_t mutex; 50 | } taskpool; 51 | 52 | static taskpool *feldspar_taskpool = 0; 53 | 54 | void *worker(); 55 | 56 | void taskpool_init( int c, int n, int m ) 57 | { 58 | log_3("taskpool_init %d %d %d - enter\n",c,n,m); 59 | log_0("taskpool_init - allocating taskpool\n"); 60 | feldspar_taskpool = calloc( 1, sizeof(taskpool) ); 61 | log_1("taskpool_init - allocating %d closures\n",c); 62 | feldspar_taskpool->closures = malloc( c * sizeof(void*) ); 63 | feldspar_taskpool->capacity = c; 64 | feldspar_taskpool->min_threads = m; 65 | feldspar_taskpool->max_threads = n; 66 | pthread_mutex_init( &(feldspar_taskpool->mutex), NULL ); 67 | log_1("taskpool_init - starting %d threads\n",n); 68 | for( ; n > 0; --n ) 69 | { 70 | taskpool_spawn_worker(); 71 | } 72 | log_0("taskpool_init - leave\n"); 73 | } 74 | 75 | void taskpool_shutdown() 76 | { 77 | log_0("taskpool_shutdown - enter\n"); 78 | feldspar_taskpool->shutdown = 1; 79 | log_0("taskpool_shutdown - shutdown signalled, waiting for workers\n"); 80 | while(1) 81 | { 82 | int ths; 83 | pthread_mutex_lock( &feldspar_taskpool->mutex ); 84 | ths = feldspar_taskpool->num_threads; 85 | pthread_mutex_unlock( &feldspar_taskpool->mutex ); 86 | if (0 == ths) break; 87 | } 88 | log_0("taskpool_shutdown - all threads have stopped\n"); 89 | pthread_mutex_destroy ( &feldspar_taskpool->mutex ); 90 | log_0("taskpool_shutdown - leave\n"); 91 | } 92 | 93 | void taskpool_spawn_worker() 94 | { 95 | log_0("taskpool_spawn_worker - enter\n"); 96 | pthread_mutex_lock( &feldspar_taskpool->mutex ); 97 | if ( !feldspar_taskpool->shutdown ) 98 | { 99 | pthread_t th; 100 | pthread_create( &th, NULL, &worker, NULL ); 101 | pthread_detach( th ); 102 | log_1("taskpool_spawn_worker - create thread %d\n", (unsigned)th); 103 | ++feldspar_taskpool->num_threads; 104 | ++feldspar_taskpool->act_threads; 105 | } 106 | pthread_mutex_unlock( &feldspar_taskpool->mutex ); 107 | log_0("taskpool_spawn_worker - leave\n"); 108 | } 109 | 110 | void spawn( void *closure ) 111 | { 112 | log_1("spawn %p - enter\n", closure); 113 | assert(feldspar_taskpool); 114 | pthread_mutex_lock( &(feldspar_taskpool->mutex) ); 115 | feldspar_taskpool->closures[feldspar_taskpool->tail] = closure; 116 | log_3("spawn %p - saved as task %d at %p\n" 117 | , closure, feldspar_taskpool->tail 118 | , &feldspar_taskpool->closures[feldspar_taskpool->tail]); 119 | ++feldspar_taskpool->tail; 120 | if( feldspar_taskpool->tail == feldspar_taskpool->capacity ) 121 | feldspar_taskpool->tail = 0; 122 | pthread_mutex_unlock( &(feldspar_taskpool->mutex) ); 123 | log_1("spawn %p - leave\n", closure); 124 | } 125 | 126 | void *worker() 127 | { 128 | #ifdef LOG 129 | unsigned int self; 130 | self = (unsigned long)pthread_self(); 131 | #endif 132 | log_1("worker %d - enter\n", self); 133 | taskpool *pool = feldspar_taskpool; 134 | void (*fun)(); 135 | void *closure; 136 | int awake = 1; 137 | log_1("worker %d - entering the loop\n", self); 138 | while(1) 139 | { 140 | if( pool->shutdown && pool->head == pool->tail ) 141 | { 142 | log_1("worker %d - shutdown detected, going to terminate\n", self); 143 | break; 144 | } 145 | if( pool->act_threads > pool->max_threads ) 146 | { 147 | log_1("worker %d - too many active threads, going to terminate\n", self); 148 | break; 149 | } 150 | fun = NULL; 151 | closure = NULL; 152 | pthread_mutex_lock( &(pool->mutex) ); 153 | if( pool->head != pool->tail ) 154 | { 155 | log_2("worker %d - pop task %d\n", self, pool->head); 156 | closure = pool->closures[pool->head]; 157 | ++pool->head; 158 | if( pool->head == pool->capacity ) 159 | pool->head = 0; 160 | } 161 | else { 162 | } 163 | pthread_mutex_unlock( &(pool->mutex) ); 164 | if( closure == NULL ) 165 | { 166 | if (1 == awake) 167 | { 168 | log_1("worker %d - sleep\n", self); 169 | awake = 0; 170 | } 171 | } 172 | else 173 | { 174 | awake = 1; 175 | fun = *((void(**)())closure); 176 | log_2("worker %d - closure %p enter\n", self, fun); 177 | fun( closure + sizeof(void(*)()) ); /* TODO: sizeof(void*) == sizeof(void(**)()) is assumed here */ 178 | log_2("worker %d - closure %p leave\n", self, fun); 179 | } 180 | } 181 | /* Cleanup before exit: */ 182 | log_1("worker %d - cleanup\n", self); 183 | pthread_mutex_lock( &(pool->mutex) ); 184 | --pool->num_threads; 185 | --pool->act_threads; 186 | log_3("worker %d - cleanup done; active: %d, all: %d\n" 187 | , self, pool->act_threads, pool->num_threads); 188 | pthread_mutex_unlock( &(pool->mutex) ); 189 | log_1("worker %d - leave\n", self); 190 | pthread_exit(NULL); 191 | } 192 | 193 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/Plugin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE ForeignFunctionInterface #-} 7 | 8 | -- | Dynamically load a compiled Feldspar function as a Haskell function 9 | module Feldspar.Compiler.Plugin 10 | ( loadFun 11 | , loadFunWith 12 | , loadFunOpts 13 | , loadFunOptsWith 14 | , loadFunWithConfig 15 | , defaultConfig 16 | , pack -- from MultiStage 17 | , unpack -- from MultiStage 18 | ) 19 | where 20 | 21 | import BasicTypes (failed) 22 | import GHCi.ObjLink (initObjLinker,loadObj,resolveObjs) 23 | #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 802 24 | import GHCi.ObjLink (ShouldRetainCAFs(..)) 25 | #endif 26 | import GHC.Paths (ghc) 27 | import System.Plugins.MultiStage 28 | import Distribution.Verbosity (verbose) 29 | import Distribution.Simple.Utils (defaultPackageDesc) 30 | import Distribution.PackageDescription 31 | #if defined(MIN_VERSION_Cabal) && MIN_VERSION_Cabal(2,2,0) 32 | import Distribution.PackageDescription.Parsec (readGenericPackageDescription) 33 | #else 34 | import Distribution.PackageDescription.Parse (readPackageDescription) 35 | #endif 36 | import Distribution.PackageDescription.Configuration (flattenPackageDescription) 37 | 38 | import Feldspar.Compiler.CallConv (rewriteType, buildCType, buildHaskellType) 39 | 40 | import Data.Default 41 | import Foreign.Ptr 42 | import Foreign.Marshal (with) 43 | import Foreign.Marshal.Unsafe (unsafeLocalState) 44 | import Foreign.Storable (Storable(..)) 45 | import Foreign.C.String (CString, withCString) 46 | 47 | import Control.Exception (handle) 48 | import Control.Monad (join, (>=>), when, unless) 49 | import Control.Applicative 50 | 51 | import Language.Haskell.TH hiding (Type, Range) 52 | import Language.Haskell.TH.Syntax (Lift(..)) 53 | 54 | import System.Directory (doesFileExist, removeFile, createDirectoryIfMissing) 55 | import System.Process (readProcessWithExitCode) 56 | import System.Exit (ExitCode(..)) 57 | import System.Info (os) 58 | import System.IO.Error (IOError) 59 | import System.IO.Unsafe (unsafePerformIO) 60 | 61 | 62 | -- Feldspar specific 63 | import Feldspar.Runtime 64 | import Feldspar.Compiler (compile, defaultOptions) 65 | import Feldspar.Compiler.Imperative.Representation (Constant) 66 | import Feldspar.Compiler.Backend.C.Options (Options(..), Platform(..)) 67 | import Feldspar.Compiler.Backend.C.Library (encodeFunctionName) 68 | import Feldspar.Compiler.Marshal () 69 | 70 | -- | Configurable configuration for the loader. 71 | feldsparPluginConfigWith :: String -> Options -> Config 72 | feldsparPluginConfigWith suff fopts = 73 | feldsparPluginConfig { builder = feldsparBuilder fopts 74 | , suffix = suff 75 | } 76 | 77 | -- | Default configuration for the loader 78 | feldsparPluginConfig :: Config 79 | feldsparPluginConfig = 80 | defaultConfig { builder = feldsparBuilder defaultOptions 81 | , worker = feldsparWorker 82 | , typeFromName = loadFunType >=> rewriteType 83 | , mkHSig = buildHaskellType 84 | , mkCSig = buildCType 85 | } 86 | 87 | -- | Compile and load a Feldspar function into the current GHC session. 88 | -- 89 | -- > prog1 :: Data Index -> Vector1 Index 90 | -- > prog1 c = indexed c (const c) 91 | -- > 92 | -- > $(loadFun 'prog1) 93 | -- 94 | -- The call to @loadFun@ above will splice code into the current module 95 | -- to compile, load and wrap a Feldspar function as a Haskell function: 96 | -- 97 | -- > c_prog1 :: Index -> [Index] 98 | -- 99 | loadFun :: [Name] -> Q [Dec] 100 | loadFun n = loadFunWithConfig feldsparPluginConfig n 101 | 102 | -- | @loadFun@ with a function suffix to avoid collisions and different 103 | -- feldspar-compiler options. 104 | loadFunWith :: String -> Options -> [Name] -> Q [Dec] 105 | loadFunWith s o n = loadFunWithConfig (feldsparPluginConfigWith s o) n 106 | 107 | -- | Call @loadFun@ with C compiler options 108 | loadFunOpts :: [String] -> [Name] -> Q [Dec] 109 | loadFunOpts o n = loadFunWithConfig feldsparPluginConfig{opts = o} n 110 | 111 | -- | Call @loadFunWith@ with C compiler options 112 | loadFunOptsWith :: String -> Options -> [String] -> [Name] -> Q [Dec] 113 | loadFunOptsWith pref fopt o n = 114 | loadFunWithConfig (feldsparPluginConfigWith pref fopt){opts = o} n 115 | 116 | feldsparWorker :: Name -> [Name] -> Q Body 117 | feldsparWorker fun as = normalB 118 | [|with def $ \outPtr -> do 119 | join $(infixApp (apply ([|pure $(varE fun)|] : map toRef as)) [|(<*>)|] [|pure outPtr|]) 120 | peek outPtr >>= from 121 | |] 122 | where 123 | toRef name = [| pack $(varE name) |] 124 | 125 | apply :: [ExpQ] -> ExpQ 126 | apply [] = error "apply []" 127 | apply [x] = x 128 | apply (x:y:zs) = apply (infixApp x [|(<*>)|] y : zs) 129 | 130 | feldsparBuilder :: Options -> Config -> Name -> Q Body 131 | feldsparBuilder fopts Config{..} fun = do 132 | let db = getDB 133 | let opts' = opts ++ map ("-I"++) db 134 | normalB [|unsafeLocalState $ do 135 | createDirectoryIfMissing True wdir 136 | $(varE 'compile) $(varE fun) basename base fopts 137 | compileAndLoad basename opts' 138 | lookupSymbol symbol 139 | |] 140 | where 141 | base = nameBase fun ++ suffix 142 | basename = wdir ++ "/" ++ base 143 | symbol = ldprefix ++ encodeFunctionName base 144 | ldprefix = case os of 145 | "darwin" -> "_" 146 | _ -> "" 147 | 148 | getDB :: [String] 149 | getDB = unsafePerformIO $ do 150 | dirs <- sequence [ sandbox, user, local ] 151 | putStrLn $ unwords $ "Using feldspar runtime in" : concat dirs 152 | return $ concat dirs 153 | where 154 | sandbox = handle (\(_ :: IOError) -> return []) $ do 155 | (c,d,_) <- readProcessWithExitCode "cabal" ["sandbox", "hc-pkg","field","feldspar-compiler","include-dirs"] "" 156 | case c of 157 | ExitSuccess -> return $ drop 1 $ words d 158 | _ -> return [] 159 | user = handle (\(_ :: IOError) -> return []) $ do 160 | (c,d,_) <- readProcessWithExitCode "ghc-pkg" ["field","feldspar-compiler","include-dirs"] "" 161 | case c of 162 | ExitSuccess -> return $ drop 1 $ words d 163 | _ -> return [] 164 | local = do 165 | #if defined(MIN_VERSION_Cabal) && MIN_VERSION_Cabal(2,2,0) 166 | pd <- readGenericPackageDescription verbose =<< defaultPackageDesc verbose 167 | #else 168 | pd <- readPackageDescription verbose =<< defaultPackageDesc verbose 169 | #endif 170 | let f a = return $ includeDirs $ libBuildInfo a 171 | maybe (return []) f (maybeHasLibs $ flattenPackageDescription pd) 172 | {-# NOINLINE getDB #-} 173 | 174 | maybeHasLibs :: PackageDescription -> Maybe Library 175 | maybeHasLibs p = 176 | library p >>= \lib -> if buildable (libBuildInfo lib) 177 | then Just lib 178 | else Nothing 179 | 180 | compileAndLoad :: String -> [String] -> IO () 181 | compileAndLoad name opts = do 182 | let cname = name ++ ".c" 183 | let oname = name ++ ".o" 184 | exists <- doesFileExist oname 185 | when exists $ removeFile oname 186 | compileC cname oname opts 187 | #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 802 188 | initObjLinker RetainCAFs 189 | #else 190 | initObjLinker 191 | #endif 192 | _ <- loadObj oname 193 | res <- resolveObjs 194 | when (not res) $ error $ "Symbols in " ++ oname ++ " could not be resolved" 195 | 196 | compileC :: String -> String -> [String] -> IO () 197 | compileC srcfile objfile opts = do 198 | let args = [ "-optc -std=c99" 199 | , "-optc -Wall" 200 | , "-w" 201 | , "-c" 202 | ] 203 | (_,stdout,stderr) <- readProcessWithExitCode ghc (args ++ opts ++ ["-o",objfile,srcfile]) "" 204 | let output = stdout ++ stderr 205 | unless (null output) $ putStrLn output 206 | 207 | lookupSymbol :: String -> IO (Ptr a) 208 | lookupSymbol symbol = do 209 | when (0 /= feldspar_compiler_hook) $ error "lookupSymbol: Runtime library missing" 210 | mptr <- withCString symbol _lookupSymbol 211 | when (mptr == nullPtr) $ error $ "Symbol " ++ symbol ++ " not found" 212 | return mptr 213 | 214 | foreign import ccall safe "lookupSymbol" 215 | _lookupSymbol :: CString -> IO (Ptr a) 216 | 217 | 218 | --- Boring TH instances for Lifting Options ------- 219 | -- TODO: Derive Lift for these. 220 | 221 | instance Lift Options where 222 | lift (Options platform ph una unr frontopts sl ns) = 223 | [| Options platform ph una unr frontopts sl ns |] 224 | 225 | instance Lift Platform where 226 | lift (Platform n t vs is vf be) = [| Platform n t vs is vf be |] 227 | 228 | instance Lift (Constant () -> String) where 229 | lift x = [| error "No TH instance for ShowValue" |] 230 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/Compiler.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (c) 2009-2011, ERICSSON AB 3 | -- All rights reserved. 4 | -- 5 | -- Redistribution and use in source and binary forms, with or without 6 | -- modification, are permitted provided that the following conditions are met: 7 | -- 8 | -- * Redistributions of source code must retain the above copyright notice, 9 | -- this list of conditions and the following disclaimer. 10 | -- * Redistributions in binary form must reproduce the above copyright 11 | -- notice, this list of conditions and the following disclaimer in the 12 | -- documentation and/or other materials provided with the distribution. 13 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 14 | -- may be used to endorse or promote products derived from this software 15 | -- without specific prior written permission. 16 | -- 17 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -- 28 | 29 | {-# LANGUAGE TypeFamilies #-} 30 | {-# LANGUAGE RankNTypes #-} 31 | {-# LANGUAGE RecordWildCards #-} 32 | {-# LANGUAGE ConstraintKinds #-} 33 | {-# LANGUAGE FlexibleContexts #-} 34 | {-# LANGUAGE FlexibleInstances #-} 35 | {-# LANGUAGE ExistentialQuantification #-} 36 | 37 | module Feldspar.Compiler.Compiler ( 38 | compileToCCore 39 | , compileToCCore' 40 | , defaultOptions 41 | , sicsOptions 42 | , sicsOptions2 43 | , sicsOptions3 44 | , c99PlatformOptions 45 | , c99OpenMpPlatformOptions 46 | , tic64xPlatformOptions 47 | , SplitModule(..) 48 | , CompiledModule(..) 49 | , BackendPass(..) 50 | , backend 51 | , fromCore 52 | , ProgOpts(..) 53 | , defaultProgOpts 54 | ) where 55 | 56 | import Data.List (partition) 57 | import Data.Maybe (fromMaybe) 58 | 59 | import Feldspar.Core.Frontend (Syntactic, reifyFeld) 60 | import Feldspar.Core.Interpretation (defaultFeldOpts, FeldOpts(..), Target(..)) 61 | import Feldspar.Core.UntypedRepresentation (UntypedFeld, VarId) 62 | import Feldspar.Core.Middleend.FromTyped (FrontendPass, frontend) 63 | import Feldspar.Compiler.Backend.C.Library 64 | import Feldspar.Compiler.Backend.C.Options 65 | import Feldspar.Compiler.Backend.C.Platforms 66 | import Feldspar.Compiler.Backend.C.CodeGeneration 67 | import Feldspar.Compiler.Backend.C.MachineLowering 68 | import Feldspar.Compiler.Backend.C.Tic64x 69 | import Feldspar.Compiler.Imperative.FromCore 70 | import Feldspar.Compiler.Imperative.ArrayOps 71 | import Feldspar.Compiler.Imperative.Representation 72 | import Feldspar.Core.Middleend.PassManager 73 | import Control.Monad (when) 74 | 75 | data SplitModule = SplitModule 76 | { implementation :: CompiledModule 77 | , interface :: CompiledModule 78 | } 79 | 80 | data CompiledModule = CompiledModule { 81 | sourceCode :: String, 82 | debugModule :: Module () 83 | } 84 | 85 | -- | Split a module into interface and implemenation. 86 | splitModule :: Module () -> (Module (), Module ()) 87 | splitModule m = (Module (hdr ++ createProcDecls (entities m)), Module body) 88 | where 89 | (hdr, body) = partition belongsToHeader (entities m) 90 | belongsToHeader :: Entity () -> Bool 91 | belongsToHeader StructDef{} = True 92 | belongsToHeader Proc{..} | Nothing <- procBody = True 93 | belongsToHeader _ = False 94 | -- TODO These only belongs in the header iff the types are used in a 95 | -- function interface 96 | createProcDecls :: [Entity ()] -> [Entity ()] 97 | createProcDecls = concatMap defToDecl 98 | defToDecl :: Entity () -> [Entity ()] 99 | defToDecl (Proc n False inp rtype _) = [Proc n False inp rtype Nothing] 100 | defToDecl _ = [] 101 | 102 | compileSplitModule :: Options -> (Module (), Module ()) -> SplitModule 103 | compileSplitModule opts (hmdl, cmdl) 104 | = SplitModule 105 | { interface = CompiledModule { sourceCode = incls ++ hres 106 | , debugModule = hmdl 107 | } 108 | , implementation = CompiledModule { sourceCode = cres 109 | , debugModule = cmdl 110 | } 111 | } 112 | where 113 | hres = compToCWithInfos opts hmdl 114 | cres = compToCWithInfos opts cmdl 115 | incls = genIncludeLines opts Nothing 116 | 117 | -- | Compiler core. 118 | -- Everything should call this function and only do a trivial interface adaptation. 119 | -- Do not duplicate. 120 | compileToCCore :: Syntactic c => String -> Options -> c -> SplitModule 121 | compileToCCore name opts prg = compileToCCore' opts mod 122 | where 123 | mod = fromCore opts (encodeFunctionName name) prg 124 | 125 | compileToCCore' :: Options -> Module () -> SplitModule 126 | compileToCCore' opts m = compileSplitModule opts $ splitModule mod 127 | where 128 | mod = adaptTic64x opts $ rename opts False $ arrayOps opts m 129 | 130 | genIncludeLines :: Options -> Maybe String -> String 131 | genIncludeLines opts mainHeader = concatMap include incs ++ "\n\n" 132 | where 133 | include [] = "" 134 | include fname@('<':_) = "#include " ++ fname ++ "\n" 135 | include fname = "#include \"" ++ fname ++ "\"\n" 136 | incs = includes (platform opts) ++ [fromMaybe "" mainHeader] 137 | 138 | -- | Predefined options 139 | 140 | defaultOptions :: Options 141 | defaultOptions 142 | = Options 143 | { platform = c99 144 | , printHeader = False 145 | , useNativeArrays = False 146 | , useNativeReturns = False 147 | , frontendOpts = defaultFeldOpts 148 | , safetyLimit = 2000 149 | , nestSize = 2 150 | } 151 | 152 | c99PlatformOptions :: Options 153 | c99PlatformOptions = defaultOptions 154 | 155 | c99OpenMpPlatformOptions :: Options 156 | c99OpenMpPlatformOptions = defaultOptions { platform = c99OpenMp } 157 | 158 | tic64xPlatformOptions :: Options 159 | tic64xPlatformOptions = defaultOptions { platform = tic64x } 160 | 161 | sicsOptions :: Options 162 | sicsOptions = defaultOptions { frontendOpts = defaultFeldOpts { targets = [SICS,CSE] }} 163 | 164 | sicsOptions2 :: Options 165 | sicsOptions2 = defaultOptions { frontendOpts = defaultFeldOpts { targets = [SICS] }} 166 | 167 | sicsOptions3 :: Options 168 | sicsOptions3 = defaultOptions { platform = c99Wool, frontendOpts = defaultFeldOpts { targets = [SICS,CSE,Wool] }} 169 | 170 | data BackendPass = BPFromCore 171 | | BPArrayOps 172 | | BPRename 173 | | BPAdapt 174 | | BPSplit 175 | | BPCompile 176 | | BPUnsplit 177 | deriving (Eq, Enum, Bounded, Read, Show) 178 | 179 | instance (Pretty a, Pretty b) => Pretty (a, b) where 180 | pretty (x,y) = "(" ++ pretty x ++ ", " ++ pretty y ++ ")" 181 | 182 | instance Pretty (Module ()) where 183 | pretty m = compToCWithInfos defaultOptions m 184 | 185 | instance Pretty VarId where 186 | pretty v = show v 187 | 188 | instance Pretty SplitModule where 189 | pretty (SplitModule impl intf) = "// Interface\n" ++ sourceCode intf ++ 190 | "\n// Implementation\n" ++ sourceCode impl 191 | 192 | backend :: PassCtrl BackendPass -> Options -> String -> UntypedFeld -> ([String], Maybe SplitModule) 193 | backend ctrl opts name = evalPasses 0 194 | $ codegen (codeGenerator $ platform opts) ctrl opts 195 | . pc BPRename (rename opts False) 196 | . pc BPArrayOps (arrayOps opts) 197 | . pt BPFromCore (fst . fromCoreUT opts (encodeFunctionName name)) 198 | where pc :: Pretty a => BackendPass -> (a -> a) -> Prog a Int -> Prog a Int 199 | pc = passC ctrl 200 | pt :: (Pretty a, Pretty b) => BackendPass -> (a -> b) -> Prog a Int -> Prog b Int 201 | pt = passT ctrl 202 | 203 | codegen :: String -> PassCtrl BackendPass -> Options -> Prog (Module ()) Int -> Prog SplitModule Int 204 | codegen "c" ctrl opts = passT ctrl BPCompile (compileSplitModule opts) 205 | . passT ctrl BPSplit splitModule 206 | . passC ctrl BPAdapt (adaptTic64x opts) 207 | codegen gen _ _ = error $ "Compiler.codegen: unknown code generator " ++ gen 208 | 209 | -- | Get the generated core for an expression. 210 | fromCore :: Syntactic a 211 | => Options 212 | -> String -- ^ Name of the generated function 213 | -> a -- ^ Expression to generate code for 214 | -> Module () 215 | fromCore opt funname prog 216 | | Just prg <- snd $ frontend ctrl (frontendOpts opt) $ reifyFeld prog 217 | = fst $ fromCoreUT opt funname prg 218 | where ctrl = frontendCtrl defaultProgOpts 219 | 220 | data ProgOpts = 221 | ProgOpts 222 | { backOpts :: Options 223 | , passFileName :: String 224 | , outFileName :: String 225 | , functionName :: String 226 | , frontendCtrl :: PassCtrl FrontendPass 227 | , backendCtrl :: PassCtrl BackendPass 228 | , printHelp :: Bool 229 | } 230 | 231 | defaultProgOpts :: ProgOpts 232 | defaultProgOpts = 233 | ProgOpts 234 | { backOpts = defaultOptions 235 | , passFileName = "" 236 | , outFileName = "" 237 | , functionName = "" 238 | , frontendCtrl = defaultPassCtrl 239 | , backendCtrl = defaultPassCtrl 240 | , printHelp = False 241 | } 242 | -------------------------------------------------------------------------------- /clib/ivar.c: -------------------------------------------------------------------------------- 1 | // 2 | // Copyright (c) 2009-2011, ERICSSON AB 3 | // All rights reserved. 4 | // 5 | // Redistribution and use in source and binary forms, with or without 6 | // modification, are permitted provided that the following conditions are met: 7 | // 8 | // * Redistributions of source code must retain the above copyright notice, 9 | // this list of conditions and the following disclaimer. 10 | // * Redistributions in binary form must reproduce the above copyright 11 | // notice, this list of conditions and the following disclaimer in the 12 | // documentation and/or other materials provided with the distribution. 13 | // * Neither the name of the ERICSSON AB nor the names of its contributors 14 | // may be used to endorse or promote products derived from this software 15 | // without specific prior written permission. 16 | // 17 | // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | // AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | // IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | // DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | // FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | // DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | // SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | // CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | // OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | // 28 | 29 | #include "ivar.h" 30 | #include "taskpool.h" 31 | #include 32 | #include 33 | //#define LOG 34 | #include "log.h" 35 | 36 | /* Type of function pointer */ 37 | typedef void* array_copy_t( void* dst, int32_t dstLen, void* src, int32_t srcLen ); 38 | 39 | int feldspar_ivar_hook(void) 40 | { 41 | return 0; 42 | } 43 | 44 | void *worker( void *p ); 45 | 46 | void ivar_init( struct ivar *iv ) 47 | { 48 | struct ivar_internals *ivi; 49 | int err; 50 | log_1("ivar_init %p - enter\n", iv); 51 | ivi = iv->internals = (struct ivar_internals*)malloc( sizeof(struct ivar_internals) ); 52 | err = pthread_mutex_init( &(ivi->mutex), NULL ); 53 | if (err) exit(err); 54 | err = pthread_cond_init( &(ivi->cond), NULL ); 55 | if (err) exit(err); 56 | ivi->full = 0; 57 | iv->self = iv; 58 | log_1("ivar_init %p - leave\n", iv); 59 | } 60 | 61 | void ivar_destroy( struct ivar *iv ) // TODO: Think about ivars escaping from their scope... 62 | { 63 | log_1("ivar_destroy %p - enter\n", iv); 64 | if( iv->self == iv ) // This is true iff this iVar is not a copy. 65 | { 66 | struct ivar_internals *ivi = iv->internals; 67 | pthread_mutex_destroy( &(ivi->mutex) ); 68 | pthread_cond_destroy( &(ivi->cond) ); 69 | if( ivi->full ) 70 | { 71 | free( ivi->data ); // TODO: Destroy deep? 72 | } 73 | free( ivi ); 74 | } 75 | log_1("ivar_destroy %p - leave\n", iv); 76 | } 77 | 78 | void ivar_put_with_size( struct ivar iv, void *d, int size ) 79 | { 80 | struct ivar_internals *ivi = iv.internals; 81 | log_3("ivar_put_with_size %p %p %d - enter\n", &iv, d, size); 82 | pthread_mutex_lock( &(ivi->mutex) ); 83 | ivi->data = (void*)malloc( size ); 84 | memcpy( ivi->data, d, size ); 85 | ivi->full = 1; 86 | pthread_cond_broadcast( &(ivi->cond) ); 87 | pthread_mutex_unlock( &(ivi->mutex) ); 88 | log_3("ivar_put_with_size %p %p %d - leave\n", &iv, d, size); 89 | } 90 | 91 | void ivar_put_array( struct ivar iv, void *dv, void* vcf ) 92 | { 93 | struct ivar_internals *ivi = iv.internals; 94 | log_2("ivar_put_array %p %p - enter\n", &iv, d); 95 | pthread_mutex_lock( &(ivi->mutex) ); 96 | array_copy_t* cf = (array_copy_t*) vcf; 97 | struct array *str = allocArray( ivi->data ); 98 | struct array *d = dv; 99 | str->buffer = cf( str->buffer, str->length, d->buffer, d->length ); 100 | str->length = d->length; 101 | ivi->data = str; 102 | ivi->full = 1; 103 | pthread_cond_broadcast( &(ivi->cond) ); 104 | pthread_mutex_unlock( &(ivi->mutex) ); 105 | log_2("ivar_put_array %p %p - leave\n", &iv, d); 106 | } 107 | 108 | void ivar_put_array_shallow( struct ivar iv, void *dv, int32_t size ) 109 | { 110 | struct ivar_internals *ivi = iv.internals; 111 | log_2("ivar_put_array_shallow %p %p - enter\n", &iv, d); 112 | pthread_mutex_lock( &(ivi->mutex) ); 113 | struct array *str = allocArray( ivi->data ); 114 | struct array *d = dv; 115 | str->buffer = initCopyArray( str->buffer, str->length, size, d->buffer, d->length ); 116 | str->length = d->length; 117 | ivi->data = str; 118 | ivi->full = 1; 119 | pthread_cond_broadcast( &(ivi->cond) ); 120 | pthread_mutex_unlock( &(ivi->mutex) ); 121 | log_2("ivar_put_array_shallow %p %p - leave\n", &iv, d); 122 | } 123 | 124 | void ivar_get_helper( struct ivar_internals *iv ) 125 | { 126 | log_1("ivar_get_helper %p - enter\n", iv); 127 | pthread_mutex_lock( &(iv->mutex) ); 128 | if( !iv->full ) 129 | { 130 | log_1("ivar_get_helper %p - ivar is empty\n", iv); 131 | taskpool_spawn_worker(); 132 | log_1("ivar_get_helper %p - blocking while waiting for data\n", iv); 133 | pthread_cond_wait( &(iv->cond), &(iv->mutex) ); 134 | log_1("ivar_get_helper %p - data arrived\n" , iv); 135 | } 136 | pthread_mutex_unlock( &(iv->mutex) ); 137 | log_1("ivar_get_helper %p - leave\n", iv); 138 | } 139 | 140 | void ivar_get_with_size( void *var, struct ivar iv, int size ) 141 | { 142 | log_3("ivar_get_with_size %p %p %d - enter\n", var, &iv, size); 143 | ivar_get_helper(iv.internals); 144 | memcpy( var, iv.internals->data, size ); 145 | log_3("ivar_get_with_size %p %p %d - leave\n", var, &iv, size); 146 | } 147 | 148 | void ivar_get_array( void *vvar, struct ivar iv, void* vcf ) 149 | { 150 | struct array *ptr; 151 | log_2("ivar_get_array %p %p - enter\n", var, &iv); 152 | ivar_get_helper(iv.internals); 153 | ptr = (struct array*)iv.internals->data; 154 | assert(ptr); 155 | struct array *var = vvar; 156 | array_copy_t* cf = (array_copy_t*) vcf; 157 | var->buffer = cf( var->buffer, var->length, ptr->buffer, ptr->length ); 158 | var->length = ptr->length; 159 | log_2("ivar_get_array %p %p - leave\n", var, &iv); 160 | } 161 | 162 | void ivar_get_array_shallow( void *vvar, struct ivar iv, int32_t size ) 163 | { 164 | struct array *ptr; 165 | log_2("ivar_get_array_shallow %p %p - enter\n", var, &iv); 166 | ivar_get_helper(iv.internals); 167 | ptr = (struct array*)iv.internals->data; 168 | assert(ptr); 169 | struct array *var = vvar; 170 | var->buffer = initCopyArray( var->buffer, var->length, size, ptr->buffer, ptr->length ); 171 | var->length = ptr->length; 172 | log_2("ivar_get_arra_shallowy %p %p - leave\n", var, &iv); 173 | } 174 | 175 | void ivar_get_nontask_with_size( void *var, struct ivar iv, int size ) 176 | { 177 | struct ivar_internals *ivi = iv.internals; 178 | log_3("ivar_get_nontask_with_size %p %p %d - enter\n", var, &iv, size); 179 | pthread_mutex_lock( &(ivi->mutex) ); 180 | if ( !ivi->full ) 181 | log_3("ivar_get_nontask_with_size %p %p %d -> waiting for data\n" 182 | , var, &iv, size); 183 | while( !ivi->full ) 184 | { 185 | int err = pthread_cond_wait( &(ivi->cond), &(ivi->mutex) ); 186 | if (err) { exit(err); } 187 | } 188 | pthread_mutex_unlock( &(ivi->mutex) ); 189 | assert(ivi->data); 190 | memcpy( var, ivi->data, size ); 191 | log_3("ivar_get_nontask_with_size %p %p %d - leave\n", var, &iv, size); 192 | } 193 | 194 | void ivar_get_array_nontask( void *vvar, struct ivar iv, void* vcf ) 195 | { 196 | struct ivar_internals *ivi = iv.internals; 197 | struct array *ptr; 198 | log_2("ivar_get_array_nontask %p %p - enter\n", var, &iv); 199 | pthread_mutex_lock( &(ivi->mutex) ); 200 | if ( !ivi->full ) 201 | log_2("ivar_get_array_nontask %p %p - waiting for data\n", var, &iv); 202 | while(!ivi->full) 203 | { 204 | int err = pthread_cond_wait( &(ivi->cond), &(ivi->mutex) ); 205 | if (err) { exit(err); } 206 | } 207 | assert(ivi->full); 208 | pthread_mutex_unlock( &(ivi->mutex) ); 209 | if (NULL == ivi->data) 210 | { 211 | log_2("ivar_get_array_nontask %p %p - data uninitialized\n", var, &iv); 212 | } 213 | else 214 | { 215 | ptr = (struct array*)ivi->data; 216 | struct array *var = vvar; 217 | array_copy_t* cf = (array_copy_t*) vcf; 218 | var->buffer = cf( var->buffer, var->length, ptr->buffer, ptr->length ); 219 | var->length = ptr->length; 220 | } 221 | log_2("ivar_get_array_nontask %p %p - leave\n", var, &iv); 222 | } 223 | 224 | void ivar_get_array_shallow_nontask( void *vvar, struct ivar iv, int32_t size ) 225 | { 226 | struct ivar_internals *ivi = iv.internals; 227 | struct array *ptr; 228 | log_2("ivar_get_array_shallow_nontask %p %p - enter\n", var, &iv); 229 | pthread_mutex_lock( &(ivi->mutex) ); 230 | if ( !ivi->full ) 231 | log_2("ivar_get_array_shallow_nontask %p %p - waiting for data\n", var, &iv); 232 | while(!ivi->full) 233 | { 234 | int err = pthread_cond_wait( &(ivi->cond), &(ivi->mutex) ); 235 | if (err) { exit(err); } 236 | } 237 | assert(ivi->full); 238 | pthread_mutex_unlock( &(ivi->mutex) ); 239 | if (NULL == ivi->data) 240 | { 241 | log_2("ivar_get_array_shallow_nontask %p %p - data uninitialized\n", var, &iv); 242 | } 243 | else 244 | { 245 | ptr = (struct array*)ivi->data; 246 | struct array *var = vvar; 247 | var->buffer = initCopyArray( var->buffer, var->length, size, ptr->buffer, ptr->length ); 248 | var->length = ptr->length; 249 | } 250 | log_2("ivar_get_array_shallow_nontask %p %p - leave\n", var, &iv); 251 | } 252 | 253 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/Backend/C/MachineLowering.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE PatternGuards #-} 3 | module Feldspar.Compiler.Backend.C.MachineLowering where 4 | 5 | import qualified Data.Map as M 6 | 7 | import Feldspar.Compiler.Imperative.Representation 8 | import Feldspar.Compiler.Imperative.Frontend 9 | import Feldspar.Compiler.Backend.C.Options 10 | import Feldspar.Compiler.Backend.C.Platforms (extend, c99, tic64x) 11 | import Feldspar.Compiler.Backend.C.RuntimeLibrary 12 | 13 | -- This module does function renaming as well as copy expansion, in a single pass. 14 | -- 15 | -- Missing from the old C99 rules: Constant folding of 0 - x. That really belongs 16 | -- in the frontend but there is no negate in NUM and multiplying by -1 gives crazy 17 | -- results due to overflow. 18 | 19 | -- | External interface for renaming. 20 | rename :: Options -> Bool -> Module () -> Module () 21 | rename opts _ | codeGenerator (platform opts) /= "c" = id 22 | rename opts addRuntimeLib = rename' opts addRuntimeLib x 23 | where x = getPlatformRenames opts 24 | 25 | -- | Internal interface for renaming. 26 | rename' :: Options -> Bool -> M.Map String [(Which, Destination)] -> Module () 27 | -> Module () 28 | rename' opts addRuntimeLib m (Module ents) = Module ents' 29 | where ents' = extra ++ map (renameEnt opts m) ents 30 | extra | addRuntimeLib = machineLibrary opts 31 | | otherwise = [] 32 | 33 | -- | Rename entities. 34 | renameEnt :: Options -> M.Map String [(Which, Destination)] -> Entity () -> Entity () 35 | renameEnt opts m p@Proc{..} 36 | | Just body <- procBody = p { procBody = Just $ renameBlock opts m body } 37 | renameEnt _ _ e = e 38 | 39 | -- | Rename blocks. 40 | renameBlock :: Options -> M.Map String [(Which, Destination)] -> Block () -> Block () 41 | renameBlock opts m (Block vs p) = Block (map (renameDecl m) vs) (renameProg opts m p) 42 | 43 | -- | Rename declarations. 44 | renameDecl :: M.Map String [(Which, Destination)] -> Declaration () -> Declaration () 45 | renameDecl m (Declaration v (Just e)) = Declaration v (Just $ renameExp m e) 46 | renameDecl _ d = d 47 | 48 | -- | Rename programs. 49 | renameProg :: Options -> M.Map String [(Which, Destination)] -> Program () 50 | -> Program () 51 | renameProg _ _ e@Empty = e 52 | renameProg _ _ c@Comment{} = c 53 | renameProg _ m (Assign lhs rhs) = Assign (renameExp m lhs) (renameExp m rhs) 54 | renameProg _ m (ProcedureCall n ps) = ProcedureCall n (map (renameParam m) ps) 55 | renameProg opts m (Sequence ps) = Sequence $ map (renameProg opts m) ps 56 | renameProg opts m (Switch scrut alts) 57 | = Switch (renameExp m scrut) (map (renameAlt opts m) alts) 58 | renameProg opts m (SeqLoop cond calc block) 59 | = SeqLoop (renameExp m cond) (renameBlock opts m calc) (renameBlock opts m block) 60 | renameProg opts m (ParLoop p v e0 e1 e2 b) 61 | = ParLoop p v (renameExp m e0) (renameExp m e1) (renameExp m e2) (renameBlock opts m b) 62 | renameProg opts m (BlockProgram b) = BlockProgram $ renameBlock opts m b 63 | 64 | -- | Rename expressions. 65 | renameExp :: M.Map String [(Which, Destination)] -> Expression () -> Expression () 66 | renameExp _ v@VarExpr{} = v 67 | renameExp m (ArrayElem e es) = ArrayElem (renameExp m e) $ map (renameExp m) es 68 | renameExp m (StructField e s) = StructField (renameExp m e) s 69 | renameExp _ c@ConstExpr{} = c 70 | renameExp m (FunctionCall f es) = res 71 | where f'@(Function new t) = renameFun m (typeof $ head es) f 72 | es' = map (renameExp m) es 73 | res | new /= "div" = FunctionCall f' es' 74 | | [arg1,arg2] <- es 75 | , (_ :# NumType Signed _) <- t 76 | = StructField (fun div_t (div_f t) [arg1, arg2]) "quot" 77 | | otherwise = fun t "/" es' 78 | where 79 | div_t = StructType "div_t" [("quot", t), ("rem", t)] 80 | div_f (1 :# (NumType Signed S8)) = "div" 81 | div_f (1 :# (NumType Signed S16)) = "div" 82 | div_f (1 :# (NumType Signed S32)) = "div" 83 | div_f (1 :# (NumType Signed S40)) = "ldiv" 84 | div_f (1 :# (NumType Signed S64)) = "lldiv" 85 | div_f typ = error $ "div not defined for " ++ show typ 86 | 87 | renameExp m (Cast t e) = Cast t $ renameExp m e 88 | renameExp m (AddrOf e) = AddrOf $ renameExp m e 89 | renameExp _ s@SizeOf{} = s 90 | renameExp m (Deref e) = Deref $ renameExp m e 91 | 92 | -- | Rename parameters. 93 | renameParam :: M.Map String [(Which, Destination)] -> ActualParameter () 94 | -> ActualParameter () 95 | renameParam m (ValueParameter e) = ValueParameter $ renameExp m e 96 | renameParam _ p = p 97 | 98 | -- | Rename switch alternatives. 99 | renameAlt :: Options -> M.Map String [(Which, Destination)] 100 | -> (Pattern (), Block ()) -> (Pattern (), Block ()) 101 | renameAlt opts m (p, b) = (p, renameBlock opts m b) 102 | 103 | -- | Renames functions that should be renamed. Identity function on others. 104 | renameFun :: M.Map String [(Which, Destination)] -> Type -> Function -> Function 105 | renameFun m argtype f@(Function name t) 106 | | Just ps <- M.lookup name m 107 | , Just s <- findFun name argtype ps t = Function s t 108 | | otherwise = f 109 | 110 | -- | Finds the new name of the function, if any. 111 | findFun :: String -> Type -> [(Which, Destination)] -> Type -> Maybe String 112 | findFun name argtype m tp = go m 113 | where go [] = Nothing 114 | go ((Only p, s):_) | true p tp = Just (newName name argtype tp s) 115 | go ((All, s):_) = Just (newName name argtype tp s) 116 | go (_:t) = go t 117 | 118 | -- | Returns a new name according to specification. 119 | newName :: String -> Type -> Type -> Destination -> String 120 | newName _ _ _ (Name s) = s 121 | newName name _ tp (Extend FunType p) = extend p name tp 122 | newName name argtype _ (Extend ArgType p) = extend p name argtype 123 | newName _ _ tp (ExtendRename FunType p s) = extend p s tp 124 | newName _ argtype _ (ExtendRename ArgType p s) = extend p s argtype 125 | 126 | -- | Tells whether a predicate holds for a type. 127 | true :: Predicate -> Type -> Bool 128 | true Complex t = isComplex t 129 | true Float t = isFloat t 130 | true Signed32 t 131 | | Just 32 <- intWidth t 132 | , Just True <- intSigned t = True 133 | | otherwise = False 134 | true Unsigned32 t 135 | | Just 32 <- intWidth t 136 | , Just False <- intSigned t = True 137 | | otherwise = False 138 | 139 | -- A rename is the name of the function to be renamed coupled with a 140 | -- list of preconditions for renaming to happen and a the destination 141 | -- name if the precondition is held. First match is executed and the 142 | -- destination name becomes whatever the template specifies. 143 | 144 | -- | C99 renaming list. 145 | c99list :: [Rename] 146 | c99list = 147 | [ ("/=", [ (All, Name "!=")]) 148 | , ("not", [ (All, Name "!")]) 149 | , ("quot", [ (All, Name "/")]) 150 | , ("rem", [ (All, Name "%")]) 151 | , (".&.", [ (All, Name "&")]) 152 | , (".|.", [ (All, Name "|")]) 153 | , ("xor", [ (All, Name "^")]) 154 | , ("complement", [ (All, Name "~")]) 155 | , ("shiftL", [ (All, Name "<<")]) 156 | , ("shiftLU", [ (All, Name "<<")]) 157 | , ("shiftR", [ (All, Name ">>")]) 158 | , ("shiftRU", [ (All, Name ">>")]) 159 | , ("creal", [ (All, Name "crealf")]) 160 | , ("cimag", [ (All, Name "cimagf")]) 161 | , ("conjugate", [ (All, Name "conjf")]) 162 | , ("magnitude", [ (All, Name "cabsf")]) 163 | , ("phase", [ (All, Name "cargf")]) 164 | , ("atan2", [ (Only Complex, Name "atan2f") ]) 165 | ] ++ 166 | (map mkC99TrigRule ["exp", "sqrt", "log", "**", "sin", "tan", "cos", "asin" 167 | , "atan", "acos", "sinh", "tanh", "cosh", "asinh", "atanh" 168 | , "acosh"]) ++ 169 | -- Extend these functions based on the function type. 170 | (map (mkC99ExtendRule FunType) [ "abs", "signum", "logBase", "setBit", "clearBit" 171 | , "complementBit", "rotateL", "rotateR" 172 | , "reverseBits" ]) ++ 173 | -- Extend these functions based on the argument type. 174 | (map (mkC99ExtendRule ArgType) [ "testBit", "bitScan", "bitCount", "complex" 175 | , "mkPolar", "cis"]) 176 | 177 | -- | Make C99 extend rule. 178 | mkC99ExtendRule :: WhichType -> String -> Rename 179 | mkC99ExtendRule t s = (s, [ (All, Extend t c99) ]) 180 | 181 | -- | Make C99 trig rule. 182 | mkC99TrigRule :: String -> Rename 183 | mkC99TrigRule s = (s, [ (Only Complex, Name ('c':s')), (All, Name s') ]) 184 | where s' = s ++ "f" 185 | 186 | -- | Tic64x renaming list. 187 | tic64xlist :: [Rename] 188 | tic64xlist = 189 | [ ("==", [ (Only Complex, ExtendRename ArgType tic64x "equal") ]) 190 | , ("abs", [ (Only Float, Name "_fabs"), (Only Signed32, Name "_abs") ]) 191 | , ("+", [ (Only Complex, ExtendRename ArgType tic64x "add") ]) 192 | , ("-", [ (Only Complex, ExtendRename ArgType tic64x "sub") ]) 193 | , ("*", [ (Only Complex, ExtendRename ArgType tic64x "mult") ]) 194 | , ("/", [ (Only Complex, ExtendRename ArgType tic64x "div") ]) 195 | ] ++ 196 | (map mkTic64xComplexRule ["exp", "sqrt", "log", "sin", "tan", "cos", "asin" 197 | ,"atan", "acos", "sinh", "tanh", "cosh", "asinh" 198 | ,"atanh","acosh","creal","cimag", "conjugate" 199 | ,"magnitude","phase", "logBase"]) ++ 200 | [ ("**", [ (Only Complex, ExtendRename ArgType tic64x "cpow") ]) 201 | , ("rotateL", [ (Only Unsigned32, Name "_rotl") ]) 202 | , ("reverseBits", [ (Only Unsigned32, Name "_bitr") ]) 203 | ] 204 | 205 | -- | Create Tic64x rule for complex type. 206 | mkTic64xComplexRule :: String -> Rename 207 | mkTic64xComplexRule s = (s, [ (Only Complex, Extend ArgType tic64x) ] ) 208 | 209 | -- | Returns the platform renames based on the platform name. 210 | getPlatformRenames :: Options -> M.Map String [(Which, Destination)] 211 | getPlatformRenames opt = 212 | case name $ platform opt of 213 | "tic64x" -> M.fromList (tic64xlist ++ c99list) 214 | s | s `elem` ["c99", "c99OpenMp", "c99Wool"] -> M.fromList c99list 215 | | otherwise -> M.fromList [] 216 | 217 | flattenProgram :: [Program ()] -> Program () 218 | flattenProgram ss = if null ss then Empty else Sequence ss 219 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/Frontend/Interactive/Interface.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | 6 | -- 7 | -- Copyright (c) 2009-2011, ERICSSON AB 8 | -- All rights reserved. 9 | -- 10 | -- Redistribution and use in source and binary forms, with or without 11 | -- modification, are permitted provided that the following conditions are met: 12 | -- 13 | -- * Redistributions of source code must retain the above copyright notice, 14 | -- this list of conditions and the following disclaimer. 15 | -- * Redistributions in binary form must reproduce the above copyright 16 | -- notice, this list of conditions and the following disclaimer in the 17 | -- documentation and/or other materials provided with the distribution. 18 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 19 | -- may be used to endorse or promote products derived from this software 20 | -- without specific prior written permission. 21 | -- 22 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 23 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 24 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 25 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 26 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 27 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 28 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 30 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -- 33 | 34 | module Feldspar.Compiler.Frontend.Interactive.Interface where 35 | 36 | import Feldspar.Core.Frontend (Syntactic, reifyFeld) 37 | import Feldspar.Core.Interpretation (FeldOpts(..), Target(..)) 38 | import Feldspar.Core.UntypedRepresentation (UntypedFeld) 39 | import Feldspar.Core.Middleend.PassManager 40 | import Feldspar.Core.Middleend.FromTyped (FrontendPass, frontend) 41 | import Feldspar.Compiler.Compiler 42 | import Feldspar.Compiler.Imperative.FromCore 43 | import Feldspar.Compiler.Backend.C.Options 44 | import Feldspar.Compiler.Backend.C.Library 45 | import Feldspar.Compiler.Backend.C.Platforms (availablePlatforms, platformFromName) 46 | import Feldspar.Compiler.Imperative.Representation (Module(..)) 47 | 48 | import Data.Char 49 | import Data.List (intercalate) 50 | import Control.Monad (when) 51 | import System.FilePath (takeFileName) 52 | import System.Environment (getArgs, getProgName) 53 | import System.Console.GetOpt 54 | import System.IO 55 | 56 | -- ================================================================================================ 57 | -- == Interactive compilation 58 | -- ================================================================================================ 59 | 60 | compile :: (Syntactic t) => t -> FilePath -> String -> Options -> IO () 61 | compile prg fileName funName opts = writeFiles compRes fileName (codeGenerator $ platform opts) 62 | where compRes = compileToCCore funName opts prg 63 | 64 | compileUT :: UntypedFeld -> FilePath -> String -> Options -> IO () 65 | compileUT prg fileName funName opts = writeFiles compRes fileName (codeGenerator $ platform opts) 66 | where compRes = compileToCCore' opts prg' 67 | prg' = fst $ fromCoreUT opts (encodeFunctionName funName) prg 68 | 69 | writeFiles :: SplitModule -> FilePath -> String -> IO () 70 | writeFiles prg fileName "c" = do 71 | writeFile cfile $ unlines [ "#include \"" ++ takeFileName hfile ++ "\"" 72 | , "\n" 73 | , sourceCode $ implementation prg 74 | ] 75 | writeFile hfile $ withIncludeGuard $ sourceCode $ interface prg 76 | where 77 | hfile = makeHFileName fileName 78 | cfile = makeCFileName fileName 79 | 80 | withIncludeGuard code = unlines [ "#ifndef " ++ guardName 81 | , "#define " ++ guardName 82 | , "" 83 | , code 84 | , "" 85 | , "#endif // " ++ guardName 86 | ] 87 | 88 | guardName = map ((\c -> if c `elem` toBeChanged then '_' else c) . toUpper) hfile 89 | where 90 | toBeChanged = "./\\" 91 | writeFiles prg fileName _ = writeFile fileName $ sourceCode $ implementation prg 92 | 93 | icompile :: (Syntactic t) => t -> IO () 94 | icompile = icompileWith defaultOptions 95 | 96 | icompileWith :: (Syntactic t) => Options -> t -> IO () 97 | icompileWith opts = icompile' opts "test" 98 | 99 | icompile' :: (Syntactic t) => Options -> String -> t -> IO () 100 | icompile' opts functionName prg = do 101 | let res = compileToCCore functionName opts prg 102 | when (printHeader opts) $ do 103 | putStrLn "=============== Header ================" 104 | putStrLn $ sourceCode $ interface res 105 | putStrLn "=============== Source ================" 106 | putStrLn $ sourceCode $ implementation res 107 | 108 | -- | Get the generated core for a program. 109 | getCore :: (Syntactic t) => t -> Module () 110 | getCore = fromCore defaultOptions "test" 111 | 112 | -- | Print the generated core for a program. 113 | printCore :: (Syntactic t) => t -> IO () 114 | printCore prog = print $ getCore prog 115 | 116 | targetsFromPlatform :: Platform -> [Target] 117 | targetsFromPlatform pf = tfp $ name pf 118 | where tfp "c99" = [] 119 | tfp "c99OpenMp" = [] 120 | tfp "c99Wool" = [Wool] 121 | tfp "ba" = [BA] 122 | 123 | program :: Syntactic a => a -> IO () 124 | program p = programOpts p defaultOptions 125 | 126 | programOpts :: Syntactic a => a -> Options -> IO () 127 | programOpts p opts = do args <- getArgs 128 | programOptsArgs p defaultProgOpts{backOpts = opts} args 129 | 130 | programOptsArgs :: Syntactic a => a -> ProgOpts -> [String] -> IO () 131 | programOptsArgs p opts args = programComp (const (return p)) opts args 132 | 133 | programComp :: Syntactic a => ([String] -> IO a) -> ProgOpts -> [String] -> IO () 134 | programComp pc opts args = do name <- getProgName 135 | let (opts1,nonopts) = decodeOpts (optsFromName opts name) args 136 | let header = "Usage: " ++ name ++ "