├── src ├── Onnx │ ├── Onnx │ │ ├── NodeProto.o-boot │ │ ├── TypeProto.o-boot │ │ ├── NodeProto.hi-boot │ │ ├── TypeProto.hi-boot │ │ ├── NodeProto.hs-boot │ │ ├── TypeProto.hs-boot │ │ ├── TensorShapeProto │ │ │ └── Dimension │ │ │ │ └── Value.hs │ │ ├── TypeProto │ │ │ ├── Value.hs │ │ │ └── Sequence.hs │ │ ├── TensorProto │ │ │ ├── DataLocation.hs │ │ │ └── Segment.hs │ │ ├── Version.hs │ │ ├── TensorShapeProto.hs │ │ └── AttributeProto │ │ │ └── AttributeType.hs │ └── README ├── Feldspar │ ├── Algorithm │ │ ├── FFT │ │ │ ├── Utils.hs │ │ │ ├── Twids.hs │ │ │ └── Push.hs │ │ ├── CRC.hs │ │ └── FFT.hs │ ├── Memoize.hs │ ├── Core │ │ ├── Middleend │ │ │ ├── LetSinking.hs │ │ │ ├── UniqueVars.hs │ │ │ ├── Constructors.hs │ │ │ ├── CreateTasks.hs │ │ │ ├── PushLets.hs │ │ │ └── PassManager.hs │ │ ├── Collection.hs │ │ ├── AdjustBindings.hs │ │ └── Eval.hs │ ├── Future.hs │ ├── SimpleVector.hs │ ├── Par.hs │ ├── Compiler │ │ └── Backend │ │ │ └── C │ │ │ └── Tic64x.hs │ ├── Vector │ │ └── Shape.hs │ ├── Option.hs │ └── Mutable.hs ├── clib │ └── include │ │ ├── feldspar_future.h │ │ ├── log.h │ │ ├── ivar.h │ │ └── feldspar_array.h └── Feldspar.hs ├── tests ├── gold │ ├── selectT.txt │ ├── not1.c │ ├── ffiTest.c │ ├── pairParam.c │ ├── not1.h │ ├── not1_ret.c │ ├── not1_ret.h │ ├── tuples.h │ ├── ffiTest.h │ ├── example9.h │ ├── foreignEffect.h │ ├── switcher.h │ ├── issue128_ex1.h │ ├── issue128_ex2.h │ ├── issue128_ex3.h │ ├── pairParam_ret.c │ ├── noinline1.c │ ├── foreignEffect.c │ ├── topLevelConsts.h │ ├── noinline1.h │ ├── noshareT.txt │ ├── fut1.h │ ├── topLevelConsts_native.h │ ├── issue128_ex1.c │ ├── example9.c │ ├── fut1_ret.h │ ├── ivartest.h │ ├── pairRet.c │ ├── pairRet.h │ ├── pairParam.h │ ├── pairParam_ret.h │ ├── switcher.c │ ├── shareT.txt │ ├── complexWhileCond.h │ ├── pairParam2.c │ ├── topLevelConsts.c │ ├── issue128_ex2.c │ ├── topLevelConsts_native.c │ ├── concatV.h │ ├── concatVM.h │ ├── issue128_ex3.c │ ├── ivartest2.h │ ├── pairParam2.h │ ├── arrayInStruct.h │ ├── arrayInStruct_wool.h │ ├── arrayInStruct_openMP.h │ ├── example9.txt │ ├── divConq3.h │ ├── fut1.c │ ├── fut1_ret.c │ ├── arrayInStructInStruct.c │ ├── ivartest.c │ ├── topLevelConsts.txt │ ├── ivartest2.c │ ├── complexWhileCond.c │ ├── scanlPush.h │ ├── trickySharing.txt │ ├── arrayInStructInStruct.h │ ├── metrics.h │ ├── concatVM.c │ ├── monadicSharing.txt │ ├── arrayInStruct.c │ ├── arrayInStruct_openMP.c │ ├── concatV.c │ ├── tuples.c │ ├── arrayInStruct_wool.c │ ├── deepArrayCopy.h │ ├── scanlPush.c │ ├── divConq3.c │ ├── metrics.c │ └── deepArrayCopy.c ├── TutorialTest.hs └── Feldspar │ ├── Vector │ └── Test.hs │ ├── Core │ └── Test.hs │ ├── Mutable │ └── Test.hs │ └── Stream │ └── Test.hs ├── benchs ├── MatMulC.h ├── BenchmarkUtils.hs ├── MatMulC.c ├── FFT.hs ├── FIR_Fusion.hs ├── CRC.hs └── MatMul.hs ├── examples ├── Tutorial │ ├── back.html │ ├── Makefile │ ├── Array.lhs │ ├── index.lhs │ ├── SimpleVector.lhs │ ├── Vector.lhs │ ├── style.css │ ├── Basic.lhs │ └── Patch.lhs └── Examples │ └── Simple │ └── Basics.hs ├── .gitignore ├── README.md ├── hie.yaml ├── CONTRIBUTING.md ├── .github └── workflows │ └── ci.yml ├── LICENSE ├── stack.yaml ├── stack-8.8.4.yaml └── Setup.hs /src/Onnx/Onnx/NodeProto.o-boot: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/Onnx/Onnx/TypeProto.o-boot: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/gold/selectT.txt: -------------------------------------------------------------------------------- 1 | 3 : 1xu32 2 | -------------------------------------------------------------------------------- /tests/gold/not1.c: -------------------------------------------------------------------------------- 1 | #include "not1.h" 2 | 3 | 4 | void not1(bool v0, bool * out) 5 | { 6 | *out = !(v0); 7 | } 8 | -------------------------------------------------------------------------------- /src/Onnx/Onnx/NodeProto.hi-boot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Feldspar/feldspar-language/HEAD/src/Onnx/Onnx/NodeProto.hi-boot -------------------------------------------------------------------------------- /src/Onnx/Onnx/TypeProto.hi-boot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Feldspar/feldspar-language/HEAD/src/Onnx/Onnx/TypeProto.hi-boot -------------------------------------------------------------------------------- /tests/gold/ffiTest.c: -------------------------------------------------------------------------------- 1 | #include "ffiTest.h" 2 | 3 | 4 | void ffiTest(float v0, float * out) 5 | { 6 | *out = increment(v0); 7 | } 8 | -------------------------------------------------------------------------------- /tests/gold/pairParam.c: -------------------------------------------------------------------------------- 1 | #include "pairParam.h" 2 | 3 | 4 | void pairParam(struct s_2_2xunsignedS32 * v0, uint32_t * out) 5 | { 6 | *out = (*v0).member1; 7 | } 8 | -------------------------------------------------------------------------------- /tests/gold/not1.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_NOT1_H 2 | #define TMP2_NOT1_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void not1(bool v0, bool * out); 7 | 8 | #endif // TMP2_NOT1_H 9 | -------------------------------------------------------------------------------- /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/not1_ret.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_NOT1_RET_H 2 | #define TMP2_NOT1_RET_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | bool not1__ret(bool v0); 7 | 8 | #endif // TMP2_NOT1_RET_H 9 | -------------------------------------------------------------------------------- /tests/gold/tuples.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_TUPLES_H 2 | #define TMP2_TUPLES_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void tuples(int32_t v0, int32_t * out); 7 | 8 | #endif // TMP2_TUPLES_H 9 | -------------------------------------------------------------------------------- /tests/gold/ffiTest.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_FFITEST_H 2 | #define TMP2_FFITEST_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void ffiTest(float v0, float * out); 7 | 8 | #endif // TMP2_FFITEST_H 9 | -------------------------------------------------------------------------------- /tests/gold/example9.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_EXAMPLE9_H 2 | #define TMP2_EXAMPLE9_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void example9(int32_t v0, int32_t * out); 7 | 8 | #endif // TMP2_EXAMPLE9_H 9 | -------------------------------------------------------------------------------- /benchs/MatMulC.h: -------------------------------------------------------------------------------- 1 | #ifndef _MATMULC_ 2 | #define _MATMULC_ 3 | 4 | void MatMulC(int, int, double *, double *, double *); 5 | void MatMulCopt(int, int, double *, double *, double *); 6 | 7 | #endif 8 | -------------------------------------------------------------------------------- /examples/Tutorial/back.html: -------------------------------------------------------------------------------- 1 |
2 |
3 |

[Back to index]

4 |
5 | -------------------------------------------------------------------------------- /tests/gold/foreignEffect.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_FOREIGNEFFECT_H 2 | #define TMP2_FOREIGNEFFECT_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void foreignEffect(void * out); 7 | 8 | #endif // TMP2_FOREIGNEFFECT_H 9 | -------------------------------------------------------------------------------- /tests/gold/switcher.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_SWITCHER_H 2 | #define TMP2_SWITCHER_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void switcher(uint8_t v0, bool v1, uint8_t * out); 7 | 8 | #endif // TMP2_SWITCHER_H 9 | -------------------------------------------------------------------------------- /tests/gold/issue128_ex1.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_ISSUE128_EX1_H 2 | #define TMP2_ISSUE128_EX1_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void issue128__ex1(uint32_t v0, uint32_t * out); 7 | 8 | #endif // TMP2_ISSUE128_EX1_H 9 | -------------------------------------------------------------------------------- /tests/gold/issue128_ex2.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_ISSUE128_EX2_H 2 | #define TMP2_ISSUE128_EX2_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void issue128__ex2(uint32_t v0, uint32_t * out); 7 | 8 | #endif // TMP2_ISSUE128_EX2_H 9 | -------------------------------------------------------------------------------- /tests/gold/issue128_ex3.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_ISSUE128_EX3_H 2 | #define TMP2_ISSUE128_EX3_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void issue128__ex3(uint32_t v0, uint32_t * out); 7 | 8 | #endif // TMP2_ISSUE128_EX3_H 9 | -------------------------------------------------------------------------------- /tests/gold/pairParam_ret.c: -------------------------------------------------------------------------------- 1 | #include "pairParam_ret.h" 2 | 3 | 4 | uint32_t pairParam__ret(struct s_2_2xunsignedS32 * v0) 5 | { 6 | uint32_t out; 7 | 8 | out = (*v0).member1; 9 | return(out); 10 | } 11 | -------------------------------------------------------------------------------- /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/foreignEffect.c: -------------------------------------------------------------------------------- 1 | #include "foreignEffect.h" 2 | 3 | 4 | void foreignEffect(void * out) 5 | { 6 | float v0; 7 | 8 | alert(); 9 | v0 = getPos(); 10 | launchMissiles(v0); 11 | *out = cleanUp(); 12 | } 13 | -------------------------------------------------------------------------------- /tests/gold/topLevelConsts.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_TOPLEVELCONSTS_H 2 | #define TMP2_TOPLEVELCONSTS_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void topLevelConsts(uint32_t v1, uint32_t v2, uint32_t * out); 7 | 8 | #endif // TMP2_TOPLEVELCONSTS_H 9 | -------------------------------------------------------------------------------- /tests/gold/noinline1.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_NOINLINE1_H 2 | #define TMP2_NOINLINE1_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void noinline0(bool v0, bool * out); 7 | 8 | void noinline1(bool v0, bool * out); 9 | 10 | #endif // TMP2_NOINLINE1_H 11 | -------------------------------------------------------------------------------- /tests/gold/noshareT.txt: -------------------------------------------------------------------------------- 1 | Tup {((1xu32,1xu32),(1xu32,1xu32)) in (([1,1], [2,2]), ([3,3], [2,2]))} 2 | ├╴Tup {(1xu32,1xu32) in ([1,1], [2,2])} 3 | │ ├╴1 : 1xu32 4 | │ └╴2 : 1xu32 5 | └╴Tup {(1xu32,1xu32) in ([3,3], [2,2])} 6 | ├╴3 : 1xu32 7 | └╴2 : 1xu32 8 | -------------------------------------------------------------------------------- /tests/gold/fut1.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_FUT1_H 2 | #define TMP2_FUT1_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void task_core0(struct ivar e0); 7 | 8 | void task0(void * params); 9 | 10 | void fut1(struct ivar v0, struct ivar * out); 11 | 12 | #endif // TMP2_FUT1_H 13 | -------------------------------------------------------------------------------- /tests/gold/topLevelConsts_native.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_TOPLEVELCONSTS_NATIVE_H 2 | #define TMP2_TOPLEVELCONSTS_NATIVE_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void topLevelConsts__native(uint32_t v1, uint32_t v2, uint32_t * out); 7 | 8 | #endif // TMP2_TOPLEVELCONSTS_NATIVE_H 9 | -------------------------------------------------------------------------------- /.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 | .stack-work/ 18 | src/Onnx.hs 19 | 20 | tmp 21 | tmp2 22 | -------------------------------------------------------------------------------- /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 | *out = 10; 12 | } 13 | else 14 | { 15 | *out = v0; 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /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/fut1_ret.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_FUT1_RET_H 2 | #define TMP2_FUT1_RET_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void task_core0(struct ivar e0); 7 | 8 | void task0(void * params); 9 | 10 | void fut1__ret(struct ivar v0, struct ivar * out); 11 | 12 | #endif // TMP2_FUT1_RET_H 13 | -------------------------------------------------------------------------------- /tests/TutorialTest.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Tutorial.Basic 4 | import Tutorial.Array 5 | import Tutorial.SimpleVector 6 | import Tutorial.Vector 7 | import Tutorial.Size 8 | import Tutorial.Patch 9 | 10 | -- Currently only testing compilation 11 | 12 | main = return () 13 | 14 | -------------------------------------------------------------------------------- /tests/gold/ivartest.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_IVARTEST_H 2 | #define TMP2_IVARTEST_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | void task_core0(uint32_t v0, struct ivar e1); 7 | 8 | void task0(void * params); 9 | 10 | void ivartest(uint32_t v0, uint32_t * out); 11 | 12 | #endif // TMP2_IVARTEST_H 13 | -------------------------------------------------------------------------------- /tests/gold/pairRet.c: -------------------------------------------------------------------------------- 1 | #include "pairRet.h" 2 | 3 | 4 | void pairRet(uint32_t v1, struct s_2_2xunsignedS32 * out) 5 | { 6 | if ((v1 > 3)) 7 | { 8 | (*out).member1 = 3; 9 | (*out).member2 = 9; 10 | } 11 | else 12 | { 13 | (*out).member1 = 7; 14 | (*out).member2 = 5; 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /tests/gold/pairRet.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_PAIRRET_H 2 | #define TMP2_PAIRRET_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct s_2_2xunsignedS32 7 | { 8 | uint32_t member1; 9 | uint32_t member2; 10 | }; 11 | 12 | void pairRet(uint32_t v1, struct s_2_2xunsignedS32 * out); 13 | 14 | #endif // TMP2_PAIRRET_H 15 | -------------------------------------------------------------------------------- /tests/gold/pairParam.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_PAIRPARAM_H 2 | #define TMP2_PAIRPARAM_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct s_2_2xunsignedS32 7 | { 8 | uint32_t member1; 9 | uint32_t member2; 10 | }; 11 | 12 | void pairParam(struct s_2_2xunsignedS32 * v0, uint32_t * out); 13 | 14 | #endif // TMP2_PAIRPARAM_H 15 | -------------------------------------------------------------------------------- /tests/gold/pairParam_ret.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_PAIRPARAM_RET_H 2 | #define TMP2_PAIRPARAM_RET_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct s_2_2xunsignedS32 7 | { 8 | uint32_t member1; 9 | uint32_t member2; 10 | }; 11 | 12 | uint32_t pairParam__ret(struct s_2_2xunsignedS32 * v0); 13 | 14 | #endif // TMP2_PAIRPARAM_RET_H 15 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/Feldspar/Algorithm/FFT/Utils.hs: -------------------------------------------------------------------------------- 1 | module Feldspar.Algorithm.FFT.Utils where 2 | 3 | import qualified Prelude as P 4 | 5 | import Feldspar 6 | import Feldspar.Vector 7 | 8 | withLen :: Data Length 9 | -> (Pull DIM1 a -> Pull DIM1 b) 10 | -> Pull DIM1 a -> Pull DIM1 b 11 | withLen l f = newLen1 l . f . newLen1 l 12 | 13 | -------------------------------------------------------------------------------- /tests/gold/shareT.txt: -------------------------------------------------------------------------------- 1 | Let 2 | ├╴Var v0 : (1xu32,1xu32) = 3 | │ └╴Tup {(1xu32,1xu32) in ([1,1], [2,2])} 4 | │ ├╴1 : 1xu32 5 | │ └╴2 : 1xu32 6 | └╴In 7 | └╴Tup {((1xu32,1xu32),(1xu32,1xu32)) in (([1,1], [2,2]), ([1,1], [2,2]))} 8 | ├╴v0 : (1xu32,1xu32) in ([1,1], [2,2]) 9 | └╴v0 : (1xu32,1xu32) in ([1,1], [2,2]) 10 | -------------------------------------------------------------------------------- /tests/gold/complexWhileCond.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_COMPLEXWHILECOND_H 2 | #define TMP2_COMPLEXWHILECOND_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct s_2_2xsignedS32 7 | { 8 | int32_t member1; 9 | int32_t member2; 10 | }; 11 | 12 | void complexWhileCond(int32_t v0, struct s_2_2xsignedS32 * out); 13 | 14 | #endif // TMP2_COMPLEXWHILECOND_H 15 | -------------------------------------------------------------------------------- /tests/gold/pairParam2.c: -------------------------------------------------------------------------------- 1 | #include "pairParam2.h" 2 | 3 | 4 | void pairParam2(struct s_2_2xsignedS16 * v0, struct s_2_2xs_2_2xsignedS16 * 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/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 | -------------------------------------------------------------------------------- /src/Onnx/README: -------------------------------------------------------------------------------- 1 | The files in src/Onnx/Onnx and its subdirectories are generated from the 2 | ONNX protobuf specification file 'onnx.proto' located in src/Onnx using 3 | the command 'hprotoc onnx.proto' given from the src/Onnx directory. 4 | The generated file src/Onnx/Onnx.hs is not committed. 5 | 6 | The 'hprotoc' command comes from the 'hprotoc-2.4.13' package on Hackage. 7 | -------------------------------------------------------------------------------- /examples/Tutorial/Makefile: -------------------------------------------------------------------------------- 1 | documentation: index.html \ 2 | Basic.html \ 3 | Array.html \ 4 | SimpleVector.html \ 5 | Vector.html \ 6 | Size.html \ 7 | Patch.html 8 | 9 | %.html: %.lhs style.css 10 | pandoc -s -S --toc -c style.css -f markdown+lhs $< -o $@ --include-after=back.html 11 | 12 | # Check that the tutorial can be loaded in GHCi 13 | check: 14 | ghci *.lhs 15 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Feldspar Language 2 | ================= 3 | 4 | [![Build Status](https://travis-ci.org/Feldspar/feldspar-language.svg?branch=master)](https://travis-ci.org/Feldspar/feldspar-language.svg?branch=master) 5 | 6 | The goal of the Feldspar project is to define a high-level language that 7 | allows description of high-performance digital signal processing 8 | algorithms. 9 | 10 | 11 | -------------------------------------------------------------------------------- /tests/gold/concatV.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_CONCATV_H 2 | #define TMP2_CONCATV_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct awl_signedS32 7 | { 8 | global int32_t * buffer; 9 | uint32_t length; 10 | }; 11 | 12 | struct awl_awl_signedS32 13 | { 14 | global struct awl_signedS32 * buffer; 15 | uint32_t length; 16 | }; 17 | 18 | void concatV(struct awl_awl_signedS32 * v1, struct awl_signedS32 * out); 19 | 20 | #endif // TMP2_CONCATV_H 21 | -------------------------------------------------------------------------------- /tests/gold/concatVM.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_CONCATVM_H 2 | #define TMP2_CONCATVM_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct awl_signedS32 7 | { 8 | global int32_t * buffer; 9 | uint32_t length; 10 | }; 11 | 12 | struct awl_awl_signedS32 13 | { 14 | global struct awl_signedS32 * buffer; 15 | uint32_t length; 16 | }; 17 | 18 | void concatVM(struct awl_awl_signedS32 * v1, struct awl_signedS32 * out); 19 | 20 | #endif // TMP2_CONCATVM_H 21 | -------------------------------------------------------------------------------- /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 e0; 7 | uint32_t e1; 8 | 9 | switch (v0) 10 | { 11 | case 1: 12 | e0 = 10; 13 | break; 14 | default: 15 | e0 = 45; 16 | break; 17 | } 18 | if ((2 == v0)) 19 | { 20 | e1 = 2; 21 | } 22 | else 23 | { 24 | e1 = v0; 25 | } 26 | *out = (e0 + e1); 27 | } 28 | -------------------------------------------------------------------------------- /tests/gold/ivartest2.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_IVARTEST2_H 2 | #define TMP2_IVARTEST2_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct s_2_2xunsignedS32 7 | { 8 | uint32_t member1; 9 | uint32_t member2; 10 | }; 11 | 12 | void task_core0(struct s_2_2xunsignedS32 * v0, struct ivar e0); 13 | 14 | void task0(void * params); 15 | 16 | void ivartest2(struct s_2_2xunsignedS32 * v0, struct s_2_2xunsignedS32 * out); 17 | 18 | #endif // TMP2_IVARTEST2_H 19 | -------------------------------------------------------------------------------- /tests/gold/pairParam2.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_PAIRPARAM2_H 2 | #define TMP2_PAIRPARAM2_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct s_2_2xsignedS16 7 | { 8 | int16_t member1; 9 | int16_t member2; 10 | }; 11 | 12 | struct s_2_2xs_2_2xsignedS16 13 | { 14 | struct s_2_2xsignedS16 member1; 15 | struct s_2_2xsignedS16 member2; 16 | }; 17 | 18 | void pairParam2(struct s_2_2xsignedS16 * v0, struct s_2_2xs_2_2xsignedS16 * out); 19 | 20 | #endif // TMP2_PAIRPARAM2_H 21 | -------------------------------------------------------------------------------- /tests/gold/arrayInStruct.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_ARRAYINSTRUCT_H 2 | #define TMP2_ARRAYINSTRUCT_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct awl_unsignedS32 7 | { 8 | global uint32_t * buffer; 9 | uint32_t length; 10 | }; 11 | 12 | struct s_2_1xunsignedS32_1xawl_unsignedS32 13 | { 14 | uint32_t member1; 15 | struct awl_unsignedS32 member2; 16 | }; 17 | 18 | void arrayInStruct(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * out); 19 | 20 | #endif // TMP2_ARRAYINSTRUCT_H 21 | -------------------------------------------------------------------------------- /tests/gold/arrayInStruct_wool.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_ARRAYINSTRUCT_WOOL_H 2 | #define TMP2_ARRAYINSTRUCT_WOOL_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct awl_unsignedS32 7 | { 8 | global uint32_t * buffer; 9 | uint32_t length; 10 | }; 11 | 12 | struct s_2_1xunsignedS32_1xawl_unsignedS32 13 | { 14 | uint32_t member1; 15 | struct awl_unsignedS32 member2; 16 | }; 17 | 18 | void arrayInStruct__wool(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * out); 19 | 20 | #endif // TMP2_ARRAYINSTRUCT_WOOL_H 21 | -------------------------------------------------------------------------------- /tests/gold/arrayInStruct_openMP.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_ARRAYINSTRUCT_OPENMP_H 2 | #define TMP2_ARRAYINSTRUCT_OPENMP_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct awl_unsignedS32 7 | { 8 | global uint32_t * buffer; 9 | uint32_t length; 10 | }; 11 | 12 | struct s_2_1xunsignedS32_1xawl_unsignedS32 13 | { 14 | uint32_t member1; 15 | struct awl_unsignedS32 member2; 16 | }; 17 | 18 | void arrayInStruct__openMP(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * out); 19 | 20 | #endif // TMP2_ARRAYINSTRUCT_OPENMP_H 21 | -------------------------------------------------------------------------------- /src/Feldspar/Algorithm/FFT/Twids.hs: -------------------------------------------------------------------------------- 1 | module Feldspar.Algorithm.FFT.Twids where 2 | 3 | import qualified Prelude 4 | 5 | import Feldspar 6 | import Feldspar.Vector 7 | 8 | twid :: Data Index -> Data Length -> Data Index -> Data (Complex Double) 9 | twid scale n k = share (1 / i2f n) $ \d -> cis (i2f scale * 2 * pi * i2f k * d) 10 | 11 | twids :: Data Length -> Pull1 (Complex Double) 12 | twids n = indexed1 (n `div` 2) $ twid (-1) n 13 | 14 | itwids :: Data Length -> Pull1 (Complex Double) 15 | itwids n = indexed1 (n `div` 2) $ twid 1 n 16 | 17 | -------------------------------------------------------------------------------- /tests/gold/example9.txt: -------------------------------------------------------------------------------- 1 | Lambda v0 : 1xi32 2 | └╴Let 3 | ├╴Var v2 : 1xi32 = 4 | │ └╴Add {1xi32 in [*,*]} 5 | │ ├╴v0 : 1xi32 in [*,*] 6 | │ └╴20 : 1xi32 7 | └╴In 8 | └╴Condition {1xi32 in [*,*]} 9 | ├╴LTH {1xbool in [*,*]} 10 | │ ├╴v0 : 1xi32 in [*,*] 11 | │ └╴5 : 1xi32 12 | ├╴Mul {1xi32 in [*,*]} 13 | │ ├╴3 : 1xi32 14 | │ └╴v2 : 1xi32 in [*,*] 15 | └╴Mul {1xi32 in [*,*]} 16 | ├╴30 : 1xi32 17 | └╴v2 : 1xi32 in [*,*] 18 | -------------------------------------------------------------------------------- /tests/gold/divConq3.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_DIVCONQ3_H 2 | #define TMP2_DIVCONQ3_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct awl_i_awl_signedS32 7 | { 8 | global struct ivar * buffer; 9 | uint32_t length; 10 | }; 11 | 12 | struct awl_signedS32 13 | { 14 | global int32_t * buffer; 15 | uint32_t length; 16 | }; 17 | 18 | void task_core0(uint32_t v8, uint32_t v3, struct awl_signedS32 * v1, struct awl_i_awl_signedS32 v24); 19 | 20 | void task0(void * params); 21 | 22 | void divConq3(struct awl_signedS32 * v1, struct awl_signedS32 * out); 23 | 24 | #endif // TMP2_DIVCONQ3_H 25 | -------------------------------------------------------------------------------- /tests/gold/fut1.c: -------------------------------------------------------------------------------- 1 | #include "fut1.h" 2 | 3 | 4 | void task_core0(struct ivar e0) 5 | { 6 | int32_t e1; 7 | 8 | ivar_get(int32_t, &e1, e0); 9 | ivar_put(int32_t, e0, &e1); 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 e0; 20 | 21 | taskpool_init(4, 4, 4); 22 | e0 = *out; 23 | e0 = v0; 24 | for (uint32_t v1 = 0; v1 < 20; v1 += 1) 25 | { 26 | ivar_init(&e0); 27 | spawn1(task0, struct ivar, e0); 28 | } 29 | *out = e0; 30 | taskpool_shutdown(); 31 | } 32 | -------------------------------------------------------------------------------- /tests/gold/fut1_ret.c: -------------------------------------------------------------------------------- 1 | #include "fut1_ret.h" 2 | 3 | 4 | void task_core0(struct ivar e0) 5 | { 6 | int32_t e1; 7 | 8 | ivar_get(int32_t, &e1, e0); 9 | ivar_put(int32_t, e0, &e1); 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 e0; 20 | 21 | taskpool_init(4, 4, 4); 22 | e0 = *out; 23 | e0 = v0; 24 | for (uint32_t v1 = 0; v1 < 20; v1 += 1) 25 | { 26 | ivar_init(&e0); 27 | spawn1(task0, struct ivar, e0); 28 | } 29 | *out = e0; 30 | taskpool_shutdown(); 31 | } 32 | -------------------------------------------------------------------------------- /tests/gold/arrayInStructInStruct.c: -------------------------------------------------------------------------------- 1 | #include "arrayInStructInStruct.h" 2 | 3 | 4 | void arrayInStructInStruct(struct s_2_1xunsignedS32_1xs_2_1xunsignedS32_1xawl_unsignedS32 * v0, struct s_2_1xunsignedS32_1xs_2_1xunsignedS32_1xawl_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/ivartest.c: -------------------------------------------------------------------------------- 1 | #include "ivartest.h" 2 | 3 | 4 | void task_core0(uint32_t v0, struct ivar e1) 5 | { 6 | uint32_t e2; 7 | 8 | e2 = (v0 + 1); 9 | ivar_put(uint32_t, e1, &e2); 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 e0; 20 | struct ivar e1; 21 | 22 | taskpool_init(4, 4, 4); 23 | ivar_init(&e1); 24 | spawn2(task0, uint32_t, v0, struct ivar, e1); 25 | ivar_get_nontask(uint32_t, &e0, e1); 26 | *out = (e0 << 1); 27 | taskpool_shutdown(); 28 | ivar_destroy(&e1); 29 | } 30 | -------------------------------------------------------------------------------- /tests/gold/topLevelConsts.txt: -------------------------------------------------------------------------------- 1 | Lambda v1 : 1xu32 2 | └╴Lambda v2 : 1xu32 3 | └╴Let 4 | ├╴Var v5 : 1xu32 = 5 | │ └╴Add {1xu32 in [*,*]} 6 | │ ├╴v2 : 1xu32 in [*,*] 7 | │ └╴5 : 1xu32 8 | └╴In 9 | └╴Condition {1xu32 in [1,6]} 10 | ├╴LTH {1xbool in [*,*]} 11 | │ ├╴v1 : 1xu32 in [*,*] 12 | │ └╴5 : 1xu32 13 | ├╴GetIx {1xu32 in [2,6]} 14 | │ ├╴[2,3,4,5,6] : a[5:5]1xu32 15 | │ └╴v5 : 1xu32 in [*,*] 16 | └╴GetIx {1xu32 in [1,5]} 17 | ├╴[1,2,3,4,5] : a[5:5]1xu32 18 | └╴v5 : 1xu32 in [*,*] 19 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | stack: 3 | - path: "./src" 4 | component: "feldspar-language:lib" 5 | - path: "./.stack-work/dist/x86_64-linux-tinfo6/Cabal-3.2.1.0/build/autogen/" 6 | component: "feldspar-language:lib" 7 | - path: "./src/Onnx" 8 | component: "feldspar-language:exe:onnxToFeld" 9 | - path: "./tests" 10 | component: "feldspar-language:test:regression" 11 | - path: "./tests/TutorialTest.hs" 12 | component: "feldspar-language:test:tutorial" 13 | - path: "./benchs/CRC.hs" 14 | component: "feldspar-language:bench:crc" 15 | - path: "./benchs/FFT.hs" 16 | component: "feldspar-language:bench:fft" 17 | -------------------------------------------------------------------------------- /tests/gold/ivartest2.c: -------------------------------------------------------------------------------- 1 | #include "ivartest2.h" 2 | 3 | 4 | void task_core0(struct s_2_2xunsignedS32 * v0, struct ivar e0) 5 | { 6 | ivar_put(struct s_2_2xunsignedS32, e0, &*v0); 7 | } 8 | 9 | void task0(void * params) 10 | { 11 | run2(task_core0, struct s_2_2xunsignedS32 *, struct ivar); 12 | } 13 | 14 | void ivartest2(struct s_2_2xunsignedS32 * v0, struct s_2_2xunsignedS32 * out) 15 | { 16 | struct ivar e0; 17 | 18 | taskpool_init(4, 4, 4); 19 | ivar_init(&e0); 20 | spawn2(task0, struct s_2_2xunsignedS32 *, v0, struct ivar, e0); 21 | ivar_get_nontask(struct s_2_2xunsignedS32, &*out, e0); 22 | taskpool_shutdown(); 23 | ivar_destroy(&e0); 24 | } 25 | -------------------------------------------------------------------------------- /tests/gold/complexWhileCond.c: -------------------------------------------------------------------------------- 1 | #include "complexWhileCond.h" 2 | 3 | 4 | void complexWhileCond(int32_t v0, struct s_2_2xsignedS32 * out) 5 | { 6 | struct s_2_2xsignedS32 e0 = { 0 }; 7 | struct s_2_2xsignedS32 v9 = { 0 }; 8 | int32_t v4; 9 | int32_t v6; 10 | bool v2; 11 | 12 | (e0).member1 = 0; 13 | (e0).member2 = v0; 14 | v4 = (e0).member1; 15 | v6 = ((e0).member2 - v4); 16 | v2 = ((v4 * v4) < (v6 * v6)); 17 | while (v2) 18 | { 19 | (v9).member1 = ((e0).member1 + 1); 20 | (v9).member2 = (e0).member2; 21 | e0 = v9; 22 | v4 = (e0).member1; 23 | v6 = ((e0).member2 - v4); 24 | v2 = ((v4 * v4) < (v6 * v6)); 25 | } 26 | *out = e0; 27 | } 28 | -------------------------------------------------------------------------------- /tests/gold/scanlPush.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_SCANLPUSH_H 2 | #define TMP2_SCANLPUSH_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct awl_unsignedS32 7 | { 8 | global uint32_t * buffer; 9 | uint32_t length; 10 | }; 11 | 12 | struct awl_awl_unsignedS32 13 | { 14 | global struct awl_unsignedS32 * buffer; 15 | uint32_t length; 16 | }; 17 | 18 | global struct awl_unsignedS32 * initArray_awl_unsignedS32(global struct awl_unsignedS32 * dst, uint32_t oldLen, uint32_t newLen); 19 | 20 | void freeArray_awl_unsignedS32(global struct awl_unsignedS32 * src, int32_t srcLen); 21 | 22 | void scanlPush(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * v1, struct awl_awl_unsignedS32 * out); 23 | 24 | #endif // TMP2_SCANLPUSH_H 25 | -------------------------------------------------------------------------------- /tests/gold/trickySharing.txt: -------------------------------------------------------------------------------- 1 | Lambda v0 : 1xu32 2 | └╴Let 3 | ├╴Var v4 : 1xu32 = 4 | │ └╴Add {1xu32 in [*,*]} 5 | │ ├╴Mul {1xu32 in [*,*]} 6 | │ │ ├╴v0 : 1xu32 in [*,*] 7 | │ │ └╴3 : 1xu32 8 | │ └╴Mul {1xu32 in [*,*]} 9 | │ ├╴v0 : 1xu32 in [*,*] 10 | │ └╴5 : 1xu32 11 | ├╴Var v5 : 1xu32 = 12 | │ └╴Add {1xu32 in [*,*]} 13 | │ ├╴v4 : 1xu32 in [*,*] 14 | │ └╴Mul {1xu32 in [*,*]} 15 | │ ├╴v0 : 1xu32 in [*,*] 16 | │ └╴7 : 1xu32 17 | └╴In 18 | └╴Add {1xu32 in [*,*]} 19 | ├╴Add {1xu32 in [*,*]} 20 | │ ├╴v5 : 1xu32 in [*,*] 21 | │ └╴v4 : 1xu32 in [*,*] 22 | └╴v5 : 1xu32 in [*,*] 23 | -------------------------------------------------------------------------------- /examples/Tutorial/Array.lhs: -------------------------------------------------------------------------------- 1 | % Core arrays 2 | 3 |
4 | 5 | 6 | 7 | *[This document needs to be extended.]* 8 | 9 | It is generally not recommended to use core arrays directly. A more high-level interface is provided by the [vector library](Vector.html). 10 | 11 | \begin{code} 12 | module Tutorial.Array where 13 | 14 | import qualified Prelude 15 | import Feldspar 16 | \end{code} 17 | 18 | An array containing the powers of two: 19 | 20 | \begin{code} 21 | powsOfTwo :: Data Length -> Data [WordN] 22 | powsOfTwo l = parallel l (2^) 23 | \end{code} 24 | 25 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 26 | *Tutorial.Array> eval powsOfTwo 10 27 | [1,2,4,8,16,32,64,128,256,512] 28 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 29 | 30 | -------------------------------------------------------------------------------- /tests/gold/arrayInStructInStruct.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_ARRAYINSTRUCTINSTRUCT_H 2 | #define TMP2_ARRAYINSTRUCTINSTRUCT_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct awl_unsignedS32 7 | { 8 | global uint32_t * buffer; 9 | uint32_t length; 10 | }; 11 | 12 | struct s_2_1xunsignedS32_1xawl_unsignedS32 13 | { 14 | uint32_t member1; 15 | struct awl_unsignedS32 member2; 16 | }; 17 | 18 | struct s_2_1xunsignedS32_1xs_2_1xunsignedS32_1xawl_unsignedS32 19 | { 20 | uint32_t member1; 21 | struct s_2_1xunsignedS32_1xawl_unsignedS32 member2; 22 | }; 23 | 24 | void arrayInStructInStruct(struct s_2_1xunsignedS32_1xs_2_1xunsignedS32_1xawl_unsignedS32 * v0, struct s_2_1xunsignedS32_1xs_2_1xunsignedS32_1xawl_unsignedS32 * out); 25 | 26 | #endif // TMP2_ARRAYINSTRUCTINSTRUCT_H 27 | -------------------------------------------------------------------------------- /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 { reportFile = Just report } 12 | 13 | dimToString ls = intercalate "x" (map show ls) 14 | 15 | mkData ds ls = do 16 | putStrLn $ unwords ["Alloc array with", dimToString ls, "elements"] 17 | evaluate =<< pack (take (fromIntegral $ product ls) ds) 18 | 19 | mkData2 ds ls = do 20 | putStrLn $ unwords ["Alloc array with", dimToString ls, "elements"] 21 | evaluate =<< pack (ls, take (fromIntegral $ product ls) ds) 22 | 23 | mkBench name ls = bench (name ++ "_" ++ dimToString ls) 24 | -------------------------------------------------------------------------------- /src/Feldspar/Memoize.hs: -------------------------------------------------------------------------------- 1 | module Feldspar.Memoize where 2 | 3 | import qualified Prelude 4 | 5 | import Feldspar 6 | 7 | -- | Accelerate the function @f@ using a lookup table. 8 | -- The table will span all possible input values. 9 | tabulate :: (Bits i, Integral i, Syntax a) 10 | => (Data i -> a) -> Data i -> a 11 | tabulate f i = tabulateLen (2 ^ bitSize i) f i 12 | 13 | -- | Accelerate the function @f@ by creating a lookup table of the results for the 14 | -- @len@ first argument values 15 | -- 16 | -- Note. To really get a table the function must be closed after the 17 | -- application to @i@ 18 | -- 19 | tabulateLen :: (Integral i, Syntax a) 20 | => Data Length -> (Data i -> a) -> Data i -> a 21 | tabulateLen len f i = sugar $ share (parallel len (desugar.f.i2n)) (!i2n i) 22 | 23 | -------------------------------------------------------------------------------- /examples/Tutorial/index.lhs: -------------------------------------------------------------------------------- 1 | % Feldspar Tutorial 2 | 3 | 4 | 5 | 11 | 12 | 13 | 14 | This is a light-weight introduction to the [Feldspar](http://hackage.haskell.org/package/feldspar-language) language in the form of a set of documented example files. The source code of the examples is available as literate Haskell files distributed in the `examples/Tutorial` directory of the [`feldspar-language`](http://hackage.haskell.org/package/feldspar-language) package. This documentation does not cover the [back end](http://hackage.haskell.org/package/feldspar-compiler). 15 | 16 |

Contents

17 | 18 | * [Basic usage](Basic.html) 19 | * [Core arrays](Array.html) 20 | * [Simple vector library](SimpleVector.html) 21 | * [Vector library](Vector.html) 22 | * [Size analysis](Size.html) 23 | * [Type and size patches](Patch.html) 24 | 25 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Contributing to Feldspar 2 | --------------------- 3 | 4 | Start by reading [tibbe's style guide](https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md). 5 | Current Feldspar follows most of the conventions except for the section on 6 | data types. 7 | 8 | Use your judgement. Having a line that is 83 characters long might be a better 9 | choice compared to the alternative even if it violates the style guide. 10 | 11 | 1. No commits to master in your fork. 12 | 13 | 1. Follow whatever code style the file uses. One consistent but bad 14 | style is preferable over having eight different good styles in the 15 | same file. 16 | 17 | 1. No trailing whitespace. 18 | 19 | 1. Run `cabal test` before committing. 20 | 21 | 1. Use one commit per logical change. 22 | 23 | 1. Keep the pile of small style fixes and similar in one or several 24 | separate commits. 25 | 26 | 1. Make a sensible commit message. 27 | 28 | 29 | -------------------------------------------------------------------------------- /tests/Feldspar/Vector/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Feldspar.Vector.Test (vectorTests) where 4 | 5 | import qualified Prelude as P 6 | import qualified Data.List as P 7 | 8 | import Feldspar 9 | import Feldspar.Vector 10 | 11 | import Test.Tasty 12 | import Test.Tasty.TH 13 | import Test.Tasty.QuickCheck 14 | 15 | vectorTests = $(testGroupGenerator) 16 | 17 | -- TODO implement tests 18 | -- 19 | -- prop_freeze_thaw = eval (freezeVector . thawVector) === (id :: [Index] -> [Index]) 20 | -- prop_thaw_freeze = eval (thawVector . freezeVector) === (id :: [Index] -> [Index]) 21 | 22 | -- prop_length = eval (length -:: tVec1 tIndex >-> tData tLength) === P.genericLength 23 | 24 | -- prop_append = eval ((++) -:: tVec1 tIndex >-> id >-> id) === (P.++) 25 | -- prop_take = eval (take -:: tData tLength >-> tVec1 tIndex >-> id) === P.genericTake 26 | -- prop_drop = eval (drop -:: tData tLength >-> tVec1 tIndex >-> id) === P.genericDrop 27 | -- prop_revrev = eval ((reverse . reverse) -:: tVec1 tIndex >-> id) ==== id 28 | -------------------------------------------------------------------------------- /src/Onnx/Onnx/NodeProto.hs-boot: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -w #-} 3 | module Onnx.NodeProto (NodeProto) where 4 | import qualified Prelude as Prelude' 5 | import qualified Data.Typeable as Prelude' 6 | import qualified Data.Data as Prelude' 7 | import qualified GHC.Generics as Prelude' 8 | import qualified Text.ProtocolBuffers.Header as P' 9 | 10 | data NodeProto deriving Prelude'.Typeable 11 | 12 | instance P'.MessageAPI msg' (msg' -> NodeProto) NodeProto 13 | 14 | instance Prelude'.Show NodeProto 15 | 16 | instance Prelude'.Eq NodeProto 17 | 18 | instance Prelude'.Ord NodeProto 19 | 20 | instance Prelude'.Data NodeProto 21 | 22 | instance Prelude'.Generic NodeProto 23 | 24 | instance P'.Mergeable NodeProto 25 | 26 | instance P'.Default NodeProto 27 | 28 | instance P'.Wire NodeProto 29 | 30 | instance P'.GPB NodeProto 31 | 32 | instance P'.ReflectDescriptor NodeProto 33 | 34 | instance P'.TextType NodeProto 35 | 36 | instance P'.TextMsg NodeProto -------------------------------------------------------------------------------- /src/Onnx/Onnx/TypeProto.hs-boot: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -w #-} 3 | module Onnx.TypeProto (TypeProto) where 4 | import qualified Prelude as Prelude' 5 | import qualified Data.Typeable as Prelude' 6 | import qualified Data.Data as Prelude' 7 | import qualified GHC.Generics as Prelude' 8 | import qualified Text.ProtocolBuffers.Header as P' 9 | 10 | data TypeProto deriving Prelude'.Typeable 11 | 12 | instance P'.MessageAPI msg' (msg' -> TypeProto) TypeProto 13 | 14 | instance Prelude'.Show TypeProto 15 | 16 | instance Prelude'.Eq TypeProto 17 | 18 | instance Prelude'.Ord TypeProto 19 | 20 | instance Prelude'.Data TypeProto 21 | 22 | instance Prelude'.Generic TypeProto 23 | 24 | instance P'.Mergeable TypeProto 25 | 26 | instance P'.Default TypeProto 27 | 28 | instance P'.Wire TypeProto 29 | 30 | instance P'.GPB TypeProto 31 | 32 | instance P'.ReflectDescriptor TypeProto 33 | 34 | instance P'.TextType TypeProto 35 | 36 | instance P'.TextMsg TypeProto -------------------------------------------------------------------------------- /tests/gold/metrics.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_METRICS_H 2 | #define TMP2_METRICS_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct awl_signedS32 7 | { 8 | global int32_t * buffer; 9 | uint32_t length; 10 | }; 11 | 12 | struct awl_awl_signedS32 13 | { 14 | global struct awl_signedS32 * buffer; 15 | uint32_t length; 16 | }; 17 | 18 | struct s_2_2xunsignedS32 19 | { 20 | uint32_t member1; 21 | uint32_t member2; 22 | }; 23 | 24 | struct awl_s_2_2xunsignedS32 25 | { 26 | global struct s_2_2xunsignedS32 * buffer; 27 | uint32_t length; 28 | }; 29 | 30 | struct awl_awl_s_2_2xunsignedS32 31 | { 32 | global struct awl_s_2_2xunsignedS32 * buffer; 33 | uint32_t length; 34 | }; 35 | 36 | global struct awl_signedS32 * initArray_awl_signedS32(global struct awl_signedS32 * dst, uint32_t oldLen, uint32_t newLen); 37 | 38 | void freeArray_awl_signedS32(global struct awl_signedS32 * src, int32_t srcLen); 39 | 40 | void metrics(struct awl_signedS32 * v1, struct awl_signedS32 * v2, struct awl_awl_s_2_2xunsignedS32 * v3, struct awl_awl_signedS32 * out); 41 | 42 | #endif // TMP2_METRICS_H 43 | -------------------------------------------------------------------------------- /src/Onnx/Onnx/TensorShapeProto/Dimension/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -w #-} 3 | module Onnx.TensorShapeProto.Dimension.Value where 4 | import Prelude ((+), (/), (++), (.)) 5 | import qualified Prelude as Prelude' 6 | import qualified Data.Typeable as Prelude' 7 | import qualified GHC.Generics as Prelude' 8 | import qualified Data.Data as Prelude' 9 | import qualified Text.ProtocolBuffers.Header as P' 10 | 11 | data Value = Dim_value{dim_value :: (P'.Int64)} 12 | | Dim_param{dim_param :: (P'.Utf8)} 13 | deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) 14 | get'dim_value x 15 | = case x of 16 | Dim_value dim_value -> Prelude'.Just dim_value 17 | _ -> Prelude'.Nothing 18 | get'dim_param x 19 | = case x of 20 | Dim_param dim_param -> Prelude'.Just dim_param 21 | _ -> Prelude'.Nothing 22 | 23 | instance P'.Default Value where 24 | defaultValue = Dim_value P'.defaultValue 25 | 26 | instance P'.Mergeable Value -------------------------------------------------------------------------------- /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 len0; 7 | struct awl_signedS32 e1 = { 0 }; 8 | struct awl_signedS32 v7 = { 0 }; 9 | uint32_t v12; 10 | struct awl_signedS32 v9 = { 0 }; 11 | uint32_t v10; 12 | uint32_t len2; 13 | struct awl_signedS32 e3 = { 0 }; 14 | 15 | len0 = (*v1).length; 16 | e1 = *out; 17 | (e1).buffer = initArray((e1).buffer, (e1).length, sizeof(int32_t), 0); 18 | (e1).length = 0; 19 | for (uint32_t v6 = 0; v6 < len0; v6 += 1) 20 | { 21 | v12 = (e1).length; 22 | v9 = (*v1).buffer[v6]; 23 | v10 = (v9).length; 24 | len2 = (v12 + v10); 25 | (v7).buffer = initArray((v7).buffer, (v7).length, sizeof(int32_t), len2); 26 | (v7).length = len2; 27 | for (uint32_t v17 = 0; v17 < v12; v17 += 1) 28 | { 29 | (v7).buffer[v17] = (e1).buffer[v17]; 30 | } 31 | for (uint32_t v21 = 0; v21 < v10; v21 += 1) 32 | { 33 | (v7).buffer[(v21 + v12)] = (v9).buffer[v21]; 34 | } 35 | e3 = e1; 36 | e1 = v7; 37 | v7 = e3; 38 | } 39 | *out = e1; 40 | freeArray((v7).buffer); 41 | freeArray((v9).buffer); 42 | } 43 | -------------------------------------------------------------------------------- /examples/Examples/Simple/Basics.hs: -------------------------------------------------------------------------------- 1 | module Examples.Simple.Basics where 2 | 3 | import qualified Prelude 4 | import Feldspar 5 | import Feldspar.Vector 6 | 7 | -- Identity function for 32 bit integers. 8 | example1 :: Data Int32 -> Data Int32 9 | example1 = id 10 | 11 | -- Constant function 12 | example2 :: Data Int32 13 | example2 = 2 14 | 15 | -- A constant core vector 16 | example3 :: Data [Int32] 17 | example3 = value [42,1,2,3] 18 | 19 | -- Examples showing some of the integer and boolean operations: 20 | 21 | example4 :: Data Int32 -> Data Int32 22 | example4 x = negate x 23 | 24 | example5 :: Data Int32 -> Data Int32 -> Data Int32 25 | example5 x y = x + y 26 | 27 | example6 :: Data Int32 -> Data Int32 -> Data Bool 28 | example6 x y = x == y 29 | 30 | example7 :: Data Bool 31 | example7 = 2 /= (2 :: Data Int32) -- Type of numeric literals sometimes have to be written explicitly. 32 | 33 | example8 :: Data Bool -> Data Bool 34 | example8 b = not b 35 | 36 | -- Examples on using conditionals: 37 | 38 | example9 :: Data Int32 -> Data Int32 39 | example9 a = a < 5 ? (3 * (a + 20)) $ 30 * (a + 20) 40 | 41 | example10 :: Data Int32 -> Data Int32 42 | example10 a = a < 5 ? (3 * (a + a)) $ 30 * (a + a) 43 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | pull_request: 4 | types: 5 | - opened 6 | - synchronize 7 | 8 | jobs: 9 | build: 10 | runs-on: ubuntu-20.04 11 | strategy: 12 | matrix: 13 | cabal: ["3.4"] 14 | ghc: ["8.8.4", "8.10.7"] 15 | env: 16 | CONFIG: "--enable-tests --enable-benchmarks" 17 | steps: 18 | - uses: actions/checkout@v2 19 | - uses: haskell/actions/setup@v1.2 20 | id: setup-haskell-cabal 21 | with: 22 | ghc-version: ${{ matrix.ghc }} 23 | cabal-version: ${{ matrix.cabal }} 24 | - run: cabal v2-update 25 | - run: cabal v2-freeze $CONFIG 26 | - uses: actions/cache@v2 27 | with: 28 | path: | 29 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 30 | dist-newstyle 31 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 32 | restore-keys: | 33 | ${{ runner.os }}-${{ matrix.ghc }}- 34 | - run: cabal v2-build -j4 $CONFIG 35 | - run: | 36 | export feldspar_language_libdir="$PWD/src/clib" 37 | cabal v2-test $CONFIG 38 | # - run: cabal v2-haddock $CONFIG 39 | - run: cabal check 40 | - run: cabal v2-sdist 41 | -------------------------------------------------------------------------------- /tests/gold/monadicSharing.txt: -------------------------------------------------------------------------------- 1 | Lambda v0 : 1xu32 2 | └╴Run {1xu32 in [*,*]} 3 | └╴Bind {M1xu32 in [*,*]} 4 | ├╴NewRef {MR1xu32 in [*,*]} 5 | │ └╴v0 : 1xu32 in [*,*] 6 | └╴Lambda v1 : R1xu32 7 | └╴Bind {M1xu32 in [*,*]} 8 | ├╴GetRef {M1xu32 in [*,*]} 9 | │ └╴v1 : R1xu32 in [*,*] 10 | └╴Lambda v2 : 1xu32 11 | └╴Let 12 | ├╴Var v3 : 1xu32 = 13 | │ └╴Add {1xu32 in [*,*]} 14 | │ ├╴v2 : 1xu32 in [*,*] 15 | │ └╴3 : 1xu32 16 | └╴In 17 | └╴Bind {M1xu32 in [*,*]} 18 | ├╴NewRef {MR1xu32 in [*,*]} 19 | │ └╴v3 : 1xu32 in [*,*] 20 | └╴Lambda v4 : R1xu32 21 | └╴Bind {M1xu32 in [*,*]} 22 | ├╴GetRef {M1xu32 in [*,*]} 23 | │ └╴v4 : R1xu32 in [*,*] 24 | └╴Lambda v5 : 1xu32 25 | └╴Return {M1xu32 in [*,*]} 26 | └╴Add {1xu32 in [*,*]} 27 | ├╴v5 : 1xu32 in [*,*] 28 | └╴v3 : 1xu32 in [*,*] 29 | -------------------------------------------------------------------------------- /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_1xunsignedS32_1xawl_unsignedS32 e0 = { 0 }; 7 | struct s_2_1xunsignedS32_1xawl_unsignedS32 v6 = { 0 }; 8 | uint32_t len1; 9 | struct awl_unsignedS32 e2 = { 0 }; 10 | bool v3; 11 | 12 | (e0).member1 = (*v0).length; 13 | ((e0).member2).buffer = initCopyArray(((e0).member2).buffer, ((e0).member2).length, sizeof(uint32_t), (*v0).buffer, (*v0).length); 14 | ((e0).member2).length = (*v0).length; 15 | v3 = ((e0).member1 > 0); 16 | while (v3) 17 | { 18 | (v6).member1 = ((e0).member1 - 1); 19 | len1 = ((e0).member2).length; 20 | ((v6).member2).buffer = initArray(((v6).member2).buffer, ((v6).member2).length, sizeof(uint32_t), len1); 21 | ((v6).member2).length = len1; 22 | for (uint32_t v10 = 0; v10 < len1; v10 += 1) 23 | { 24 | ((v6).member2).buffer[v10] = (((e0).member2).buffer[v10] + 5); 25 | } 26 | e2 = (e0).member2; 27 | e0 = v6; 28 | (v6).member2 = e2; 29 | v3 = ((e0).member1 > 0); 30 | } 31 | (*out).buffer = initCopyArray((*out).buffer, (*out).length, sizeof(uint32_t), ((e0).member2).buffer, ((e0).member2).length); 32 | (*out).length = ((e0).member2).length; 33 | freeArray(((e0).member2).buffer); 34 | freeArray(((v6).member2).buffer); 35 | } 36 | -------------------------------------------------------------------------------- /examples/Tutorial/SimpleVector.lhs: -------------------------------------------------------------------------------- 1 | % Simple vector library 2 | 3 |
4 | 5 | 6 | 7 | *[This document needs to be extended.]* 8 | 9 | The vector library provides an interface for vector operations similar to Haskell's list library. It is available in the module `Feldspar.SimpleVector`: 10 | 11 | \begin{code} 12 | module Tutorial.SimpleVector where 13 | 14 | import qualified Prelude 15 | import Feldspar 16 | import Feldspar.SimpleVector 17 | \end{code} 18 | 19 | Scalar product: 20 | 21 | \begin{code} 22 | scProd :: (Numeric a) => Vector1 a -> Vector1 a -> Data a 23 | scProd a b = sum (zipWith (*) a b) 24 | \end{code} 25 | 26 | Specialize the type: 27 | 28 | \begin{code} 29 | scProdF = scProd :: Vector1 Float -> Vector1 Float -> Data Float 30 | \end{code} 31 | 32 | Testing: 33 | 34 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 35 | *Tutorial.SimpleVector> eval scProdF [1,2,3,4] [5,6,7,8::Float] 36 | 70.0 37 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 38 | 39 | Resulting core expression (with manually inserted white space): 40 | 41 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 42 | *Tutorial.SimpleVector> printExpr scProdF 43 | (\var0 -> (\var1 -> ( 44 | forLoop (min (getLength var0) (getLength var1)) 0.0 (\var2 -> (\var3 -> 45 | (var3 + ((var0 ! var2) * (var1 ! var2))) 46 | )) 47 | ))) 48 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 49 | 50 | Note how `sum` and `zipWith` have been fused into a single `forLoop`. 51 | 52 | -------------------------------------------------------------------------------- /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_1xunsignedS32_1xawl_unsignedS32 e0 = { 0 }; 7 | struct s_2_1xunsignedS32_1xawl_unsignedS32 v6 = { 0 }; 8 | bool v3; 9 | 10 | (e0).member1 = (*v0).length; 11 | ((e0).member2).buffer = initCopyArray(((e0).member2).buffer, ((e0).member2).length, sizeof(uint32_t), (*v0).buffer, (*v0).length); 12 | ((e0).member2).length = (*v0).length; 13 | v3 = ((e0).member1 > 0); 14 | while (v3) 15 | { 16 | uint32_t len1; 17 | struct awl_unsignedS32 e2 = { 0 }; 18 | 19 | (v6).member1 = ((e0).member1 - 1); 20 | len1 = ((e0).member2).length; 21 | ((v6).member2).buffer = initArray(((v6).member2).buffer, ((v6).member2).length, sizeof(uint32_t), len1); 22 | ((v6).member2).length = len1; 23 | #pragma omp parallel for 24 | for (uint32_t v10 = 0; v10 < len1; v10 += 1) 25 | { 26 | ((v6).member2).buffer[v10] = (((e0).member2).buffer[v10] + 5); 27 | } 28 | e2 = (e0).member2; 29 | e0 = v6; 30 | (v6).member2 = e2; 31 | v3 = ((e0).member1 > 0); 32 | } 33 | (*out).buffer = initCopyArray((*out).buffer, (*out).length, sizeof(uint32_t), ((e0).member2).buffer, ((e0).member2).length); 34 | (*out).length = ((e0).member2).length; 35 | freeArray(((e0).member2).buffer); 36 | freeArray(((v6).member2).buffer); 37 | } 38 | -------------------------------------------------------------------------------- /benchs/MatMulC.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "MatMulC.h" 3 | 4 | void MatMulC(int rows, int len, double *a, double *bin, double *c) { 5 | double *b = malloc(len * sizeof(double)); 6 | 7 | // Transpose bin with result in b. 8 | for (int n = 0; n < len; n++) { 9 | b[n] = bin[rows * (n % rows) + (n / rows)]; 10 | } 11 | 12 | for (int i = 0; i < rows; i++) { 13 | for (int j = 0; j < rows; j++) { 14 | double sum = 0.0; 15 | for (int k = 0; k < rows; k++) { 16 | sum += a[i*rows+k] * b[j*rows + k]; 17 | } 18 | c[i*rows + j] = sum; 19 | } 20 | } 21 | 22 | free(b); 23 | } 24 | 25 | /** 26 | * Same code as above with middle loop unrolled once to improve the balance 27 | * between computation and memory reads. 28 | */ 29 | void MatMulCopt(int rows, int len, double *a, double *bin, double *c) { 30 | double *b = malloc(len * sizeof(double)); 31 | 32 | // Transpose bin with result in b. 33 | for(int n = 0; n < len; n++ ) { 34 | b[n] = bin[rows * (n % rows) + (n / rows)]; 35 | } 36 | 37 | for (int i = 0; i < rows; i++) { 38 | for (int j = 0; j < rows; j += 2) { 39 | double sum0 = 0.0; 40 | double sum1 = 0.0; 41 | for (int k = 0; k < rows; k++) { 42 | sum0 += a[i*rows+k] * b[j*rows + k]; 43 | sum1 += a[i*rows+k] * b[(j + 1)*rows + k]; 44 | } 45 | c[i*rows + j] = sum0; 46 | c[i*rows + j+1] = sum1; 47 | } 48 | } 49 | 50 | free(b); 51 | } 52 | -------------------------------------------------------------------------------- /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 | setupPlugins :: IO () 34 | setupPlugins = do 35 | _ <- evaluate c_fft_builder 36 | return () 37 | 38 | setupData :: [Length] -> IO (Ptr (SA (Complex Float)), Ptr (SA (Complex Float))) 39 | setupData lengths = do 40 | d <- mkData testdata lengths 41 | ds <- allocSA $ fromIntegral $ product lengths :: IO (Ptr (SA (Complex Float))) 42 | return (ds, d) 43 | 44 | mkComp :: [Length] -> Benchmark 45 | mkComp ls = env (setupData ls) $ \ ~(o, d) -> 46 | mkBench "c_fft" ls (whnfIO $ c_fft_raw d o) 47 | 48 | main :: IO () 49 | main = defaultMainWith (mkConfig "report_fft.html") 50 | [ env setupPlugins $ \_ -> bgroup "compiled" $ map mkComp sizes 51 | ] 52 | -------------------------------------------------------------------------------- /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 len0; 8 | struct awl_signedS32 v6 = { 0 }; 9 | uint32_t v11; 10 | struct awl_signedS32 v8 = { 0 }; 11 | uint32_t v9; 12 | uint32_t len1; 13 | struct awl_signedS32 e2 = { 0 }; 14 | uint32_t v27; 15 | 16 | len0 = (*v1).length; 17 | (v26).buffer = initArray((v26).buffer, (v26).length, sizeof(int32_t), 0); 18 | (v26).length = 0; 19 | for (uint32_t v5 = 0; v5 < len0; v5 += 1) 20 | { 21 | v11 = (v26).length; 22 | v8 = (*v1).buffer[v5]; 23 | v9 = (v8).length; 24 | len1 = (v11 + v9); 25 | (v6).buffer = initArray((v6).buffer, (v6).length, sizeof(int32_t), len1); 26 | (v6).length = len1; 27 | for (uint32_t v16 = 0; v16 < v11; v16 += 1) 28 | { 29 | (v6).buffer[v16] = (v26).buffer[v16]; 30 | } 31 | for (uint32_t v20 = 0; v20 < v9; v20 += 1) 32 | { 33 | (v6).buffer[(v20 + v11)] = (v8).buffer[v20]; 34 | } 35 | e2 = v26; 36 | v26 = v6; 37 | v6 = e2; 38 | } 39 | v27 = (v26).length; 40 | (*out).buffer = initArray((*out).buffer, (*out).length, sizeof(int32_t), v27); 41 | (*out).length = v27; 42 | for (uint32_t v30 = 0; v30 < v27; v30 += 1) 43 | { 44 | (*out).buffer[v30] = (v26).buffer[v30]; 45 | } 46 | freeArray((v26).buffer); 47 | freeArray((v6).buffer); 48 | freeArray((v8).buffer); 49 | } 50 | -------------------------------------------------------------------------------- /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 v15; 9 | int32_t v6; 10 | int32_t v14; 11 | int32_t v25; 12 | int32_t v13; 13 | int32_t v22; 14 | int32_t v34; 15 | int32_t v51; 16 | int32_t v68; 17 | int32_t v24; 18 | int32_t v36; 19 | int32_t v49; 20 | int32_t v67; 21 | int32_t v37; 22 | int32_t v23; 23 | int32_t v35; 24 | int32_t v48; 25 | int32_t v33; 26 | int32_t v47; 27 | int32_t v66; 28 | int32_t v46; 29 | int32_t v65; 30 | int32_t v50; 31 | int32_t v64; 32 | int32_t v63; 33 | int32_t v61; 34 | 35 | v1 = (v0 * 3); 36 | v7 = (v0 + v1); 37 | v15 = (v1 + v7); 38 | v6 = (v1 + v0); 39 | v14 = (v6 + v1); 40 | v25 = (v14 + v15); 41 | v13 = (v7 + v6); 42 | v22 = (v13 + v14); 43 | v34 = (v22 + v25); 44 | v51 = (v1 + v34); 45 | v68 = (v51 + v1); 46 | v24 = (v15 + v1); 47 | v36 = (v25 + v24); 48 | v49 = (v34 + v36); 49 | v67 = (v1 + v49); 50 | v37 = (v1 + v22); 51 | v23 = (v1 + v13); 52 | v35 = (v23 + v1); 53 | v48 = (v35 + v37); 54 | v33 = (v24 + v23); 55 | v47 = (v33 + v35); 56 | v66 = (v47 + v48); 57 | v46 = (v37 + v1); 58 | v65 = (v46 + v51); 59 | v50 = (v36 + v33); 60 | v64 = (v49 + v50); 61 | v63 = (v48 + v46); 62 | v61 = (v50 + v47); 63 | *out = ((((((((((((((v64 + v61) + v66) + v63) + v65) + v68) + v67) + v64) + v61) + v66) + v63) + v65) + v68) + v67) + (v1 * v49)); 64 | } 65 | -------------------------------------------------------------------------------- /examples/Tutorial/Vector.lhs: -------------------------------------------------------------------------------- 1 | % Vector library 2 | 3 |
4 | 5 | 6 | 7 | *[This document is just a port of [Simple vector library](SimpleVector.html), but it should be extended to cover the multi-dimensional aspects of the vector library.]* 8 | 9 | The vector library provides an interface for multi-dimensional vectors. It is available in the module `Feldspar.Vector`: 10 | 11 | \begin{code} 12 | module Tutorial.Vector where 13 | 14 | import qualified Prelude 15 | import Feldspar 16 | import Feldspar.Vector 17 | \end{code} 18 | 19 | Scalar product: 20 | 21 | \begin{code} 22 | scProd :: (Numeric a) => Pull1 a -> Pull1 a -> Data a 23 | scProd a b = fromZero $ sum (zipWith (*) a b) 24 | \end{code} 25 | 26 | Specialize the type: 27 | 28 | \begin{code} 29 | scProdF = scProd :: Pull1 Float -> Pull1 Float -> Data Float 30 | \end{code} 31 | 32 | Testing: 33 | 34 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 35 | *Tutorial.Vector> eval scProdF [1,2,3,4] [5,6,7,8::Float] 36 | 70.0 37 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 38 | 39 | Resulting core expression (with manually inserted white space): 40 | 41 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 42 | *Tutorial.Vector> printExpr scProdF 43 | (\var0 -> (\var1 -> ( 44 | forLoop (min (getLength var0) (getLength var1)) 0.0 (\var2 -> (\var3 -> 45 | (var3 + ((var0 ! var2) * (var1 ! var2))) 46 | )) 47 | ))) 48 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 49 | 50 | Note how `sum` and `zipWith` have been fused into a single `forLoop`. 51 | 52 | -------------------------------------------------------------------------------- /src/Onnx/Onnx/TypeProto/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -w #-} 3 | module Onnx.TypeProto.Value where 4 | import Prelude ((+), (/), (++), (.)) 5 | import qualified Prelude as Prelude' 6 | import qualified Data.Typeable as Prelude' 7 | import qualified GHC.Generics as Prelude' 8 | import qualified Data.Data as Prelude' 9 | import qualified Text.ProtocolBuffers.Header as P' 10 | import qualified Onnx.TypeProto.Map as Onnx.TypeProto (Map) 11 | import qualified Onnx.TypeProto.Sequence as Onnx.TypeProto (Sequence) 12 | import qualified Onnx.TypeProto.Tensor as Onnx.TypeProto (Tensor) 13 | 14 | data Value = Tensor_type{tensor_type :: (Onnx.TypeProto.Tensor)} 15 | | Sequence_type{sequence_type :: (Onnx.TypeProto.Sequence)} 16 | | Map_type{map_type :: (Onnx.TypeProto.Map)} 17 | deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) 18 | get'tensor_type x 19 | = case x of 20 | Tensor_type tensor_type -> Prelude'.Just tensor_type 21 | _ -> Prelude'.Nothing 22 | get'sequence_type x 23 | = case x of 24 | Sequence_type sequence_type -> Prelude'.Just sequence_type 25 | _ -> Prelude'.Nothing 26 | get'map_type x 27 | = case x of 28 | Map_type map_type -> Prelude'.Just map_type 29 | _ -> Prelude'.Nothing 30 | 31 | instance P'.Default Value where 32 | defaultValue = Tensor_type P'.defaultValue 33 | 34 | instance P'.Mergeable Value -------------------------------------------------------------------------------- /tests/Feldspar/Core/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Feldspar.Core.Test (coreTests) where 4 | 5 | import qualified Prelude 6 | 7 | import Test.Tasty 8 | import Test.Tasty.TH 9 | import Test.Tasty.QuickCheck 10 | 11 | import qualified Data.List as DL 12 | 13 | import Feldspar 14 | import Feldspar.Mutable 15 | 16 | coreTests :: TestTree 17 | coreTests = $(testGroupGenerator) 18 | 19 | deinterleave :: (Type a) => Data [a] -> Data [a] 20 | deinterleave input = 21 | let n = getLength input 22 | cols = 12 23 | rows = 7 24 | steps = n `div` (rows * cols) 25 | in runMutableArray $ do 26 | arr <- newArr_ n 27 | oix <- newRef 0 28 | forM steps $ \s -> 29 | forM rows $ \r -> 30 | forM cols $ \c -> do 31 | ix <- getRef oix 32 | setArr arr ix $ input ! (s*rows*cols + c*rows + r) 33 | modifyRef oix (+1) 34 | forM (n - steps*rows*cols) $ const $ do 35 | ix <- getRef oix 36 | setArr arr ix $ input ! ix 37 | modifyRef oix (+1) 38 | return arr 39 | 40 | withInterleaveable :: (Arbitrary a, Show a, Testable prop) 41 | => ([a] -> prop) -> Property 42 | withInterleaveable prop = 43 | forAll (elements [84..167]) $ \len -> 44 | forAll (vectorOf len arbitrary) prop 45 | 46 | prop_deinterleave_preseves_elements :: Property 47 | prop_deinterleave_preseves_elements = 48 | withInterleaveable $ \xs -> 49 | (DL.sort xs :: [WordN]) ==== DL.sort (eval deinterleave xs) 50 | -------------------------------------------------------------------------------- /src/Feldspar/Core/Middleend/LetSinking.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Feldspar.Core.Middleend.LetSinking ( sinkLets ) where 4 | 5 | import Feldspar.Compiler.Options (Options, Target(..), inTarget) 6 | import Feldspar.Core.UntypedRepresentation 7 | 8 | -- | Sink lets that are stuck between two lambdas. 9 | -- Necessary invariant: lambdas can only appear in special places. 10 | -- 11 | sinkLets :: Options -> UntypedFeld a -> UntypedFeld a 12 | sinkLets opts = collectAtTop opts . go 13 | where go e@(In _ Variable{}) = e 14 | go (In r (Lambda v e)) 15 | | (bs1, In r' (Lambda v' body)) <- collectLetBinders e 16 | , not $ null bs1 17 | = In r (Lambda v $ go (In r' (Lambda v' $ mkLets (bs1, body)))) 18 | go (In r (Lambda v e)) = In r (Lambda v (go e)) 19 | go (In r (LetFun (s, k, e1) e2)) = In r (LetFun (s, k, go e1) (go e2)) 20 | go l@(In _ Literal{}) = l 21 | go (In r (App Let t [e1, In r' (Lambda x e2)])) 22 | = In r (App Let t [go e1, In r' (Lambda x $ go e2)]) 23 | go (In r (App p t es)) = In r (App p t $ map go es) 24 | 25 | -- | Converts let x = .. in .. \x2 -> e to \x2 -> let x = .. in e 26 | -- for the top level expression when BA is a target. 27 | collectAtTop :: Options -> UntypedFeld a -> UntypedFeld a 28 | collectAtTop opts e 29 | | BA `inTarget` opts 30 | , (bs, e1) <- collectLetBinders e -- Get outermost let bindings 31 | , not $ null bs 32 | , (vs, body) <- collectBinders e1 -- Get all lambdas immediately within 33 | , not $ null vs 34 | = mkLam vs $ mkLets (bs, body) 35 | | otherwise = e 36 | -------------------------------------------------------------------------------- /tests/gold/arrayInStruct_wool.c: -------------------------------------------------------------------------------- 1 | #include "arrayInStruct_wool.h" 2 | 3 | 4 | LOOP_BODY_2(wool0, 5 | LARGE_BODY, 6 | uint32_t, 7 | v10, 8 | struct s_2_1xunsignedS32_1xawl_unsignedS32, 9 | e0, 10 | struct s_2_1xunsignedS32_1xawl_unsignedS32, 11 | v6) 12 | { 13 | ((v6).member2).buffer[v10] = (((e0).member2).buffer[v10] + 5); 14 | } 15 | 16 | void arrayInStruct__wool(struct awl_unsignedS32 * v0, struct awl_unsignedS32 * out) 17 | { 18 | struct s_2_1xunsignedS32_1xawl_unsignedS32 e0 = { 0 }; 19 | struct s_2_1xunsignedS32_1xawl_unsignedS32 v6 = { 0 }; 20 | bool v3; 21 | 22 | (e0).member1 = (*v0).length; 23 | ((e0).member2).buffer = initCopyArray(((e0).member2).buffer, ((e0).member2).length, sizeof(uint32_t), (*v0).buffer, (*v0).length); 24 | ((e0).member2).length = (*v0).length; 25 | v3 = ((e0).member1 > 0); 26 | while (v3) 27 | { 28 | uint32_t len1; 29 | struct awl_unsignedS32 e2 = { 0 }; 30 | 31 | (v6).member1 = ((e0).member1 - 1); 32 | len1 = ((e0).member2).length; 33 | ((v6).member2).buffer = initArray(((v6).member2).buffer, ((v6).member2).length, sizeof(uint32_t), len1); 34 | ((v6).member2).length = len1; 35 | FOR(wool0, 0, len1, e0, v6); 36 | e2 = (e0).member2; 37 | e0 = v6; 38 | (v6).member2 = e2; 39 | v3 = ((e0).member1 > 0); 40 | } 41 | (*out).buffer = initCopyArray((*out).buffer, (*out).length, sizeof(uint32_t), ((e0).member2).buffer, ((e0).member2).length); 42 | (*out).length = ((e0).member2).length; 43 | freeArray(((e0).member2).buffer); 44 | freeArray(((v6).member2).buffer); 45 | } 46 | -------------------------------------------------------------------------------- /examples/Tutorial/style.css: -------------------------------------------------------------------------------- 1 | html { 2 | background-color: #ACF; 3 | } 4 | 5 | body { 6 | margin: auto; 7 | background-color: #FFF; 8 | padding-top: 1px; 9 | padding-bottom: 1px; 10 | padding-right: 1em; 11 | padding-left: 1em; 12 | border-right: 3px solid #8AC; 13 | border-left: 3px solid #8AC; 14 | border-bottom: 1px solid #888; 15 | max-width: 60em; 16 | font-family: verdana, sans-serif; 17 | font-size: 85%; 18 | line-height: 140%; 19 | color: #222; 20 | } 21 | 22 | h1, h2, h3, h4, h5 { 23 | font-weight: bold; 24 | color: #3840B0; 25 | } 26 | 27 | h1 a, h2 a, h3 a, h4 a, h5 a { 28 | color: #3840B0; 29 | } 30 | 31 | h1.title { 32 | font-size: 150%; 33 | text-align: center; 34 | margin-top: 1em; 35 | border-bottom: none; 36 | margin-bottom: 2em; 37 | } 38 | 39 | h1 { 40 | font-size: 130%; 41 | margin-top: 2em; 42 | border-bottom: 1px dotted #BBB; 43 | } 44 | 45 | h2 { 46 | margin-top: 2em; 47 | font-size: 110%; 48 | } 49 | 50 | h3 { 51 | font-size: 95%; 52 | margin-left: 2em; 53 | } 54 | 55 | h4 { 56 | font-size: 90%; 57 | font-style: italic; 58 | margin-left: 3em; 59 | } 60 | 61 | h5 { 62 | font-size: 85%; 63 | font-style: italic; 64 | margin-left: 4em; 65 | } 66 | 67 | a { 68 | text-decoration: none; 69 | color: #33F; 70 | } 71 | 72 | a:hover { 73 | background-color: #CCC; 74 | -moz-border-radius: 0.2em; 75 | border-radius: 0.2em; 76 | } 77 | 78 | pre { 79 | border: 1px solid #CCC; 80 | border-left: 3px solid gray; 81 | background-color: #ececec; 82 | color: #1111111; 83 | padding: 0.5em; 84 | white-space: pre-wrap; 85 | } 86 | 87 | code { 88 | font-family: monospace; 89 | font-size: 12px; 90 | } 91 | 92 | -------------------------------------------------------------------------------- /src/clib/include/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 | -------------------------------------------------------------------------------- /tests/Feldspar/Mutable/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Feldspar.Mutable.Test (mutableTests) where 4 | 5 | import Feldspar 6 | import qualified Feldspar.Vector as V 7 | import Feldspar.Mutable 8 | 9 | import Test.Tasty 10 | import Test.Tasty.TH 11 | import Test.Tasty.QuickCheck 12 | 13 | 14 | 15 | hash :: Num a => [a] -> a 16 | hash = Prelude.foldr (\a b -> 3*a-b) 0 17 | 18 | buffProg :: Length -> Data Length -> Data WordN 19 | buffProg bl n = runMutable $ do 20 | buf <- newBuffer (value bl) (0 :: Data WordN) 21 | forM n $ \i -> putBuf buf i 22 | as <- Prelude.sequence [indexBuf buf (value j) | j <- [0 .. bl-1]] 23 | return (hash as) 24 | 25 | prop_buff = 26 | forAll (choose (1,10)) $ \bl -> 27 | forAll (choose (1,100)) $ \n -> 28 | let bl' = fromIntegral bl 29 | in eval (buffProg bl) n Prelude.== (hash $ take bl' $ reverse $ replicate bl' 0 ++ [0..n-1]) 30 | 31 | -- Test that `withBuf` followed by indexing behaves like `indexBuf` 32 | prop_withBuf = 33 | forAll (choose (1,5)) $ \bl -> 34 | forAll (choose (1,15)) $ \n -> 35 | forAll (vector n) $ \as -> 36 | forAll (choose (0,15)) $ \i -> 37 | eval (prog1 as) bl i Prelude.== eval (prog2 as) bl i 38 | where 39 | prog1 :: [Data Word32] -> Data Length -> Data Index -> Data Word32 40 | prog1 as bl i = runMutable $ do 41 | buf <- newBuffer bl 0 42 | sequence_ [putBuf buf a | a <- as] 43 | indexBuf buf i 44 | 45 | prog2 :: [Data Word32] -> Data Length -> Data Index -> Data Word32 46 | prog2 as bl i = runMutable $ do 47 | buf <- newBuffer bl 0 48 | sequence_ [putBuf buf a | a <- as] 49 | withBuf buf $ \b -> return (b V.!! i) 50 | 51 | mutableTests = $(testGroupGenerator) 52 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/Feldspar/Future.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.Future where 30 | 31 | import Feldspar 32 | import Feldspar.Vector as V 33 | 34 | withFuture :: (Syntax a, Syntax b) 35 | => a -> (Future a -> b) -> b 36 | withFuture = share . future 37 | 38 | 39 | -- TODO enable again 40 | -- withFutures :: (Syntax a, Syntax b, Shapely sh) 41 | -- => Pull sh a -> (Manifest sh (Future a) -> b) -> b 42 | -- withFutures coll = share $ store $ V.map future coll 43 | 44 | -------------------------------------------------------------------------------- /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 | setupPlugins :: IO () 39 | setupPlugins = do 40 | putStrLn "Compiling plugins" 41 | _ <- evaluate c_naive_builder 42 | _ <- evaluate c_normal_builder 43 | return () 44 | 45 | setupData :: Length -> IO [Word8] 46 | setupData l = return $ Prelude.take (fromIntegral l) testdata 47 | 48 | setupRaw :: Length -> IO (Ptr Word16, Ptr (SA Word8)) 49 | setupRaw l = do 50 | o <- malloc 51 | pd <- pack (Prelude.take (fromIntegral l) testdata) 52 | return (o, pd) 53 | 54 | main :: IO () 55 | main = 56 | defaultMainWith (mkConfig "report_crc.html") 57 | [ 58 | env (setupData 1024) $ \d -> 59 | bgroup "evaluated" 60 | [ bench "h_naive" $ nf h_naive d 61 | , bench "h_normal" $ nf h_normal d 62 | ] 63 | , env setupPlugins $ \_ -> bgroup "compiled" 64 | [ env (setupData len) $ \d -> bgroup "marshal" 65 | [ bench "c_naive" $ whnfIO $ c_naive_worker d 66 | , bench "c_normal" $ whnfIO $ c_normal_worker d 67 | ] 68 | , env (setupRaw len) $ \ ~(o, pd) -> bgroup "raw" 69 | [ bench "c_naive" $ whnfIO $ c_naive_raw pd o 70 | , bench "c_normal" $ whnfIO $ c_normal_raw pd o 71 | ] 72 | ] 73 | ] 74 | -------------------------------------------------------------------------------- /src/Feldspar/Algorithm/FFT/Push.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Feldspar.Algorithm.FFT.Push 7 | ( fft 8 | , butterfly 9 | , twid 10 | , itwids 11 | , twids 12 | ) where 13 | 14 | 15 | import qualified Prelude as P 16 | import qualified Data.Complex 17 | 18 | import Feldspar 19 | import Feldspar.Mutable 20 | import Feldspar.Vector 21 | 22 | import Feldspar.Algorithm.FFT.Utils 23 | import Feldspar.Algorithm.FFT.Twids 24 | 25 | import Test.QuickCheck 26 | 27 | 28 | 29 | -- | Utilities that should go into Feldspar.Vector 30 | chnk :: forall arr1 a b . (Pushy arr1, VecShape arr1 ~ DIM1, Syntax b) 31 | => Data Length -- ^ Number of chunks 32 | -> Data Length -- ^ Size of the chunks 33 | -> (Pull DIM1 a -> arr1 b) -- ^ Applied to every chunk 34 | -> Pull DIM1 a 35 | -> Push DIM1 b 36 | chnk r c f v = Push loop $ extent v 37 | where loop :: PushK DIM1 b 38 | loop func = parFor r $ \i -> 39 | let (Push k _) = toPush $ f (take c (drop (c*i) v)) 40 | in k (\(Z:.j) a -> func (Z:.(c*i + j)) a) 41 | 42 | unhalve :: (Syntax a) 43 | => Pull DIM1 (a,a) -> Push DIM1 a 44 | unhalve xs = unpairWith id (\(Z:.i) -> Z:.(i + length xs)) xs 45 | 46 | stride :: Data Length -> Data Length 47 | -> (Data Index -> a -> M b) 48 | -> Data Index -> (a,a) -> M b 49 | stride n k f ix (a1,a2) = f (n*ix) a1 >> f (n*ix+k) a2 50 | 51 | 52 | -- | DFT2 for Decimation-In-Frequency 53 | dft2 :: Num a => a -> (a, a) -> (a,a) 54 | dft2 w (x0,x1) = (x0+x1, (x0-x1)*w) 55 | 56 | butterfly :: (Syntax a, Num a) 57 | => (a -> (a,a) -> (a,a)) 58 | -> Pull DIM1 a -> Pull DIM1 a -> Push DIM1 a 59 | butterfly f ws = unhalve . zipWith f ws . uncurry zip . halve 60 | 61 | -- | Cooley-Tukey Radix-2 Decimation In Frequency Fast Fourier Transfrom 62 | fft :: (Syntax a, Num a) 63 | => Pull DIM1 a -> Pull DIM1 a -> Pull DIM1 a 64 | fft ws vs = forLoop (ilog2 len) vs stage 65 | where 66 | len = length vs 67 | stage s = withLen len 68 | $ toPull 69 | . store 70 | . chnk (1 .<<. s) (len .>>. s) (butterfly dft2 (ixmap (.<<. s) ws)) 71 | 72 | -------------------------------------------------------------------------------- /tests/gold/deepArrayCopy.h: -------------------------------------------------------------------------------- 1 | #ifndef TMP2_DEEPARRAYCOPY_H 2 | #define TMP2_DEEPARRAYCOPY_H 3 | 4 | #include "feldspar_c99.h" 5 | 6 | struct awl_unsignedS32 7 | { 8 | global uint32_t * buffer; 9 | uint32_t length; 10 | }; 11 | 12 | struct awl_awl_unsignedS32 13 | { 14 | global struct awl_unsignedS32 * buffer; 15 | uint32_t length; 16 | }; 17 | 18 | struct awl_awl_awl_unsignedS32 19 | { 20 | global struct awl_awl_unsignedS32 * buffer; 21 | uint32_t length; 22 | }; 23 | 24 | struct s_2_2xawl_awl_awl_unsignedS32 25 | { 26 | struct awl_awl_awl_unsignedS32 member1; 27 | struct awl_awl_awl_unsignedS32 member2; 28 | }; 29 | 30 | global struct awl_awl_unsignedS32 * copyArrayPos_awl_awl_unsignedS32(global struct awl_awl_unsignedS32 * dst, int32_t dstLen, global struct awl_awl_unsignedS32 * src, int32_t srcLen, int32_t pos); 31 | 32 | global struct awl_awl_unsignedS32 * copyArray_awl_awl_unsignedS32(global struct awl_awl_unsignedS32 * dst, int32_t dstLen, global struct awl_awl_unsignedS32 * src, int32_t srcLen); 33 | 34 | global struct awl_awl_unsignedS32 * initCopyArray_awl_awl_unsignedS32(global struct awl_awl_unsignedS32 * dst, int32_t dstLen, global struct awl_awl_unsignedS32 * src, int32_t srcLen); 35 | 36 | global struct awl_unsignedS32 * copyArrayPos_awl_unsignedS32(global struct awl_unsignedS32 * dst, int32_t dstLen, global struct awl_unsignedS32 * src, int32_t srcLen, int32_t pos); 37 | 38 | global struct awl_unsignedS32 * copyArray_awl_unsignedS32(global struct awl_unsignedS32 * dst, int32_t dstLen, global struct awl_unsignedS32 * src, int32_t srcLen); 39 | 40 | global struct awl_unsignedS32 * initCopyArray_awl_unsignedS32(global struct awl_unsignedS32 * dst, int32_t dstLen, global struct awl_unsignedS32 * src, int32_t srcLen); 41 | 42 | global struct awl_awl_unsignedS32 * initArray_awl_awl_unsignedS32(global struct awl_awl_unsignedS32 * dst, uint32_t oldLen, uint32_t newLen); 43 | 44 | void freeArray_awl_awl_unsignedS32(global struct awl_awl_unsignedS32 * src, int32_t srcLen); 45 | 46 | global struct awl_unsignedS32 * initArray_awl_unsignedS32(global struct awl_unsignedS32 * dst, uint32_t oldLen, uint32_t newLen); 47 | 48 | void freeArray_awl_unsignedS32(global struct awl_unsignedS32 * src, int32_t srcLen); 49 | 50 | void deepArrayCopy(struct awl_awl_awl_unsignedS32 * v0, struct s_2_2xawl_awl_awl_unsignedS32 * out); 51 | 52 | #endif // TMP2_DEEPARRAYCOPY_H 53 | -------------------------------------------------------------------------------- /examples/Tutorial/Basic.lhs: -------------------------------------------------------------------------------- 1 | % Basic usage 2 | 3 |
4 | 5 | 6 | 7 | *[This document needs to be extended.]* 8 | 9 | Getting started 10 | =============== 11 | 12 | Feldspar is implemented as an embedded language in Haskell. To use Feldspar, simply import the `Feldspar` module in a Haskell source file: 13 | 14 | \begin{code} 15 | module Tutorial.Basic where 16 | 17 | import Feldspar 18 | \end{code} 19 | 20 | Since Feldspar redefines several standard Haskell identifiers, it is strongly recommended to import the standard `Prelude` qualified: 21 | 22 | \begin{code} 23 | import qualified Prelude 24 | \end{code} 25 | 26 | (Certain useful `Prelude` identifiers that are not used by Feldspar are reexported by the `Feldspar` module.) 27 | 28 | In order to try out the examples in this file, we just load the file in GHCi: 29 | 30 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 31 | terminal> ghci Basic.lhs 32 | GHCi, version 7.6.1: http://www.haskell.org/ghc/ :? for help 33 | Loading package ghc-prim ... linking ... done. 34 | Loading package integer-gmp ... linking ... done. 35 | Loading package base ... linking ... done. 36 | [1 of 1] Compiling Tutorial.Basic ( Basic.lhs, interpreted ) 37 | Ok, modules loaded: Tutorial.Basic. 38 | *Tutorial.Basic> 39 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 40 | 41 | We are now ready to define a simple program. The following function computes the length of the hypotenuse of a triangle, given the lengths of the two catheti: 42 | 43 | \begin{code} 44 | hypotenuse :: Data Float -> Data Float -> Data Float 45 | hypotenuse c1 c2 = sqrt (square c1 + square c2) 46 | where 47 | square x = x*x 48 | \end{code} 49 | 50 | Note that this code is *identical* to the corresponding code in ordinary Haskell, except for the `Data` constructor in the type. 51 | 52 | What makes `hypotenuse` different from the corresponding Haskell function can be seen when we try to evaluate it: 53 | 54 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 55 | *Tutorial.Basic> hypotenuse 3 4 56 | (sqrt ((3.0 * 3.0) + (4.0 * 4.0))) 57 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 58 | 59 | Hm... instead of computing a result, `hypotenuse` returned an unevaluated expression. In order to evaluate this expression, we have to use the function `eval`: 60 | 61 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 62 | *Tutorial.Basic> eval hypotenuse 3 4 63 | 5.0 64 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 65 | 66 | -------------------------------------------------------------------------------- /src/clib/include/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 | -------------------------------------------------------------------------------- /src/Feldspar/Core/Collection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | -- 6 | -- Copyright (c) 2009-2011, ERICSSON AB 7 | -- All rights reserved. 8 | -- 9 | -- Redistribution and use in source and binary forms, with or without 10 | -- modification, are permitted provided that the following conditions are met: 11 | -- 12 | -- * Redistributions of source code must retain the above copyright notice, 13 | -- this list of conditions and the following disclaimer. 14 | -- * Redistributions in binary form must reproduce the above copyright 15 | -- notice, this list of conditions and the following disclaimer in the 16 | -- documentation and/or other materials provided with the distribution. 17 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 18 | -- may be used to endorse or promote products derived from this software 19 | -- without specific prior written permission. 20 | -- 21 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 24 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 25 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 27 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 29 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -- 32 | 33 | -- | General interfaces to collections of data 34 | 35 | module Feldspar.Core.Collection where 36 | 37 | -- | Collection element type 38 | type family Elem a 39 | 40 | -- | Collection index type 41 | type family CollIndex a 42 | 43 | -- | Collection size type 44 | type family CollSize a 45 | 46 | -- | Data structures that support indexing 47 | class Indexed a 48 | where 49 | (!) :: a -> CollIndex a -> Elem a 50 | 51 | infixl 9 ! 52 | 53 | -- | Sized data structures 54 | class Sized a 55 | where 56 | collSize :: a -> CollSize a 57 | setCollSize :: CollSize a -> a -> a 58 | 59 | -- | Mapping over collections 60 | class CollMap a b 61 | where 62 | collMap :: (Elem a -> Elem b) -> a -> b 63 | -------------------------------------------------------------------------------- /src/Feldspar/Core/AdjustBindings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# OPTIONS_GHC -Wall #-} 8 | 9 | -- 10 | -- Copyright (c) 2019, ERICSSON AB 11 | -- All rights reserved. 12 | -- 13 | -- Redistribution and use in source and binary forms, with or without 14 | -- modification, are permitted provided that the following conditions are met: 15 | -- 16 | -- * Redistributions of source code must retain the above copyright notice, 17 | -- this list of conditions and the following disclaimer. 18 | -- * Redistributions in binary form must reproduce the above copyright 19 | -- notice, this list of conditions and the following disclaimer in the 20 | -- documentation and/or other materials provided with the distribution. 21 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 22 | -- may be used to endorse or promote products derived from this software 23 | -- without specific prior written permission. 24 | -- 25 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 26 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 27 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 28 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 29 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 30 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 31 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 32 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 33 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 34 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 35 | -- 36 | 37 | module Feldspar.Core.AdjustBindings (adjustBindings) where 38 | 39 | import Feldspar.Core.Representation 40 | 41 | adjustBindings :: AExpr a -> AExpr a 42 | adjustBindings = adjA 43 | 44 | adjA :: AExpr a -> AExpr a 45 | adjA (i :& e) = i :& adj e 46 | 47 | adj :: Expr a -> Expr a 48 | adj (Sym l@Lambda{} :@ e) = Sym l :@ adjB [] e 49 | adj (f :@ e) = adj f :@ adjA e 50 | adj e = e 51 | 52 | adjB :: [CBind] -> AExpr a -> AExpr a 53 | adjB bs (_ :& Sym Let :@ a :@ (_ :& Sym (Lambda v) :@ e)) = adjB (CBind v (adjA a) : bs) e 54 | adjB bs (i :& Sym l@Lambda{} :@ e) = i :& Sym l :@ adjB bs e 55 | adjB bs e = mkLets (reverse bs, adjA e) 56 | -------------------------------------------------------------------------------- /tests/gold/scanlPush.c: -------------------------------------------------------------------------------- 1 | #include "scanlPush.h" 2 | 3 | 4 | global struct awl_unsignedS32 * initArray_awl_unsignedS32(global 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(global 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 e0 = { 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 | (e0).buffer = initArray((e0).buffer, (e0).length, sizeof(uint32_t), v24); 68 | (e0).length = v24; 69 | for (uint32_t v26 = 0; v26 < v24; v26 += 1) 70 | { 71 | (e0).buffer[v26] = (v23).buffer[v26]; 72 | } 73 | ((*out).buffer[v13]).buffer = initCopyArray(((*out).buffer[v13]).buffer, ((*out).buffer[v13]).length, sizeof(uint32_t), (e0).buffer, (e0).length); 74 | ((*out).buffer[v13]).length = (e0).length; 75 | } 76 | freeArray((v12).buffer); 77 | freeArray((v23).buffer); 78 | freeArray((e0).buffer); 79 | } 80 | -------------------------------------------------------------------------------- /src/Onnx/Onnx/TensorProto/DataLocation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -w #-} 3 | module Onnx.TensorProto.DataLocation (DataLocation(..)) where 4 | import Prelude ((+), (/), (.)) 5 | import qualified Prelude as Prelude' 6 | import qualified Data.Typeable as Prelude' 7 | import qualified GHC.Generics as Prelude' 8 | import qualified Data.Data as Prelude' 9 | import qualified Text.ProtocolBuffers.Header as P' 10 | 11 | data DataLocation = DEFAULT 12 | | EXTERNAL 13 | deriving (Prelude'.Read, Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, 14 | Prelude'.Generic) 15 | 16 | instance P'.Mergeable DataLocation 17 | 18 | instance Prelude'.Bounded DataLocation where 19 | minBound = DEFAULT 20 | maxBound = EXTERNAL 21 | 22 | instance P'.Default DataLocation where 23 | defaultValue = DEFAULT 24 | 25 | toMaybe'Enum :: Prelude'.Int -> P'.Maybe DataLocation 26 | toMaybe'Enum 0 = Prelude'.Just DEFAULT 27 | toMaybe'Enum 1 = Prelude'.Just EXTERNAL 28 | toMaybe'Enum _ = Prelude'.Nothing 29 | 30 | instance Prelude'.Enum DataLocation where 31 | fromEnum DEFAULT = 0 32 | fromEnum EXTERNAL = 1 33 | toEnum 34 | = P'.fromMaybe (Prelude'.error "hprotoc generated code: toEnum failure for type Onnx.TensorProto.DataLocation") . toMaybe'Enum 35 | succ DEFAULT = EXTERNAL 36 | succ _ = Prelude'.error "hprotoc generated code: succ failure for type Onnx.TensorProto.DataLocation" 37 | pred EXTERNAL = DEFAULT 38 | pred _ = Prelude'.error "hprotoc generated code: pred failure for type Onnx.TensorProto.DataLocation" 39 | 40 | instance P'.Wire DataLocation where 41 | wireSize ft' enum = P'.wireSize ft' (Prelude'.fromEnum enum) 42 | wirePut ft' enum = P'.wirePut ft' (Prelude'.fromEnum enum) 43 | wireGet 14 = P'.wireGetEnum toMaybe'Enum 44 | wireGet ft' = P'.wireGetErr ft' 45 | wireGetPacked 14 = P'.wireGetPackedEnum toMaybe'Enum 46 | wireGetPacked ft' = P'.wireGetErr ft' 47 | 48 | instance P'.GPB DataLocation 49 | 50 | instance P'.MessageAPI msg' (msg' -> DataLocation) DataLocation where 51 | getVal m' f' = f' m' 52 | 53 | instance P'.ReflectEnum DataLocation where 54 | reflectEnum = [(0, "DEFAULT", DEFAULT), (1, "EXTERNAL", EXTERNAL)] 55 | reflectEnumInfo _ 56 | = P'.EnumInfo (P'.makePNF (P'.pack ".onnx.TensorProto.DataLocation") [] ["Onnx", "TensorProto"] "DataLocation") 57 | ["Onnx", "TensorProto", "DataLocation.hs"] 58 | [(0, "DEFAULT"), (1, "EXTERNAL")] 59 | Prelude'.False 60 | 61 | instance P'.TextType DataLocation where 62 | tellT = P'.tellShow 63 | getT = P'.getRead -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-18.13 21 | 22 | ghc-options: 23 | # Somewhere deep inside there is a call to ghc --make, pass -j3 to 24 | # speed up builds. Sys time goes up with -j4 on GHC 8.4 so there 25 | # is a slowdown for that. 26 | "$locals": -j3 27 | 28 | # User packages to be built. 29 | # Various formats can be used as shown in the example below. 30 | # 31 | # packages: 32 | # - some-directory 33 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 34 | # subdirs: 35 | # - auto-update 36 | # - wai 37 | packages: 38 | - . 39 | 40 | # Dependency packages to be pulled from upstream that are not in the resolver. 41 | # These entries can reference officially published versions as well as 42 | # forks / in-progress versions pinned to a git hash. For example: 43 | # 44 | # extra-deps: 45 | # - acme-missiles-0.3 46 | # - git: https://github.com/commercialhaskell/stack.git 47 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 48 | # 49 | extra-deps: 50 | [patch-combinators-0.2.2 51 | ,prelude-edsl-0.3.1 52 | ,data-hash-0.2.0.1 53 | ,tree-view-0.5.1 54 | ,plugins-multistage-0.6.3 55 | ,protocol-buffers-2.4.17 56 | ] 57 | 58 | # Override default flag values for local packages and extra-deps 59 | # flags: {} 60 | 61 | # Extra package databases containing global packages 62 | # extra-package-dbs: [] 63 | 64 | # Control whether we use the GHC we find on the path 65 | # system-ghc: true 66 | # 67 | # Require a specific version of stack, using version ranges 68 | # require-stack-version: -any # Default 69 | # require-stack-version: ">=2.1" 70 | # 71 | # Override the architecture used by stack, especially useful on Windows 72 | # arch: i386 73 | # arch: x86_64 74 | # 75 | # Extra directories used by stack for building 76 | # extra-include-dirs: [/path/to/dir] 77 | # extra-lib-dirs: [/path/to/dir] 78 | # 79 | # Allow a newer minor version of GHC than the snapshot specifies 80 | # compiler-check: newer-minor 81 | -------------------------------------------------------------------------------- /stack-8.8.4.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-16.12 21 | 22 | ghc-options: 23 | # Somewhere deep inside there is a call to ghc --make, pass -j3 to 24 | # speed up builds. Sys time goes up with -j4 on GHC 8.4 so there 25 | # is a slowdown for that. 26 | "$locals": -j3 27 | 28 | # User packages to be built. 29 | # Various formats can be used as shown in the example below. 30 | # 31 | # packages: 32 | # - some-directory 33 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 34 | # subdirs: 35 | # - auto-update 36 | # - wai 37 | packages: 38 | - . 39 | 40 | # Dependency packages to be pulled from upstream that are not in the resolver. 41 | # These entries can reference officially published versions as well as 42 | # forks / in-progress versions pinned to a git hash. For example: 43 | # 44 | # extra-deps: 45 | # - acme-missiles-0.3 46 | # - git: https://github.com/commercialhaskell/stack.git 47 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 48 | # 49 | extra-deps: 50 | [patch-combinators-0.2.2 51 | ,prelude-edsl-0.3.1 52 | ,data-hash-0.2.0.1 53 | ,tree-view-0.5 54 | ,plugins-multistage-0.6.3 55 | ,protocol-buffers-2.4.13 56 | ] 57 | 58 | # Override default flag values for local packages and extra-deps 59 | # flags: {} 60 | 61 | # Extra package databases containing global packages 62 | # extra-package-dbs: [] 63 | 64 | # Control whether we use the GHC we find on the path 65 | # system-ghc: true 66 | # 67 | # Require a specific version of stack, using version ranges 68 | # require-stack-version: -any # Default 69 | # require-stack-version: ">=2.1" 70 | # 71 | # Override the architecture used by stack, especially useful on Windows 72 | # arch: i386 73 | # arch: x86_64 74 | # 75 | # Extra directories used by stack for building 76 | # extra-include-dirs: [/path/to/dir] 77 | # extra-lib-dirs: [/path/to/dir] 78 | # 79 | # Allow a newer minor version of GHC than the snapshot specifies 80 | # compiler-check: newer-minor 81 | -------------------------------------------------------------------------------- /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 v10; 7 | uint32_t v12; 8 | struct awl_signedS32 e0 = { 0 }; 9 | 10 | v10 = (v8 << 10); 11 | v12 = min(1024, (v3 - v10)); 12 | (e0).buffer = initArray((e0).buffer, (e0).length, sizeof(int32_t), v12); 13 | (e0).length = v12; 14 | for (uint32_t v15 = 0; v15 < v12; v15 += 1) 15 | { 16 | (e0).buffer[v15] = ((*v1).buffer[(v15 + v10)] + 1); 17 | } 18 | ivar_put_array_shallow((v24).buffer[v8], &e0, 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 | struct awl_signedS32 v28 = { 0 }; 33 | uint32_t v34; 34 | struct awl_signedS32 v31 = { 0 }; 35 | struct ivar e1; 36 | uint32_t v32; 37 | uint32_t len2; 38 | struct awl_signedS32 e3 = { 0 }; 39 | uint32_t v50; 40 | 41 | taskpool_init(4, 4, 4); 42 | v3 = (*v1).length; 43 | v4 = (v3 >> 10); 44 | (v24).buffer = initArray((v24).buffer, (v24).length, sizeof(struct ivar), v4); 45 | (v24).length = v4; 46 | for (uint32_t v8 = 0; v8 < v4; v8 += 1) 47 | { 48 | ivar_init(&(v24).buffer[v8]); 49 | spawn4(task0, uint32_t, v8, uint32_t, v3, struct awl_signedS32 *, v1, struct awl_i_awl_signedS32, v24); 50 | } 51 | (v49).buffer = initArray((v49).buffer, (v49).length, sizeof(int32_t), 0); 52 | (v49).length = 0; 53 | for (uint32_t v27 = 0; v27 < v4; v27 += 1) 54 | { 55 | v34 = (v49).length; 56 | e1 = (v24).buffer[v27]; 57 | ivar_get_array_shallow_nontask(&v31, e1, sizeof(int32_t)); 58 | v32 = (v31).length; 59 | len2 = (v34 + v32); 60 | (v28).buffer = initArray((v28).buffer, (v28).length, sizeof(int32_t), len2); 61 | (v28).length = len2; 62 | for (uint32_t v39 = 0; v39 < v34; v39 += 1) 63 | { 64 | (v28).buffer[v39] = (v49).buffer[v39]; 65 | } 66 | for (uint32_t v43 = 0; v43 < v32; v43 += 1) 67 | { 68 | (v28).buffer[(v43 + v34)] = (v31).buffer[v43]; 69 | } 70 | e3 = v49; 71 | v49 = v28; 72 | v28 = e3; 73 | } 74 | v50 = (v49).length; 75 | (*out).buffer = initArray((*out).buffer, (*out).length, sizeof(int32_t), v50); 76 | (*out).length = v50; 77 | for (uint32_t v53 = 0; v53 < v50; v53 += 1) 78 | { 79 | (*out).buffer[v53] = (v49).buffer[v53]; 80 | } 81 | taskpool_shutdown(); 82 | freeArray((v24).buffer); 83 | freeArray((v49).buffer); 84 | freeArray((v28).buffer); 85 | freeArray((v31).buffer); 86 | ivar_destroy(&e1); 87 | } 88 | -------------------------------------------------------------------------------- /src/Feldspar/SimpleVector.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 | -- | A module for /virtual vectors/. Many of the functions defined here are 30 | -- imitations of Haskell's list operations, and to a first approximation they 31 | -- behave accordingly. 32 | -- 33 | -- A virtual vector is normally guaranteed not to be present in the generated 34 | -- code. The only exceptions are: 35 | -- 36 | -- * when it is explicitly forced using the functions 'force' or 'desugar' 37 | -- 38 | -- * when it is the input or output of a program 39 | -- 40 | -- * when it is accessed by a function outside the "Feldspar.SimpleVector" API, for 41 | -- example, 'condition' or 'forLoop' 42 | -- 43 | -- Note also that most operations only introduce a small constant overhead on 44 | -- the vector. The exceptions are 45 | -- 46 | -- * 'fold' 47 | -- 48 | -- * 'fold1' 49 | -- 50 | -- * Functions that introduce storage (see above) 51 | -- 52 | -- * \"Folding\" functions: 'sum', 'maximum', etc. 53 | -- 54 | -- These functions introduce overhead that is linear in the length of the 55 | -- vector. 56 | 57 | module Feldspar.SimpleVector 58 | ( module Feldspar.SimpleVector.Internal 59 | ) where 60 | 61 | 62 | 63 | import Feldspar() -- For Haddock 64 | import Feldspar.SimpleVector.Internal hiding (freezeVector, scan) 65 | 66 | -------------------------------------------------------------------------------- /tests/Feldspar/Stream/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Feldspar.Stream.Test (streamTests, vector1D) where 4 | 5 | import qualified Prelude as P 6 | import qualified Data.List as List 7 | 8 | import Feldspar 9 | import Feldspar.Stream 10 | import Feldspar.Vector 11 | 12 | import Test.Tasty 13 | import Test.Tasty.TH 14 | import Test.Tasty.QuickCheck 15 | 16 | import Test.QuickCheck 17 | 18 | -- | Helper to generate one-dimensional vectors. Placed in the wrong module. 19 | vector1D :: Length -> Gen a -> Gen [a] 20 | vector1D l = vectorOf (P.fromIntegral l) 21 | 22 | scProd :: Num a => [a] -> [a] -> a 23 | scProd a b = P.sum $ P.zipWith (*) a b 24 | 25 | 26 | 27 | -- | Reference implementation of Fibonacci 28 | fibRef :: Num a => Int -> a 29 | fibRef i = fibs P.!! i 30 | where 31 | fibs = 0 : 1 : P.zipWith (+) fibs (P.tail fibs) 32 | 33 | fibFeld :: Numeric a => Int -> a 34 | fibFeld = eval (recurrenceO (thawPull1 $ fromList [0,1]) (\fib -> fib!!0 + fib!!1) !) . P.toEnum 35 | 36 | prop_fib = forAll (choose (0,20)) $ \i -> fibRef (i+2) P.== (fibFeld i :: WordN) 37 | 38 | 39 | 40 | -- | Reference implementation of FIR filter 41 | firRef :: Num a => [a] -> [a] -> [a] 42 | firRef coeffs inp = [scProd coeffs is | is <- P.map P.reverse $ P.tail $ List.inits inp] 43 | 44 | firFeld :: [Int32] -> [Int32] -> [Int32] 45 | firFeld coeffs = eval (freezePull1 . streamAsVector (fir (toPull $ value1 coeffs)) . thawPull1) 46 | 47 | prop_fir = 48 | forAll (choose (1, 10)) $ \l1 -> 49 | forAll (choose (1, 10)) $ \l2 -> 50 | forAll (vector1D l1 arbitrary) $ \coeffs -> 51 | forAll (vector1D l2 arbitrary) $ \xs -> 52 | firRef coeffs xs ==== firFeld coeffs xs 53 | 54 | 55 | 56 | -- | Reference implementation of IIR filter 57 | iirRef :: Num a => [a] -> [a] -> [a] -> [a] 58 | iirRef as bs inp = outp 59 | where 60 | inps = P.map P.reverse $ P.tail $ List.inits inp 61 | outps = P.map P.reverse $ P.tail $ List.inits (0:outp) 62 | 63 | outp = [scProd bs is - scProd as os | (is,os) <- P.zip inps outps] 64 | 65 | -- | Same as 'iir' in "Feldspar.Stream", but without the fractional constraint, to avoid rounding 66 | -- errors when testing 67 | iirInt :: Numeric a => Pull1 a -> Pull1 a -> Stream (Data a) -> Stream (Data a) 68 | iirInt a b inp = 69 | recurrenceIO (replicate1 (length b) 0) inp 70 | (replicate1 (length a) 0) 71 | (\i o -> scalarProd b i - scalarProd a o) 72 | 73 | iirFeld :: [Int32] -> [Int32] -> [Int32] -> [Int32] 74 | iirFeld as bs = eval (freezePull1 . iirVec . thawPull1) 75 | where 76 | iirVec = streamAsVector (iirInt (toPull $ value1 as) (toPull $ value1 bs)) 77 | 78 | prop_iir = 79 | forAll (choose (1, 10)) $ \l1 -> 80 | forAll (choose (1, 10)) $ \l2 -> 81 | forAll (vector1D l1 arbitrary) $ \as -> 82 | forAll (vector1D l2 arbitrary) $ \bs -> 83 | iirRef as bs ==== iirFeld as bs 84 | 85 | 86 | streamTests = $(testGroupGenerator) 87 | -------------------------------------------------------------------------------- /tests/gold/metrics.c: -------------------------------------------------------------------------------- 1 | #include "metrics.h" 2 | 3 | 4 | global struct awl_signedS32 * initArray_awl_signedS32(global 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(global 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_2xunsignedS32 * v3, struct awl_awl_signedS32 * out) 40 | { 41 | uint32_t v10; 42 | uint32_t v9; 43 | struct awl_awl_signedS32 v33 = { 0 }; 44 | struct awl_s_2_2xunsignedS32 v16 = { 0 }; 45 | uint32_t v18; 46 | struct awl_signedS32 st0 = { 0 }; 47 | struct awl_signedS32 * v14 = NULL; 48 | struct awl_signedS32 v36 = { 0 }; 49 | uint32_t v37; 50 | 51 | v10 = (*v3).length; 52 | v9 = (*v1).length; 53 | (st0).buffer = initArray((st0).buffer, (st0).length, sizeof(int32_t), 8); 54 | (st0).length = 8; 55 | for (uint32_t v6 = 0; v6 < 8; v6 += 1) 56 | { 57 | (st0).buffer[v6] = -32678; 58 | } 59 | v14 = &st0; 60 | (v33).buffer = initArray_awl_signedS32((v33).buffer, (v33).length, v10); 61 | (v33).length = v10; 62 | for (uint32_t v13 = 0; v13 < v10; v13 += 1) 63 | { 64 | v16 = (*v3).buffer[v13]; 65 | v18 = min((v16).length, v9); 66 | ((v33).buffer[v13]).buffer = initArray(((v33).buffer[v13]).buffer, ((v33).buffer[v13]).length, sizeof(int32_t), v18); 67 | ((v33).buffer[v13]).length = v18; 68 | for (uint32_t v24 = 0; v24 < v18; v24 += 1) 69 | { 70 | ((v33).buffer[v13]).buffer[v24] = (*v14).buffer[((v16).buffer[v24]).member1]; 71 | } 72 | v14 = &(v33).buffer[v13]; 73 | } 74 | (*out).buffer = initArray_awl_signedS32((*out).buffer, (*out).length, v10); 75 | (*out).length = v10; 76 | for (uint32_t v34 = 0; v34 < v10; v34 += 1) 77 | { 78 | v36 = (v33).buffer[v34]; 79 | v37 = (v36).length; 80 | ((*out).buffer[v34]).buffer = initArray(((*out).buffer[v34]).buffer, ((*out).buffer[v34]).length, sizeof(int32_t), v37); 81 | ((*out).buffer[v34]).length = v37; 82 | for (uint32_t v40 = 0; v40 < v37; v40 += 1) 83 | { 84 | ((*out).buffer[v34]).buffer[v40] = (v36).buffer[v40]; 85 | } 86 | } 87 | freeArray_awl_signedS32((v33).buffer, (v33).length); 88 | freeArray((v16).buffer); 89 | freeArray((st0).buffer); 90 | freeArray((v36).buffer); 91 | } 92 | -------------------------------------------------------------------------------- /src/Feldspar.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 | {-# OPTIONS_GHC -Wall #-} 29 | -- The qualified prelude is required for GHCI but not the module itself so 30 | -- disable unused import warnings. 31 | {-# OPTIONS_GHC -Wno-unused-imports #-} 32 | 33 | -- | Interface to the essential parts of the Feldspar language. High-level 34 | -- libraries have to be imported separately. 35 | 36 | module Feldspar 37 | ( module Prelude.EDSL 38 | -- * Reexported standard modules 39 | , Complex (..) 40 | , module Data.Int 41 | , module Data.Word 42 | 43 | -- * Feldspar types 44 | , Range (..) 45 | , module Feldspar.Core.Types 46 | 47 | -- * Frontend 48 | , module Feldspar.Core.Frontend 49 | , module Feldspar.Core.NestedTuples 50 | , module Feldspar.Core.Collection 51 | ) where 52 | 53 | import qualified Prelude 54 | -- In order to be able to use the Feldspar module in GHCi without getting name 55 | -- clashes. 56 | 57 | import Prelude.EDSL 58 | 59 | import Data.Complex 60 | import Data.Int hiding (Int) 61 | import Data.Word 62 | 63 | import Feldspar.Range 64 | -- The names for selectors collide with the ones for ordinary tuples. 65 | import Feldspar.Core.NestedTuples hiding (sel1, sel2, sel3, sel4, sel5, sel6, 66 | sel7, sel8, sel9, sel10, sel11, sel12, 67 | sel13, sel14, sel15) 68 | import Feldspar.Core.Types 69 | import Feldspar.Core.Frontend 70 | import Feldspar.Core.Collection 71 | -------------------------------------------------------------------------------- /src/Feldspar/Core/Eval.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (c) 2019, 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 | {-# LANGUAGE GADTs #-} 29 | {-# LANGUAGE TypeOperators #-} 30 | {-# LANGUAGE ScopedTypeVariables #-} 31 | {-# OPTIONS_GHC -Wall #-} 32 | 33 | -- | Evaluator of typed expressions 34 | module Feldspar.Core.Eval (eval) where 35 | 36 | import Feldspar.Core.Representation 37 | import Feldspar.Core.Semantics 38 | 39 | import qualified Data.Map.Strict as M 40 | import Data.Typeable 41 | 42 | data Closure where 43 | Clo :: Typeable a => a -> Closure 44 | 45 | -- | Evaluate an expression 46 | eval :: AExpr a -> a 47 | eval = evalA M.empty 48 | 49 | evalA :: CloEnv -> AExpr a -> a 50 | evalA bm (_ :& e) = evalE bm e 51 | 52 | evalE :: Typeable a => CloEnv -> Expr a -> a 53 | evalE bm (Sym (Variable v)) = lookupCE "Eval.evalE" bm v 54 | evalE bm (Sym (Lambda (Var n _)) :@ e) = \x -> evalA (M.insert n (Clo x) bm) e 55 | evalE _ (Sym op) = semSem $ semantics op 56 | evalE bm (f :@ e) = evalE bm f $ evalA bm e 57 | 58 | type CloEnv = M.Map VarId Closure 59 | 60 | lookupCE :: Typeable a => String -> CloEnv -> Var a -> a 61 | lookupCE msg bm (v@(Var n _) :: Var a) 62 | = case M.lookup n bm of 63 | Nothing -> error $ msg ++ ": lookupCE does not find variable " ++ show v 64 | Just (Clo (x :: b)) 65 | -> case eqT :: Maybe (a :~: b) of 66 | Nothing -> error $ msg ++ ": lookupCE finds conflicing types for " ++ show v 67 | Just Refl -> x 68 | -------------------------------------------------------------------------------- /src/Feldspar/Par.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 FlexibleContexts #-} 30 | 31 | module Feldspar.Par 32 | ( P 33 | , IVar 34 | , runPar 35 | , new 36 | , get 37 | , put 38 | , fork 39 | , yield 40 | , spawn 41 | , pval 42 | , parMap 43 | , parMapM 44 | , divConq 45 | ) 46 | where 47 | import Feldspar.Core.Frontend (Syntax) 48 | import Feldspar.Core.Language hiding (pval) 49 | import Feldspar.Core.Representation 50 | 51 | runPar :: Syntax a => P a -> a 52 | runPar = sugarSym1 ParRun 53 | 54 | new :: Syntax a => P (IVar a) 55 | new = sugarSym0 ParNew 56 | 57 | get :: Syntax a => IVar a -> P a 58 | get = sugarSym1 ParGet 59 | 60 | put :: Syntax a => IVar a -> a -> P () 61 | put = sugarSym2 ParPut 62 | 63 | fork :: P () -> P () 64 | fork = sugarSym1 ParFork 65 | 66 | yield :: P () 67 | yield = sugarSym0 ParYield 68 | 69 | spawn :: Syntax a => P a -> P (IVar a) 70 | spawn p = do 71 | r <- new 72 | fork (p >>= put r) 73 | return r 74 | 75 | pval :: Syntax a => a -> P (IVar a) 76 | pval a = spawn (return a) 77 | 78 | parMap :: Syntax b => (a -> b) -> [a] -> P [b] 79 | parMap f xs = mapM (pval . f) xs >>= mapM get 80 | 81 | parMapM :: Syntax b => (a -> P b) -> [a] -> P [b] 82 | parMapM f xs = mapM (spawn . f) xs >>= mapM get 83 | 84 | divConq :: Syntax b => (a -> Bool) -> (a -> [a]) -> ([b] -> b) -> (a -> b) -> a -> P b 85 | divConq indiv split join f = go 86 | where 87 | go prob | indiv prob = return (f prob) 88 | | otherwise = do 89 | sols <- parMapM go (split prob) 90 | return (join sols) 91 | -------------------------------------------------------------------------------- /src/Feldspar/Core/Middleend/UniqueVars.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | -- 4 | -- Copyright (c) 2019, ERICSSON AB 5 | -- All rights reserved. 6 | -- 7 | -- Redistribution and use in source and binary forms, with or without 8 | -- modification, are permitted provided that the following conditions are met: 9 | -- 10 | -- * Redistributions of source code must retain the above copyright notice, 11 | -- this list of conditions and the following disclaimer. 12 | -- * Redistributions in binary form must reproduce the above copyright 13 | -- notice, this list of conditions and the following disclaimer in the 14 | -- documentation and/or other materials provided with the distribution. 15 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 16 | -- may be used to endorse or promote products derived from this software 17 | -- without specific prior written permission. 18 | -- 19 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -- 30 | 31 | module Feldspar.Core.Middleend.UniqueVars (uniqueVars) where 32 | 33 | import Feldspar.Core.UntypedRepresentation 34 | 35 | import qualified Data.Set as S 36 | import qualified Data.Map.Strict as M 37 | import Control.Monad.State 38 | 39 | type U a = State (S.Set VarId) a 40 | type RRExp a = UntypedFeldF (UntypedFeld a) 41 | 42 | {- | Ensure that each variable binding binds a unique variable. 43 | This invariant is import since some back ends declare all 44 | variables at top level. 45 | -} 46 | 47 | uniqueVars :: UntypedFeld a -> UntypedFeld a 48 | uniqueVars e = evalState (uniqA M.empty e) S.empty 49 | 50 | uniqA :: M.Map VarId (RRExp a) -> UntypedFeld a -> U (UntypedFeld a) 51 | uniqA vm (In r e) = do e1 <- uniq vm e 52 | return $ In r e1 53 | 54 | uniq :: M.Map VarId (RRExp a) -> RRExp a -> U (RRExp a) 55 | uniq vm (Variable v) = return $ M.findWithDefault err (varNum v) vm 56 | where err = error $ "Did not find variable " ++ show v 57 | uniq vm (App op t es) = do es1 <- mapM (uniqA vm) es 58 | return $ App op t es1 59 | uniq _ (Literal l) = return $ Literal l 60 | uniq vm (Lambda v e) = do v1 <- record v 61 | e1 <- uniqA (M.insert (varNum v) (Variable v1) vm) e 62 | return $ Lambda v1 e1 63 | uniq _ e = error $ "UniqueVars.uniq: unimplemented expression: " ++ show e 64 | 65 | record :: Var -> U Var 66 | record v = do s <- get 67 | let n = varNum v 68 | m = head [i | i <- [n, n+10000 ..], S.notMember i s] 69 | put $ m `S.insert` s 70 | return v{varNum = m} 71 | -------------------------------------------------------------------------------- /src/Feldspar/Algorithm/CRC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | -- 4 | -- Copyright (c) 2009-2011, ERICSSON AB 5 | -- All rights reserved. 6 | -- 7 | -- Redistribution and use in source and binary forms, with or without 8 | -- modification, are permitted provided that the following conditions are met: 9 | -- 10 | -- * Redistributions of source code must retain the above copyright notice, 11 | -- this list of conditions and the following disclaimer. 12 | -- * Redistributions in binary form must reproduce the above copyright 13 | -- notice, this list of conditions and the following disclaimer in the 14 | -- documentation and/or other materials provided with the distribution. 15 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 16 | -- may be used to endorse or promote products derived from this software 17 | -- without specific prior written permission. 18 | -- 19 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -- 30 | 31 | module Feldspar.Algorithm.CRC where 32 | 33 | import qualified Prelude 34 | 35 | import Feldspar 36 | import Feldspar.Vector 37 | 38 | tstBit :: Bits a => Data a -> Data Index -> Data Bool 39 | tstBit w b = w .&. (1 .<<. b) /= 0 40 | 41 | makeCrcTable :: (Bits a) => Data a -> Pull1 a 42 | makeCrcTable polynomial = indexed1 256 $ \i -> forLoop 8 (i2n i .<<. (sz - 8)) step 43 | where 44 | sz = bitSize polynomial 45 | step _ r = let r' = r .<<. 1 46 | in tstBit r (sz - 1) ? (r' `xor` polynomial) $ r' 47 | 48 | -- | Calculate the normal form CRC using a table 49 | crcNormal :: (Bits a) 50 | => Pull1 a -> Data a -> Pull1 Word8 -> Data a 51 | crcNormal table initial xs = fromZero $ fold step initial xs 52 | where 53 | sz = bitSize initial 54 | step crc a = (table ! (Z :. i2n ((i2n (crc .>>. (sz - 8)) .&. 0xFF) `xor` a))) `xor` (crc .<<. 8) 55 | 56 | -- | Calculate the reflected form CRC using a table 57 | -- needs reflected tables 58 | crcReflected :: (Bits a) 59 | => Pull1 a -> Data a -> Pull1 Word8 -> Data a 60 | crcReflected table initial xs = fromZero $ fold step initial xs 61 | where 62 | step crc a = (table ! (Z :. i2n ((crc `xor` i2n a) .&. 0xFF))) `xor` (crc .>>. 8) 63 | 64 | -- | Calculate normal form CRC from a polynominal 65 | crcNaive :: (Bits a) => Data a -> Data a -> Pull1 Word8 -> Data a 66 | crcNaive = crcNormal . makeCrcTable 67 | 68 | -- | Reflect the bottom b bits of value t 69 | reflect :: (Bits a) => Data a -> Data Length -> Data a 70 | reflect t b = forLoop b t $ \i v -> let mask = bit ((b-1)-i) in testBit t i ? (v .|. mask) $ v .&. complement mask 71 | 72 | -- References 73 | -- The functions in this module are inspired by the follow guide 74 | -- http://www.ross.net/crc/download/crc_v3.txt 75 | -------------------------------------------------------------------------------- /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" c99WoolPlatformOptions ["-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 | setupPlugins = do 44 | putStrLn "Compiling c_matmul plugin" 45 | evaluate c_matmul_builder 46 | evaluate c_matmul_sics_builder 47 | 48 | setupRefEnv :: [Length] -> IO (Ptr CDouble, Ptr CDouble) 49 | setupRefEnv ls = do 50 | let len = fromIntegral $ product ls 51 | let td = take len (map realToFrac testdata) 52 | o <- mallocArray len 53 | d <- newArray td 54 | return (o,d) 55 | 56 | -- FIXME: This type is probably misaligned with our array-representation. 57 | allocOut :: [Length] -> IO (Ptr (Ptr (SA Length), Ptr (SA Double))) 58 | allocOut lengths = do 59 | ls <- pack lengths 60 | ds <- allocSA $ fromIntegral $ product lengths :: IO (Ptr (SA Double)) 61 | new (ls,ds) 62 | 63 | setupCompEnv :: [Length] -> IO (Ptr (SA Length, Ptr (SA Double))) 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/clib/include/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 | struct ivar_internals { 36 | pthread_mutex_t mutex; 37 | pthread_cond_t cond; 38 | int full; 39 | void *data; 40 | }; 41 | 42 | struct ivar { 43 | struct ivar_internals *internals; 44 | struct ivar *self; 45 | }; 46 | 47 | /* Initializes 'iv'. */ 48 | void ivar_init(struct ivar *iv); 49 | 50 | /* Deinitializes ivar 'iv'. */ 51 | void ivar_destroy(struct ivar *iv); 52 | 53 | /* Copies the data at 'd' of size 'size' into the ivar 'iv'. Ivars are 54 | * allowed to be written only once! */ 55 | void ivar_put_with_size(struct ivar iv, void *d, int size); 56 | 57 | /* Wrapper to 'ivar_put_with_size'. */ 58 | #define ivar_put(typ,iv,d) ivar_put_with_size(iv,d,sizeof(typ)) 59 | 60 | /* Specialized version for arrays. */ 61 | void ivar_put_array(struct ivar iv, void *d, void* cf); 62 | void ivar_put_array_shallow(struct ivar iv, void *d, int32_t size); 63 | 64 | /* Copies the data of size 'size' of the ivar 'iv' to 'var'. Ivars are 65 | * allowed to be read any number of times. Reading an empty ivar blocks 66 | * the thread, but a new worker thread is started instead. 67 | * Use this function only inside tasks! */ 68 | void ivar_get_with_size(void *var, struct ivar iv, int size); 69 | 70 | /* Wrapper to 'ivar_get_with_size'. */ 71 | #define ivar_get(typ,var,iv) ivar_get_with_size(var,iv,sizeof(typ)) 72 | 73 | /* Specialized version for arrays. */ 74 | void ivar_get_array(void *var, struct ivar iv, void* cf); 75 | void ivar_get_array_shallow(void *var, struct ivar iv, int32_t size); 76 | 77 | /* Copies the data of size 'size' of the ivar 'iv' to 'var'. Ivars are 78 | * allowed to be read any number of times. Reading an empty ivar blocks 79 | * the thread. 80 | * Use this function only outside tasks, eg. the main thread or similar! */ 81 | void ivar_get_nontask_with_size(void *var, struct ivar iv, int size); 82 | 83 | /* Wrapper to 'ivar_get_nontask_with_size'. */ 84 | #define ivar_get_nontask(typ,var,iv) ivar_get_nontask_with_size(var,iv,sizeof(typ)) 85 | 86 | /* Specialized version for arrays. */ 87 | void ivar_get_array_nontask(void *var, struct ivar iv, void* vcf); 88 | void ivar_get_array_shallow_nontask(void *var, struct ivar iv, int32_t size); 89 | 90 | #endif /* IVAR_H */ 91 | -------------------------------------------------------------------------------- /src/Feldspar/Core/Middleend/Constructors.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | -- 4 | -- Copyright (c) 2019, ERICSSON AB 5 | -- All rights reserved. 6 | -- 7 | -- Redistribution and use in source and binary forms, with or without 8 | -- modification, are permitted provided that the following conditions are met: 9 | -- 10 | -- * Redistributions of source code must retain the above copyright notice, 11 | -- this list of conditions and the following disclaimer. 12 | -- * Redistributions in binary form must reproduce the above copyright 13 | -- notice, this list of conditions and the following disclaimer in the 14 | -- documentation and/or other materials provided with the distribution. 15 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 16 | -- may be used to endorse or promote products derived from this software 17 | -- without specific prior written permission. 18 | -- 19 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -- 30 | 31 | module Feldspar.Core.Middleend.Constructors 32 | ( Bag(..) 33 | , BindBag 34 | , AExpB 35 | , RExpB 36 | , variable 37 | , literal 38 | , lambda 39 | , app 40 | , aIn 41 | , mkBinds 42 | , toExpr 43 | , fromExpr 44 | , fromRExpr 45 | , unAnnotateB 46 | ) 47 | where 48 | 49 | import Feldspar.Core.UntypedRepresentation 50 | 51 | -- | Intelligent constructors for placing bindings 52 | 53 | data Bag a = Bags [Bag a] 54 | | Item a 55 | deriving (Eq, Ord, Show) 56 | 57 | type BindBag a = Bag [(Var, UntypedFeld a)] 58 | 59 | foldBag :: (a -> b -> b) -> b -> Bag a -> b 60 | foldBag f u (Bags bs) = foldr (\ b r -> foldBag f r b) u bs 61 | foldBag f u (Item x) = f x u 62 | 63 | appendBag :: Bag a -> Bag a -> Bag a 64 | appendBag (Bags []) b = b 65 | appendBag b (Bags []) = b 66 | appendBag l (Bags rs) = Bags $ l : rs 67 | appendBag l (Item r) = Bags [l, Item r] 68 | 69 | concatBags :: [Bag a] -> Bag a 70 | concatBags = foldr appendBag (Bags []) 71 | 72 | type AExpB a = (BindBag a, UntypedFeld a) 73 | type RExpB a = (BindBag a, RRExp a) 74 | 75 | type RRExp a = UntypedFeldF (UntypedFeld a) 76 | 77 | toExpr :: AExpB a -> UntypedFeld a 78 | toExpr (b,e) = foldBag (curry mkLets) e b 79 | 80 | fromExpr :: UntypedFeld a -> AExpB a 81 | fromExpr e = (Bags [], e) 82 | 83 | unAnnotateB :: AExpB a -> RExpB a 84 | unAnnotateB (b, In _ e) = (b, e) 85 | 86 | fromRExpr :: RRExp a -> RExpB a 87 | fromRExpr e = (Bags [], e) 88 | 89 | variable :: Var -> RExpB a 90 | variable v = (Bags [], Variable v) 91 | 92 | literal :: Lit -> RExpB a 93 | literal l = (Bags [], Literal l) 94 | 95 | lambda :: Var -> AExpB a -> RExpB a 96 | lambda v eb = (Bags [], Lambda v $ toExpr eb) 97 | 98 | app :: Op -> Type -> [AExpB a] -> RExpB a 99 | app Condition t [(b,ec), et, ee] = (b, App Condition t [ec, toExpr et, toExpr ee]) 100 | app p t [be] | p `elem` [MkFuture, ParFork] = (Bags [], App p t [toExpr be]) 101 | app op t es = (concatBags bs, App op t es1) 102 | where (bs,es1) = unzip es 103 | 104 | aIn :: a -> RExpB a -> AExpB a 105 | aIn r (b,e) = (b, In r e) 106 | 107 | mkBinds :: ([(Var, AExpB a)], AExpB a) -> AExpB a 108 | mkBinds (bs,(b,e)) = (foldr appendBag (appendBag (Item $ zip vs es1) b) bs1, e) 109 | where (vs,bes) = unzip bs 110 | (bs1,es1) = unzip bes 111 | -------------------------------------------------------------------------------- /src/Feldspar/Algorithm/FFT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | -- 4 | -- Copyright (c) 2009-2011, ERICSSON AB 5 | -- All rights reserved. 6 | -- 7 | -- Redistribution and use in source and binary forms, with or without 8 | -- modification, are permitted provided that the following conditions are met: 9 | -- 10 | -- * Redistributions of source code must retain the above copyright notice, 11 | -- this list of conditions and the following disclaimer. 12 | -- * Redistributions in binary form must reproduce the above copyright 13 | -- notice, this list of conditions and the following disclaimer in the 14 | -- documentation and/or other materials provided with the distribution. 15 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 16 | -- may be used to endorse or promote products derived from this software 17 | -- without specific prior written permission. 18 | -- 19 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -- 30 | 31 | module Feldspar.Algorithm.FFT 32 | ( fft 33 | , ifft 34 | ) 35 | where 36 | 37 | import qualified Prelude as P 38 | 39 | import Feldspar 40 | import Feldspar.Vector hiding (riffle) 41 | 42 | -- | Radix-2 Decimation-In-Frequeny Fast Fourier Transformation of the given complex vector 43 | -- The given vector must be power-of-two sized, (for example 2, 4, 8, 16, 32, etc.) 44 | fft :: Pull1 (Complex Float) -> Pull1 (Complex Float) 45 | fft v = bitRev steps $ fftCore steps v 46 | where steps = ilog2 (length v) - 1 47 | 48 | -- | Radix-2 Decimation-In-Frequeny Inverse Fast Fourier Transformation of the given complex vector 49 | -- The given vector must be power-of-two sized, (for example 2, 4, 8, 16, 32, etc.) 50 | ifft :: Pull1 (Complex Float) -> Pull1 (Complex Float) 51 | ifft v = bitRev steps $ ifftCore steps v 52 | where steps = ilog2 (length v) - 1 53 | 54 | fftCore :: Data Index -> Pull1 (Complex Float) -> Pull1 (Complex Float) 55 | fftCore n = composeOn stage (reverse (0...n)) 56 | where 57 | stage k vec = indexed1 (length vec) ixf 58 | where 59 | ixf i = testBit i k ? (twid * (b - a)) $ a + b 60 | where 61 | a = vec !! i 62 | b = vec !! (i `xor` k2) 63 | twid = cis (-pi * i2f (lsbs k i) / i2f k2) 64 | k2 = 1 .<<. k 65 | 66 | ifftCore :: Data Index -> Pull1 (Complex Float) -> Pull1 (Complex Float) 67 | ifftCore n = map (/ complex (i2f (2^(n+1))) 0) . composeOn stage (reverse (0...n)) 68 | where 69 | stage k vec = indexed1 (length vec) ixf 70 | where 71 | ixf i = testBit i k ? (twid * (b - a)) $ a + b 72 | where 73 | a = vec !! i 74 | b = vec !! (i `xor` k2) 75 | twid = cis (pi * i2f (lsbs k i) / i2f k2) 76 | k2 = 1 .<<. k 77 | 78 | bitRev :: Type a => Data Index -> Pull1 a -> Pull1 a 79 | bitRev n = composeOn riffle (1...n) 80 | 81 | riffle :: Syntax a => Data Index -> Pull DIM1 a -> Pull DIM1 a 82 | riffle k = permute (const $ rotBit k) 83 | 84 | -- Helper functions 85 | composeOn :: (Syntax a) => (b -> a -> a) -> Pull DIM1 b -> a -> a 86 | composeOn f v i = fromZero $ fold (flip f) i v 87 | 88 | rotBit :: Data Index -> Data Index -> Data Index 89 | rotBit k i = lefts .|. rights 90 | where 91 | ir = i .>>. 1 92 | rights = ir .&. oneBits k 93 | lefts = (((ir .>>. k) .<<. 1) .|. (i .&. 1)) .<<. k 94 | -------------------------------------------------------------------------------- /src/Feldspar/Compiler/Backend/C/Tic64x.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE PatternGuards #-} 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | module Feldspar.Compiler.Backend.C.Tic64x (adaptTic64x) where 6 | 7 | import Feldspar.Compiler.Imperative.Representation 8 | import Feldspar.Compiler.Imperative.Frontend 9 | import Feldspar.Compiler.Options 10 | 11 | -- This module does two major things: 12 | -- 13 | -- 1) Replaces all single argument functions where the argument is of complex 14 | -- type with a single named function. The renamer can't currently match on 15 | -- that. 16 | -- 2) Replaces complex typed "/=" and "bitCount" with an expression. 17 | -- 18 | -- TODO: Extend the renamer to cope with #1. 19 | 20 | -- | External interface for tic64x specific fixes. 21 | adaptTic64x :: Options -> Module -> Module 22 | adaptTic64x opts m 23 | | "tic64x" == platformName (platform opts) = adaptTic64x' m 24 | | otherwise = m 25 | 26 | -- | Internal interface for renaming. 27 | adaptTic64x' :: Module -> Module 28 | adaptTic64x' (Module ents) = Module $ map adaptTic64xEnt ents 29 | 30 | -- | Adapts entities. 31 | adaptTic64xEnt :: Entity -> Entity 32 | adaptTic64xEnt p@Proc{..} 33 | | Just body <- procBody = p { procBody = Just $ adaptTic64xBlock body } 34 | adaptTic64xEnt e = e 35 | 36 | -- | Adapts blocks. 37 | adaptTic64xBlock :: Block -> Block 38 | adaptTic64xBlock (Block vs p) = Block (map adaptTic64xDecl vs) (adaptTic64xProg p) 39 | 40 | -- | Adapts declarations. 41 | adaptTic64xDecl :: Declaration -> Declaration 42 | adaptTic64xDecl (Declaration v (Just e)) = Declaration v (Just $ adaptTic64xExp e) 43 | adaptTic64xDecl d = d 44 | 45 | -- | Adapts programs. 46 | adaptTic64xProg :: Program -> Program 47 | adaptTic64xProg e@Empty = e 48 | adaptTic64xProg c@Comment{} = c 49 | adaptTic64xProg (Assign lhs rhs) = Assign (adaptTic64xExp lhs) (adaptTic64xExp rhs) 50 | adaptTic64xProg (ProcedureCall n ps) = ProcedureCall n (map adaptTic64xParam ps) 51 | adaptTic64xProg (Sequence ps) = Sequence $ map adaptTic64xProg ps 52 | adaptTic64xProg (Switch scrut alts) 53 | = Switch (adaptTic64xExp scrut) (map adaptTic64xAlt alts) 54 | adaptTic64xProg (SeqLoop cond calc block) 55 | = SeqLoop (adaptTic64xExp cond) (adaptTic64xBlock calc) (adaptTic64xBlock block) 56 | adaptTic64xProg (ParLoop p v e0 e1 e2 b) 57 | = ParLoop p v (adaptTic64xExp e0) (adaptTic64xExp e1) (adaptTic64xExp e2) (adaptTic64xBlock b) 58 | adaptTic64xProg (BlockProgram b) = BlockProgram $ adaptTic64xBlock b 59 | 60 | -- | Adapts expressions. 61 | adaptTic64xExp :: Expression -> Expression 62 | adaptTic64xExp v@VarExpr{} = v 63 | adaptTic64xExp (ArrayElem e es) = ArrayElem (adaptTic64xExp e) $ map adaptTic64xExp es 64 | adaptTic64xExp (StructField e s) = StructField (adaptTic64xExp e) s 65 | adaptTic64xExp c@ConstExpr{} = c 66 | adaptTic64xExp (FunctionCall (Function "/=" t) [arg1,arg2]) | isComplex (typeof arg1) 67 | = fun t "!" [fun t (extend "equal" $ typeof arg1) [arg1, arg2]] 68 | adaptTic64xExp (FunctionCall (Function "bitCount" t) [arg]) | isComplex (typeof arg) 69 | = fun t "_dotpu4" [fun t "_bitc4" [arg], litI32 0x01010101] 70 | adaptTic64xExp (FunctionCall f es) 71 | = FunctionCall (adaptTic64xFun argtype (length es) f) $ map adaptTic64xExp es 72 | where argtype = typeof $ head es 73 | adaptTic64xExp (Cast t e) = Cast t $ adaptTic64xExp e 74 | adaptTic64xExp (AddrOf e) = AddrOf $ adaptTic64xExp e 75 | adaptTic64xExp s@SizeOf{} = s 76 | adaptTic64xExp (Deref e) = Deref $ adaptTic64xExp e 77 | 78 | -- | Adapts parameters. 79 | adaptTic64xParam :: ActualParameter -> ActualParameter 80 | adaptTic64xParam (ValueParameter e) = ValueParameter $ adaptTic64xExp e 81 | adaptTic64xParam p = p 82 | 83 | -- | Adapts switch alternatives. 84 | adaptTic64xAlt :: (Pattern, Block) -> (Pattern, Block) 85 | adaptTic64xAlt (p, b) = (p, adaptTic64xBlock b) 86 | 87 | -- | Adapts functions that should be adapted Identity function on others. 88 | adaptTic64xFun :: Type -> Int -> Function -> Function 89 | adaptTic64xFun argtype args f@(Function _ t) 90 | | isComplex argtype 91 | , args == 1 -- TODO: This transformation looks dangerous. 92 | = Function (extend "creal" argtype) t 93 | | otherwise = f 94 | -------------------------------------------------------------------------------- /src/Feldspar/Core/Middleend/CreateTasks.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | -- 4 | -- Copyright (c) 2019, ERICSSON AB 5 | -- All rights reserved. 6 | -- 7 | -- Redistribution and use in source and binary forms, with or without 8 | -- modification, are permitted provided that the following conditions are met: 9 | -- 10 | -- * Redistributions of source code must retain the above copyright notice, 11 | -- this list of conditions and the following disclaimer. 12 | -- * Redistributions in binary form must reproduce the above copyright 13 | -- notice, this list of conditions and the following disclaimer in the 14 | -- documentation and/or other materials provided with the distribution. 15 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 16 | -- may be used to endorse or promote products derived from this software 17 | -- without specific prior written permission. 18 | -- 19 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -- 30 | 31 | module Feldspar.Core.Middleend.CreateTasks ( createTasks ) where 32 | 33 | import Control.Monad.State (State, evalState, get, liftM2, put) 34 | 35 | import Feldspar.Compiler.Options (Options(..), Target(..), inTarget) 36 | import Feldspar.Core.UntypedRepresentation 37 | import Feldspar.Core.ValueInfo (ValueInfo, topInfo) 38 | 39 | -- | Create tasks from MkFuture and similar constructs. 40 | -- Invariant: There are no MkFuture, ParFork or NoInline constructs in the output. 41 | createTasks :: Options -> UntypedFeld ValueInfo -> UntypedFeld ValueInfo 42 | createTasks opts e = evalState (go opts e) 0 43 | 44 | go :: Options -> UntypedFeld ValueInfo -> State Integer (UntypedFeld ValueInfo) 45 | go _ e@(In _ Variable{}) = return e 46 | go env (In r (Lambda v e)) = do 47 | e' <- go env e 48 | return $ In r (Lambda v e') 49 | go env (In r (LetFun (s, k, e1) e2)) 50 | = liftM2 (\e1' e2' -> In r (LetFun (s, k, e1') e2')) (go env e1) (go env e2) 51 | go _ l@(In _ Literal{}) = return l 52 | go env (In r (App p _ [e])) | p `elem` [MkFuture, ParFork] = do 53 | p'' <- go env p' 54 | i <- freshId 55 | let taskName = "task" ++ show i 56 | core = "task_core" ++ show i 57 | k = if p == MkFuture then Future else Par 58 | return $ In r (LetFun (core, k, p'') (In r (App (Call k taskName) t' vs'))) 59 | where vs = fv e 60 | vs' = map (\(r', v') -> In r' $ Variable v') vs 61 | p' = mkLam vs e 62 | t' = FValType $ typeof e 63 | go env (In r (App NoInline _ [p])) = do 64 | p'' <- go env p' 65 | i <- freshId 66 | let name = "noinline" ++ show i 67 | return $ In r (LetFun (name, None, p'') (In r (App (Call None name) t' vs'))) 68 | where vs = fv p 69 | vs' = map (\(r', v') -> In r' $ Variable v') vs 70 | p' = mkLam vs p 71 | t' = typeof p 72 | go env (In r1 (App f t [l, e@(In r2 (Lambda v body))])) 73 | | Wool `inTarget` env && f `elem` [EparFor, Parallel] = do 74 | p'' <- go env p' 75 | i <- freshId 76 | let name = "wool" ++ show i 77 | body' = In r2 (Lambda v (In r2 (App (Call Loop name) t' $ tail vs'))) 78 | return $ In r1 (LetFun (name, Loop, p'') (In r1 (App f t [l,body']))) 79 | where -- Make sure index is outermost parameter. 80 | -- FIXME: We are losing precision in the annotations here. 81 | vs = (topInfo $ varType v, v):fv e 82 | vs' = map (\(r', v') -> In r' $ Variable v') vs 83 | p' = mkLam vs body 84 | t' = typeof body 85 | go env (In r (App p t es)) = do 86 | es' <- mapM (go env) es 87 | return $ In r (App p t es') 88 | 89 | freshId :: State Integer Integer 90 | freshId = do 91 | i <- get 92 | put (i + 1) 93 | return i 94 | -------------------------------------------------------------------------------- /src/Feldspar/Vector/Shape.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | 5 | module Feldspar.Vector.Shape where 6 | 7 | import qualified Prelude as P 8 | 9 | import Feldspar 10 | import Feldspar.Core.Language 11 | 12 | infixl 3 :. 13 | data Z 14 | data tail :. head 15 | 16 | type DIM0 = Z 17 | type DIM1 = DIM0 :. Data Length 18 | type DIM2 = DIM1 :. Data Length 19 | type DIM3 = DIM2 :. Data Length 20 | type DIM4 = DIM3 :. Data Length 21 | 22 | data Shape sh where 23 | Z :: Shape Z 24 | (:.) :: Shape tail -> Data Length -> Shape (tail :. Data Length) 25 | 26 | -- | The dimensionality of @sh@ 27 | dim :: Shape sh -> Int 28 | dim Z = 0 29 | dim (sh :. _) = 1 + dim sh 30 | 31 | -- | The total number of elements in @sh@ 32 | size :: Shape sh -> Data Length 33 | size Z = 1 34 | size (sh :. i) = size sh * i 35 | 36 | toIndex :: Shape sh -> Shape sh -> Data Index 37 | toIndex Z Z = 0 38 | toIndex (sh1 :. sh2) (sh1' :. sh2') = toIndex sh1 sh1' * sh2 + sh2' 39 | 40 | fromIndex :: Shape sh -> Data Index -> Shape sh 41 | fromIndex Z _ = Z 42 | fromIndex sh@(_sh :. l) ix = fromIndexOne sh ix 43 | 44 | fromIndexOne :: Shape (sh :. Data Index) -> Data Index -> 45 | Shape (sh :. Data Index) 46 | fromIndexOne (Z :. _) ix = Z :. ix 47 | fromIndexOne (ds@(_ :. _) :. d) ix 48 | = fromIndexOne ds (ix `quot` d) :. (ix `rem` d) 49 | 50 | intersectDim :: Shape sh -> Shape sh -> Shape sh 51 | intersectDim Z Z = Z 52 | intersectDim (sh1 :. n1) (sh2 :. n2) 53 | = intersectDim sh1 sh2 :. min n1 n2 54 | 55 | inRange :: Shape sh -> Shape sh -> Shape sh -> Data Bool 56 | inRange Z Z Z = true 57 | inRange (shL :. l) (shU :. u) (sh :. i) 58 | = l <= i && i < u && inRange shL shU sh 59 | 60 | -- | Walk the shape, performing @k@ at each index 61 | forShape :: Shape sh -> (Shape sh -> M ()) -> M () 62 | forShape Z k = k Z 63 | forShape (sh :. l) k = forM l (\i -> forShape sh (\sh -> k (sh :. i))) 64 | 65 | -- | Walk the shape, using $k$ to generate an Elements set at each index 66 | parForShape :: Type a => Shape sh -> (Shape sh -> Data (Elements a)) -> Data (Elements a) 67 | parForShape Z k = k Z 68 | parForShape (sh :. l) k = parFor l (\i -> parForShape sh (\sh -> k (sh :. i))) 69 | 70 | parForShapeR :: Type a => Shape sh -> (Shape sh -> Data (Elements a)) -> Data (Elements a) 71 | parForShapeR Z k = k Z 72 | parForShapeR (sh :. l) k = parForShapeR sh (\sh -> parFor l (\i -> k (sh :. i))) 73 | 74 | -- | Unpack the shape to a list with the innermost dimension first 75 | toList :: Shape sh -> [Data Length] 76 | toList Z = [] 77 | toList (sh :. i) = i : toList sh 78 | 79 | -- | Deconstruct the shape 80 | uncons :: Shape (sh :. Data Length) -> (Shape sh, Data Length) 81 | uncons (sh :. i) = (sh,i) 82 | 83 | shapeEq :: Shape sh1 -> Shape sh2 -> Data Bool 84 | shapeEq Z Z = true 85 | shapeEq (sh1 :. i) (sh2 :. j) = i == j && shapeEq sh1 sh2 86 | shapeEq _ _ = false 87 | 88 | zipShape :: (Data Length -> Data Length -> Data Length) -> 89 | Shape sh -> Shape sh -> Shape sh 90 | zipShape f Z Z = Z 91 | zipShape f (sh1 :. i) (sh2 :. j) = zipShape f sh1 sh2 :. f i j 92 | 93 | class Shapely sh where 94 | zeroDim :: Shape sh 95 | unitDim :: Shape sh 96 | fakeShape :: Shape sh 97 | toShape :: Int -> Data [Length] -> Shape sh 98 | 99 | instance Shapely Z where 100 | zeroDim = Z 101 | unitDim = Z 102 | fakeShape = Z 103 | toShape _ _ = Z 104 | 105 | instance Shapely sh => Shapely (sh :. Data Length) where 106 | zeroDim = zeroDim :. 0 107 | unitDim = unitDim :. 1 108 | fakeShape = fakeShape :. P.error "You shall not inspect the syntax tree!" 109 | toShape i arr = toShape (i+1) arr :. (arr ! P.fromIntegral i) 110 | 111 | -- KFFs extensions 112 | 113 | peelLeft :: Shape (sh :. Data Length) -> (Data Length, Shape sh) 114 | peelLeft (Z :. n) = (n, Z) 115 | peelLeft (sh :. n :. n') = (m, sh' :. n') -- The extra (leftmost and below) ':.' is necessary for type checking the recursive call 116 | where (m, sh') = peelLeft (sh :. n) 117 | 118 | peelLeft2 :: Shape (sh :. Data Length :. Data Length) -> (Data Length, Data Length, Shape sh) 119 | peelLeft2 sh = (m, n, sh'') 120 | where (m, sh') = peelLeft sh 121 | (n, sh'') = peelLeft sh' 122 | 123 | insLeft :: Data Length -> Shape sh -> Shape (sh :. Data Length) 124 | insLeft m Z = Z :. m 125 | insLeft m (sh :. n) = insLeft m sh :. n 126 | -------------------------------------------------------------------------------- /examples/Tutorial/Patch.lhs: -------------------------------------------------------------------------------- 1 | % Constraints 2 | 3 |
4 | 5 | 6 | 7 | This file demonstrates how to use [patches](http://hackage.haskell.org/package/patch-combinators) to constrain types and sizes of Feldspar expressions. 8 | 9 | \begin{code} 10 | module Tutorial.Patch where 11 | 12 | import qualified Prelude 13 | import Feldspar 14 | import Feldspar.Vector 15 | \end{code} 16 | 17 | 18 | 19 | Type patches 20 | ============ 21 | 22 | Say we want to print the core expression resulting from the `scalarProd` function. Attempting this without giving any size constraints leads to an "ambiguous type" error: 23 | 24 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 25 | *Tutorial.Patch> printExpr scalarProd 26 | :26:1: 27 | Couldn't match type `syntactic-1.5.0:Language.Syntactic.Sugar.Domain 28 | a0' 29 | with `FeldDomain' 30 | The type variable `a0' is ambiguous 31 | Possible fix: add a type signature that fixes these type variable(s) 32 | In the expression: printExpr scalarProd 33 | In an equation for `it': it = printExpr scalarProd 34 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 35 | 36 | The solution is to provide a type signature for `scalarProd`: 37 | 38 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 39 | *Tutorial.Patch> printExpr (scalarProd :: Pull1 Float -> Pull1 Float -> Data Float) 40 | ... 41 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 42 | 43 | An alternative --- and less verbose --- way of specifying type constraints is to use *type patches* instead: 44 | 45 | \begin{code} 46 | test1 = printExpr $ scalarProd -:: tPull1 tFloat >-> tPull1 tFloat >-> id 47 | \end{code} 48 | 49 | The part to the right of `-::` is the "patch", which is applied as a wrapper around `scalarProd`. In general, patches can change the behavior of the wrapped function, but type patches, such as the one above, only have the effect of constraining the function's type. The patch `tPull1 tFloat >-> id` is composed of two smaller patches: `tPull1 tFloat` and `id` (the identity function). The first of these is applied to the first argument and constrains its type to `Vector1 Float`. The `id` patch simply leaves the result (that is, the partially applied `scalarProd`) untouched. Thus, the whole patch can be thought of as the following *partial type signature* for `scalarProd`: 50 | 51 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~{.haskell} 52 | scalarProd :: Pull1 Float -> _ -- Not legal Haskell 53 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~{.haskell} 54 | 55 | 56 | 57 | Avoiding length checks 58 | ====================== 59 | 60 | In the expression printed by `test1`, we see a `min` function computing the number of iterations as the minimum of the input vector lengths. It is possible to get rid of this comparison by giving the second vector the same length as the first: 61 | 62 | \begin{code} 63 | test2 = printExpr $ scalarProd 64 | -:: tPull1 tFloat >-> tPull1 tFloat >-> id 65 | -:: name (\a -> id >-> newLen1 (length a) >-> id) 66 | \end{code} 67 | 68 | The `name` combinator lets us bind the first argument (to the variable `a`) and use it in the patch. The actual patch is then 69 | 70 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~{.haskell} 71 | id >-> newLen1 (length a) >-> id 72 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~{.haskell} 73 | 74 | which simply sets the length of the second argument to the length of `a`. 75 | 76 | 77 | 78 | Size patches 79 | ============ 80 | 81 | [`Tutorial.Size`](Size.html) describes how size analysis works and how to provide size constraints to improve the analysis. Size constraints are often convenient to use as patches. 82 | 83 | The following example was used to demonstrate how the programmer can guide the analysis by providing guarantees about the ranges of values in the program: 84 | 85 | \begin{code} 86 | drop4 :: Data Index -> Pull1 (Data Word8) -> Pull1 (Data Word8) 87 | drop4 n v = drop n' v' 88 | where 89 | n' = between 100 120 n 90 | v' = newLen1 (between 150 200 (length v)) v 91 | \end{code} 92 | 93 | Using patch combinators, `drop4` can be written more succinctly as 94 | 95 | \begin{code} 96 | drop4' :: Data Index -> Pull1 (Data Word8) -> Pull1 (Data Word8) 97 | drop4' = drop -:: between 100 120 >-> (between 150 200 |> id) >-> id 98 | \end{code} 99 | 100 | The patch combinator `(|>)` takes a patch for the length (`between 150 200`) and a patch for the elements (`id`) and returns a patch for a whole vector. 101 | 102 | -------------------------------------------------------------------------------- /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 Control.Monad (unless) 40 | import System.Exit (ExitCode(..)) 41 | import System.FilePath (replaceExtension) 42 | import System.Process (readProcessWithExitCode) 43 | 44 | main = defaultMainWithHooks simpleUserHooks{ buildHook = buildH } 45 | 46 | -- | Custom build hook that builds C-sources for benchmarks with x-cc-name set. 47 | buildH :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () 48 | buildH pd lbi user_hooks flags = do 49 | benchmarks' <- mapM (checkIfAndCompile lbi) $ benchmarks pd 50 | -- Build the remaining things the regular way. 51 | buildHook simpleUserHooks pd{ benchmarks = benchmarks' } lbi user_hooks flags 52 | return () 53 | 54 | -- | Checks if x-cc-name is set, and compiles c-sources with that compiler name. 55 | checkIfAndCompile :: LocalBuildInfo -> Benchmark -> IO Benchmark 56 | checkIfAndCompile lbi bench = do 57 | let bench_bi = benchmarkBuildInfo bench 58 | case lookup "x-cc-name" $ customFieldsBI bench_bi of 59 | Nothing -> return bench 60 | Just cc_name -> do 61 | let c_srcs = cSources bench_bi 62 | cc_opts = ccOptions bench_bi 63 | inc_dirs = includeDirs bench_bi 64 | -- Compile C/C++ sources 65 | putStrLn "Invoking icc compiler" 66 | mapM_ (compile lbi bench cc_name cc_opts inc_dirs) c_srcs 67 | -- Remove C source code from the hooked build (don't change libs) 68 | return $ bench{ benchmarkBuildInfo = bench_bi{ cSources = [] } } 69 | 70 | -- | Compiles a C file with the given options. 71 | compile :: LocalBuildInfo -> Benchmark -> String -> [String] -> [String] -> FilePath -> IO () 72 | compile lbi bench cc_name opts inc_dirs srcfile = do 73 | let args = [ "-optc -std=c99" 74 | , "-optc -Wall" 75 | , "-w" 76 | , "-c" 77 | , "-pgmc " ++ cc_name 78 | ] ++ map ("-optc " ++) opts 79 | objfile = replaceExtension srcfile "o" 80 | fullargs = args ++ ["-o", objfile, srcfile] 81 | (ghcProg,_) <- requireProgram verbose ghcProgram (withPrograms lbi) 82 | let ghc = programPath ghcProg 83 | print $ unwords $ ["Calling:",ghc] ++ fullargs 84 | (ex, stdout, stderr) <- readProcessWithExitCode ghc fullargs "" 85 | case ex of 86 | ExitFailure{} -> error $ unlines [show ex, stdout, stderr] 87 | _ -> do let output = stdout ++ stderr 88 | unless (null output) $ putStrLn output 89 | -------------------------------------------------------------------------------- /src/Onnx/Onnx/Version.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -w #-} 3 | module Onnx.Version (Version(..)) where 4 | import Prelude ((+), (/), (.)) 5 | import qualified Prelude as Prelude' 6 | import qualified Data.Typeable as Prelude' 7 | import qualified GHC.Generics as Prelude' 8 | import qualified Data.Data as Prelude' 9 | import qualified Text.ProtocolBuffers.Header as P' 10 | 11 | data Version = U'START_VERSION 12 | | IR_VERSION_2017_10_10 13 | | IR_VERSION_2017_10_30 14 | | IR_VERSION_2017_11_3 15 | | IR_VERSION_2019_1_22 16 | | IR_VERSION_2019_3_18 17 | | IR_VERSION_2019_9_19 18 | | IR_VERSION 19 | deriving (Prelude'.Read, Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, 20 | Prelude'.Generic) 21 | 22 | instance P'.Mergeable Version 23 | 24 | instance Prelude'.Bounded Version where 25 | minBound = U'START_VERSION 26 | maxBound = IR_VERSION 27 | 28 | instance P'.Default Version where 29 | defaultValue = U'START_VERSION 30 | 31 | toMaybe'Enum :: Prelude'.Int -> P'.Maybe Version 32 | toMaybe'Enum 0 = Prelude'.Just U'START_VERSION 33 | toMaybe'Enum 1 = Prelude'.Just IR_VERSION_2017_10_10 34 | toMaybe'Enum 2 = Prelude'.Just IR_VERSION_2017_10_30 35 | toMaybe'Enum 3 = Prelude'.Just IR_VERSION_2017_11_3 36 | toMaybe'Enum 4 = Prelude'.Just IR_VERSION_2019_1_22 37 | toMaybe'Enum 5 = Prelude'.Just IR_VERSION_2019_3_18 38 | toMaybe'Enum 6 = Prelude'.Just IR_VERSION_2019_9_19 39 | toMaybe'Enum 7 = Prelude'.Just IR_VERSION 40 | toMaybe'Enum _ = Prelude'.Nothing 41 | 42 | instance Prelude'.Enum Version where 43 | fromEnum U'START_VERSION = 0 44 | fromEnum IR_VERSION_2017_10_10 = 1 45 | fromEnum IR_VERSION_2017_10_30 = 2 46 | fromEnum IR_VERSION_2017_11_3 = 3 47 | fromEnum IR_VERSION_2019_1_22 = 4 48 | fromEnum IR_VERSION_2019_3_18 = 5 49 | fromEnum IR_VERSION_2019_9_19 = 6 50 | fromEnum IR_VERSION = 7 51 | toEnum = P'.fromMaybe (Prelude'.error "hprotoc generated code: toEnum failure for type Onnx.Version") . toMaybe'Enum 52 | succ U'START_VERSION = IR_VERSION_2017_10_10 53 | succ IR_VERSION_2017_10_10 = IR_VERSION_2017_10_30 54 | succ IR_VERSION_2017_10_30 = IR_VERSION_2017_11_3 55 | succ IR_VERSION_2017_11_3 = IR_VERSION_2019_1_22 56 | succ IR_VERSION_2019_1_22 = IR_VERSION_2019_3_18 57 | succ IR_VERSION_2019_3_18 = IR_VERSION_2019_9_19 58 | succ IR_VERSION_2019_9_19 = IR_VERSION 59 | succ _ = Prelude'.error "hprotoc generated code: succ failure for type Onnx.Version" 60 | pred IR_VERSION_2017_10_10 = U'START_VERSION 61 | pred IR_VERSION_2017_10_30 = IR_VERSION_2017_10_10 62 | pred IR_VERSION_2017_11_3 = IR_VERSION_2017_10_30 63 | pred IR_VERSION_2019_1_22 = IR_VERSION_2017_11_3 64 | pred IR_VERSION_2019_3_18 = IR_VERSION_2019_1_22 65 | pred IR_VERSION_2019_9_19 = IR_VERSION_2019_3_18 66 | pred IR_VERSION = IR_VERSION_2019_9_19 67 | pred _ = Prelude'.error "hprotoc generated code: pred failure for type Onnx.Version" 68 | 69 | instance P'.Wire Version where 70 | wireSize ft' enum = P'.wireSize ft' (Prelude'.fromEnum enum) 71 | wirePut ft' enum = P'.wirePut ft' (Prelude'.fromEnum enum) 72 | wireGet 14 = P'.wireGetEnum toMaybe'Enum 73 | wireGet ft' = P'.wireGetErr ft' 74 | wireGetPacked 14 = P'.wireGetPackedEnum toMaybe'Enum 75 | wireGetPacked ft' = P'.wireGetErr ft' 76 | 77 | instance P'.GPB Version 78 | 79 | instance P'.MessageAPI msg' (msg' -> Version) Version where 80 | getVal m' f' = f' m' 81 | 82 | instance P'.ReflectEnum Version where 83 | reflectEnum 84 | = [(0, "U'START_VERSION", U'START_VERSION), (1, "IR_VERSION_2017_10_10", IR_VERSION_2017_10_10), 85 | (2, "IR_VERSION_2017_10_30", IR_VERSION_2017_10_30), (3, "IR_VERSION_2017_11_3", IR_VERSION_2017_11_3), 86 | (4, "IR_VERSION_2019_1_22", IR_VERSION_2019_1_22), (5, "IR_VERSION_2019_3_18", IR_VERSION_2019_3_18), 87 | (6, "IR_VERSION_2019_9_19", IR_VERSION_2019_9_19), (7, "IR_VERSION", IR_VERSION)] 88 | reflectEnumInfo _ 89 | = P'.EnumInfo (P'.makePNF (P'.pack ".onnx.Version") [] ["Onnx"] "Version") ["Onnx", "Version.hs"] 90 | [(0, "U'START_VERSION"), (1, "IR_VERSION_2017_10_10"), (2, "IR_VERSION_2017_10_30"), (3, "IR_VERSION_2017_11_3"), 91 | (4, "IR_VERSION_2019_1_22"), (5, "IR_VERSION_2019_3_18"), (6, "IR_VERSION_2019_9_19"), (7, "IR_VERSION")] 92 | Prelude'.False 93 | 94 | instance P'.TextType Version where 95 | tellT = P'.tellShow 96 | getT = P'.getRead -------------------------------------------------------------------------------- /src/Onnx/Onnx/TypeProto/Sequence.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -w #-} 3 | module Onnx.TypeProto.Sequence (Sequence(..)) where 4 | import Prelude ((+), (/), (++), (.)) 5 | import qualified Prelude as Prelude' 6 | import qualified Data.Typeable as Prelude' 7 | import qualified GHC.Generics as Prelude' 8 | import qualified Data.Data as Prelude' 9 | import qualified Text.ProtocolBuffers.Header as P' 10 | import {-# SOURCE #-} qualified Onnx.TypeProto as Onnx (TypeProto) 11 | 12 | data Sequence = Sequence{elem_type :: !(P'.Maybe Onnx.TypeProto)} 13 | deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) 14 | 15 | instance P'.Mergeable Sequence where 16 | mergeAppend (Sequence x'1) (Sequence y'1) = Sequence (P'.mergeAppend x'1 y'1) 17 | 18 | instance P'.Default Sequence where 19 | defaultValue = Sequence P'.defaultValue 20 | 21 | instance P'.Wire Sequence where 22 | wireSize ft' self'@(Sequence x'1) 23 | = case ft' of 24 | 10 -> calc'Size 25 | 11 -> P'.prependMessageSize calc'Size 26 | _ -> P'.wireSizeErr ft' self' 27 | where 28 | calc'Size = (P'.wireSizeOpt 1 11 x'1) 29 | wirePutWithSize ft' self'@(Sequence x'1) 30 | = case ft' of 31 | 10 -> put'Fields 32 | 11 -> put'FieldsSized 33 | _ -> P'.wirePutErr ft' self' 34 | where 35 | put'Fields = P'.sequencePutWithSize [P'.wirePutOptWithSize 10 11 x'1] 36 | put'FieldsSized 37 | = let size' = Prelude'.fst (P'.runPutM put'Fields) 38 | put'Size 39 | = do 40 | P'.putSize size' 41 | Prelude'.return (P'.size'WireSize size') 42 | in P'.sequencePutWithSize [put'Size, put'Fields] 43 | wireGet ft' 44 | = case ft' of 45 | 10 -> P'.getBareMessageWith (P'.catch'Unknown' P'.discardUnknown update'Self) 46 | 11 -> P'.getMessageWith (P'.catch'Unknown' P'.discardUnknown update'Self) 47 | _ -> P'.wireGetErr ft' 48 | where 49 | update'Self wire'Tag old'Self 50 | = case wire'Tag of 51 | 10 -> Prelude'.fmap 52 | (\ !new'Field -> old'Self{elem_type = P'.mergeAppend (elem_type old'Self) (Prelude'.Just new'Field)}) 53 | (P'.wireGet 11) 54 | _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self 55 | 56 | instance P'.MessageAPI msg' (msg' -> Sequence) Sequence where 57 | getVal m' f' = f' m' 58 | 59 | instance P'.GPB Sequence 60 | 61 | instance P'.ReflectDescriptor Sequence where 62 | getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [10]) 63 | reflectDescriptorInfo _ 64 | = Prelude'.read 65 | "DescriptorInfo {descName = ProtoName {protobufName = FIName \".onnx.TypeProto.Sequence\", haskellPrefix = [], parentModule = [MName \"Onnx\",MName \"TypeProto\"], baseName = MName \"Sequence\"}, descFilePath = [\"Onnx\",\"TypeProto\",\"Sequence.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".onnx.TypeProto.Sequence.elem_type\", haskellPrefix' = [], parentModule' = [MName \"Onnx\",MName \"TypeProto\",MName \"Sequence\"], baseName' = FName \"elem_type\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".onnx.TypeProto\", haskellPrefix = [], parentModule = [MName \"Onnx\"], baseName = MName \"TypeProto\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False, jsonInstances = False}" 66 | 67 | instance P'.TextType Sequence where 68 | tellT = P'.tellSubMessage 69 | getT = P'.getSubMessage 70 | 71 | instance P'.TextMsg Sequence where 72 | textPut msg 73 | = do 74 | P'.tellT "elem_type" (elem_type msg) 75 | textGet 76 | = do 77 | mods <- P'.sepEndBy (P'.choice [parse'elem_type]) P'.spaces 78 | Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) 79 | where 80 | parse'elem_type 81 | = P'.try 82 | (do 83 | v <- P'.getT "elem_type" 84 | Prelude'.return (\ o -> o{elem_type = v})) -------------------------------------------------------------------------------- /src/Onnx/Onnx/TensorShapeProto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -w #-} 3 | module Onnx.TensorShapeProto (TensorShapeProto(..)) where 4 | import Prelude ((+), (/), (++), (.)) 5 | import qualified Prelude as Prelude' 6 | import qualified Data.Typeable as Prelude' 7 | import qualified GHC.Generics as Prelude' 8 | import qualified Data.Data as Prelude' 9 | import qualified Text.ProtocolBuffers.Header as P' 10 | import qualified Onnx.TensorShapeProto.Dimension as Onnx.TensorShapeProto (Dimension) 11 | 12 | data TensorShapeProto = TensorShapeProto{dim :: !(P'.Seq Onnx.TensorShapeProto.Dimension)} 13 | deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) 14 | 15 | instance P'.Mergeable TensorShapeProto where 16 | mergeAppend (TensorShapeProto x'1) (TensorShapeProto y'1) = TensorShapeProto (P'.mergeAppend x'1 y'1) 17 | 18 | instance P'.Default TensorShapeProto where 19 | defaultValue = TensorShapeProto P'.defaultValue 20 | 21 | instance P'.Wire TensorShapeProto where 22 | wireSize ft' self'@(TensorShapeProto x'1) 23 | = case ft' of 24 | 10 -> calc'Size 25 | 11 -> P'.prependMessageSize calc'Size 26 | _ -> P'.wireSizeErr ft' self' 27 | where 28 | calc'Size = (P'.wireSizeRep 1 11 x'1) 29 | wirePutWithSize ft' self'@(TensorShapeProto x'1) 30 | = case ft' of 31 | 10 -> put'Fields 32 | 11 -> put'FieldsSized 33 | _ -> P'.wirePutErr ft' self' 34 | where 35 | put'Fields = P'.sequencePutWithSize [P'.wirePutRepWithSize 10 11 x'1] 36 | put'FieldsSized 37 | = let size' = Prelude'.fst (P'.runPutM put'Fields) 38 | put'Size 39 | = do 40 | P'.putSize size' 41 | Prelude'.return (P'.size'WireSize size') 42 | in P'.sequencePutWithSize [put'Size, put'Fields] 43 | wireGet ft' 44 | = case ft' of 45 | 10 -> P'.getBareMessageWith (P'.catch'Unknown' P'.discardUnknown update'Self) 46 | 11 -> P'.getMessageWith (P'.catch'Unknown' P'.discardUnknown update'Self) 47 | _ -> P'.wireGetErr ft' 48 | where 49 | update'Self wire'Tag old'Self 50 | = case wire'Tag of 51 | 10 -> Prelude'.fmap (\ !new'Field -> old'Self{dim = P'.append (dim old'Self) new'Field}) (P'.wireGet 11) 52 | _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self 53 | 54 | instance P'.MessageAPI msg' (msg' -> TensorShapeProto) TensorShapeProto where 55 | getVal m' f' = f' m' 56 | 57 | instance P'.GPB TensorShapeProto 58 | 59 | instance P'.ReflectDescriptor TensorShapeProto where 60 | getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [10]) 61 | reflectDescriptorInfo _ 62 | = Prelude'.read 63 | "DescriptorInfo {descName = ProtoName {protobufName = FIName \".onnx.TensorShapeProto\", haskellPrefix = [], parentModule = [MName \"Onnx\"], baseName = MName \"TensorShapeProto\"}, descFilePath = [\"Onnx\",\"TensorShapeProto.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".onnx.TensorShapeProto.dim\", haskellPrefix' = [], parentModule' = [MName \"Onnx\",MName \"TensorShapeProto\"], baseName' = FName \"dim\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".onnx.TensorShapeProto.Dimension\", haskellPrefix = [], parentModule = [MName \"Onnx\",MName \"TensorShapeProto\"], baseName = MName \"Dimension\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False, jsonInstances = False}" 64 | 65 | instance P'.TextType TensorShapeProto where 66 | tellT = P'.tellSubMessage 67 | getT = P'.getSubMessage 68 | 69 | instance P'.TextMsg TensorShapeProto where 70 | textPut msg 71 | = do 72 | P'.tellT "dim" (dim msg) 73 | textGet 74 | = do 75 | mods <- P'.sepEndBy (P'.choice [parse'dim]) P'.spaces 76 | Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) 77 | where 78 | parse'dim 79 | = P'.try 80 | (do 81 | v <- P'.getT "dim" 82 | Prelude'.return (\ o -> o{dim = P'.append (dim o) v})) -------------------------------------------------------------------------------- /src/Feldspar/Core/Middleend/PushLets.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | -- 4 | -- Copyright (c) 2019, ERICSSON AB 5 | -- All rights reserved. 6 | -- 7 | -- Redistribution and use in source and binary forms, with or without 8 | -- modification, are permitted provided that the following conditions are met: 9 | -- 10 | -- * Redistributions of source code must retain the above copyright notice, 11 | -- this list of conditions and the following disclaimer. 12 | -- * Redistributions in binary form must reproduce the above copyright 13 | -- notice, this list of conditions and the following disclaimer in the 14 | -- documentation and/or other materials provided with the distribution. 15 | -- * Neither the name of the ERICSSON AB nor the names of its contributors 16 | -- may be used to endorse or promote products derived from this software 17 | -- without specific prior written permission. 18 | -- 19 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -- 30 | 31 | module Feldspar.Core.Middleend.PushLets (pushLets) where 32 | 33 | import Feldspar.Core.UntypedRepresentation 34 | import Feldspar.Core.Middleend.Constructors 35 | 36 | pushLets :: Eq a => UntypedFeld a -> UntypedFeld a 37 | pushLets = toExpr . go 38 | where go (In _ (App Let _ [rhs, In _ (Lambda v body)])) 39 | | legalToInline rhs = push v (go rhs) `sapp` toExpr (go body) 40 | | otherwise = mkBinds ([(v, go rhs)], go body) 41 | go (In r (App op t es)) = aIn r $ app op t $ map go es 42 | go (In r (Lambda v e)) = aIn r $ lambda v $ go e 43 | go e = fromExpr e 44 | sapp f x = if x == x then f x else undefined 45 | 46 | data OCount = OC {low, high :: Int} 47 | deriving (Eq, Show) 48 | 49 | data DSCount = DS {dynamic :: OCount, static :: Int} 50 | deriving (Eq, Show) 51 | 52 | push :: Var -> AExpB a -> UntypedFeld a -> AExpB a 53 | push v rhs = snd . goA False False 54 | where goA lo pa (In r1 e) = (norm n1, aIn r1 $ if ph then eB else e1) 55 | where (n1,e1) = go lo (pa || ph) e 56 | d1 = dynamic n1 57 | ph = not pa && (high d1 > 1 || low d1 > 0 && static n1 > 1) 58 | eB = unAnnotateB $ mkBinds ([(v, rhs)], aIn r1 e1) 59 | 60 | go _ pa e@(Variable u) = if u /= v then (zeroDS, fromRExpr e) 61 | else (oneDS, if pa then fromRExpr e else unAnnotateB rhs) 62 | go _ _ e@(Literal _) = (zeroDS, fromRExpr e) 63 | go _ pa (App Condition t [ec, et, ee]) = (n, app Condition t [ec1, et1, ee1]) 64 | where (nc,ec1) = goA False pa ec 65 | (nt,et1) = goA False pa et 66 | (ne,ee1) = goA False pa ee 67 | n = liftDS both nc (liftDS oneOf nt ne) 68 | go _ pa (App op t es) = (n, app op t es1) 69 | where (ns,es1) = unzip $ map (goA lo1 pa) es 70 | n = foldr (liftDS both) zeroDS ns 71 | lo1 = op `elem` [Parallel, Sequential, EparFor, ForLoop, WhileLoop, For, While] 72 | go _ _ e@(Lambda u _) | u == v = (zeroDS, fromRExpr e) 73 | go lo pa (Lambda u e) = (lamDS lo n1, lambda u e1) 74 | where (n1,e1) = goA False pa e 75 | go _ _ LetFun{} = error "Pushing let is not supported for LetFun." 76 | 77 | lamDS :: Bool -> DSCount -> DSCount 78 | lamDS lo (DS d s) = if lo then DS (both d d) (s+s) else DS d s -- A loop body may be run several times 79 | 80 | zeroDS, oneDS :: DSCount 81 | zeroDS = DS (OC 0 0) 0 82 | oneDS = DS (OC 1 1) 1 83 | 84 | liftDS :: (OCount -> OCount -> OCount) -> DSCount -> DSCount -> DSCount 85 | liftDS df l r = DS (dynamic l `df` dynamic r) (static l + static r) 86 | 87 | both, oneOf :: OCount -> OCount -> OCount 88 | both (OC ll hl) (OC lr hr) = OC (ll+lr) (hl+hr) 89 | oneOf (OC ll hl) (OC lr hr) = OC (min ll lr) (max hl hr) 90 | 91 | norm :: DSCount -> DSCount 92 | norm (DS (OC l h) s) = DS (OC (min 1 l) (min 1 h)) (min s 1) 93 | -------------------------------------------------------------------------------- /src/clib/include/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 | void* buffer; /* pointer to the buffer of elements */ 49 | int32_t length; /* number of elements in the array */ 50 | }; 51 | 52 | /// Allocate and initialize a struct array if we did not have one already 53 | static inline struct array *allocArray(struct array* src) { 54 | log_1("allocArray %p\n", src); 55 | if (src == NULL) { 56 | src = malloc(sizeof(struct array)); 57 | src->buffer = NULL; 58 | src->length = 0; 59 | } 60 | return src; 61 | } 62 | 63 | /// Resizing an existing array. 64 | static inline void* resizeArray(void* arr, int32_t size, int32_t len) { 65 | log_3("resize %p with size %d and len %d\n", arr, size, len); 66 | return realloc(arr, len*size); 67 | } 68 | 69 | /// Array (re)initialization for flat arrays. 70 | static inline void* initArray(void* arr, int32_t arrLen, int32_t size, int32_t newLen) { 71 | log_4("initArray %p with arrlen %d size %d newLen %d\n", arr, arrLen, size, newLen); 72 | if (newLen != arrLen) 73 | arr = resizeArray(arr, size, newLen); 74 | return arr; 75 | } 76 | 77 | /// Free a flat array or an array where all the arrays it contains have been free'd already. 78 | // TODO: Think about arrays escaping from their scope. 79 | static inline void freeArray(void* arr) { 80 | log_1("freeArray %p\n", arr); 81 | free(arr); 82 | } 83 | 84 | /// Deep array copy to a given position for flat arrays. 85 | static inline void* copyArrayPos(void* dst, int32_t dstLen, int32_t size, void* src, int32_t srcLen, int32_t pos) { 86 | if (srcLen > 0) 87 | memcpy(dst + pos * size, src, srcLen * size); 88 | return dst; 89 | } 90 | 91 | /// Deep array copy for flat arrays. 92 | static inline void* copyArray(void* dst, int32_t dstLen, int32_t size, void* src, int32_t srcLen) { 93 | return copyArrayPos(dst, dstLen, size, src, srcLen, 0); 94 | } 95 | 96 | /// Combined init and copy for flat arrays. 97 | static inline void* initCopyArray(void* dst, int32_t dstLen, int32_t size, void* src, int32_t srcLen) { 98 | assert((src || !srcLen) && "source array not initialized"); 99 | assert((src != dst || srcLen == dstLen) && "same source as destination but with different lengths"); 100 | 101 | dst = initArray(dst, dstLen, size, srcLen); 102 | return copyArrayPos(dst, dstLen, size, src, srcLen, 0); 103 | } 104 | #endif 105 | -------------------------------------------------------------------------------- /src/Feldspar/Core/Middleend/PassManager.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# OPTIONS_GHC -Wno-incomplete-patterns #-} 3 | 4 | -- 5 | -- Copyright (c) 2019, 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 | -- 31 | 32 | module Feldspar.Core.Middleend.PassManager 33 | ( Prog(..) 34 | , addWrBefore 35 | , addWrAfter 36 | , setStopBefore 37 | , setStopAfter 38 | , addSkip 39 | , passC 40 | , passS 41 | , passT 42 | , evalPasses 43 | ) where 44 | 45 | import Feldspar.Compiler.Options (Pass, PassCtrl(..), Pretty(..)) 46 | 47 | data Prog a b = Prog (Maybe a) [String] b 48 | deriving Show 49 | 50 | addWrBefore :: PassCtrl -> Pass -> PassCtrl 51 | addWrBefore ctrl p = ctrl{wrBefore = p : wrBefore ctrl} 52 | 53 | addWrAfter :: PassCtrl -> Pass -> PassCtrl 54 | addWrAfter ctrl p = ctrl{wrAfter = p : wrAfter ctrl} 55 | 56 | setStopBefore :: PassCtrl -> Pass -> PassCtrl 57 | setStopBefore ctrl p = ctrl{stopBefore = [p]} 58 | 59 | setStopAfter :: PassCtrl -> Pass -> PassCtrl 60 | setStopAfter ctrl p = ctrl{stopAfter = [p]} 61 | 62 | addSkip :: PassCtrl -> Pass -> PassCtrl 63 | addSkip ctrl p = ctrl{skip = p : skip ctrl} 64 | 65 | prOrStop :: (Pretty a, Eq b, Show b) => String -> [b] -> [b] -> b -> Prog a c -> Prog a c 66 | prOrStop pos prs stop pass (Prog (Just p) ss s) 67 | = Prog (if pass `elem` stop then Nothing else Just p) 68 | (ss ++ [preamble ++ pretty p ++ "\n" | pass `elem` prs]) 69 | s 70 | where preamble = "\n========== " ++ pos ++ " " ++ show pass ++ " ==========\n\n" 71 | prOrStop _ _ _ _ prog = prog 72 | 73 | runPassC :: Eq b => [b] -> b -> (a -> a) -> Prog a c -> Prog a c 74 | runPassC skips pass f p = if pass `elem` skips then p else runPassT f p 75 | 76 | runPassT :: (a -> b) -> Prog a c -> Prog b c 77 | runPassT f (Prog p ss s) = Prog (fmap f p) ss s 78 | 79 | runPassS :: Eq b => [b] -> b -> ((c,a) -> (c,a)) -> Prog a c -> Prog a c 80 | runPassS skips pass f (Prog (Just p) ss s) 81 | | pass `notElem` skips = Prog (Just p1) ss s1 82 | where (s1,p1) = f (s,p) 83 | 84 | passC :: Pretty a => PassCtrl -> Pass -> (a -> a) -> Prog a c -> Prog a c 85 | passC ctrl pass f = prOrStop "After" (wrAfter ctrl) (stopAfter ctrl) pass 86 | . runPassC (skip ctrl) pass f 87 | . prOrStop "Before" (wrBefore ctrl) (stopBefore ctrl) pass 88 | 89 | passT :: (Pretty a, Pretty d) => PassCtrl -> Pass -> (a -> d) -> Prog a c -> Prog d c 90 | passT ctrl pass f = prOrStop "After" (wrAfter ctrl) (stopAfter ctrl) pass 91 | . runPassT f 92 | . prOrStop "Before" (wrBefore ctrl) (stopBefore ctrl) pass 93 | 94 | passS :: Pretty a => PassCtrl -> Pass -> ((c,a) -> (c,a)) -> Prog a c -> Prog a c 95 | passS ctrl pass f = prOrStop "After" (wrAfter ctrl) (stopAfter ctrl) pass 96 | . runPassS (skip ctrl) pass f 97 | . prOrStop "Before" (wrBefore ctrl) (stopBefore ctrl) pass 98 | 99 | evalPasses :: c -> (Prog a c -> Prog b c) -> a -> ([String], Maybe b) 100 | evalPasses s f p = case f $ Prog (Just p) [] s of 101 | Prog prg ss _ -> (ss, prg) 102 | -------------------------------------------------------------------------------- /src/Feldspar/Option.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# LANGUAGE FlexibleInstances #-} 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.Option where 35 | 36 | 37 | 38 | import qualified Prelude 39 | import Control.Applicative (Applicative(..)) 40 | import Control.Monad 41 | 42 | import Feldspar.Core.Reify (Syntactic(..)) 43 | import Feldspar hiding (desugar, sugar) 44 | import Feldspar.Mutable 45 | 46 | 47 | data Option a = Option { isSome :: Data Bool, fromSome :: a } 48 | 49 | instance Syntax a => Syntactic (Option a) where 50 | type Internal (Option a) = Tuple '[Bool, Internal a] 51 | desugar = desugar . desugarOption . fmap resugar 52 | sugar = fmap resugar . sugarOption . sugar 53 | 54 | instance Functor Option 55 | where 56 | fmap f opt = opt {fromSome = f (fromSome opt)} 57 | 58 | instance Applicative Option 59 | where 60 | pure = return 61 | (<*>) = ap 62 | 63 | instance Monad Option 64 | where 65 | return = some 66 | a >>= f = b { isSome = isSome a ? isSome b $ false } 67 | where 68 | b = f (fromSome a) 69 | 70 | 71 | 72 | -- | One-layer desugaring of 'Option' 73 | desugarOption :: Type a => Option (Data a) -> Data (Tuple '[Bool, a]) 74 | desugarOption a = resugar $ twotup (isSome a) (fromSome a) 75 | 76 | -- | One-layer sugaring of 'Option' 77 | sugarOption :: Type a => Data (Tuple '[Bool, a]) -> Option (Data a) 78 | sugarOption (resugar -> t) = Option (nfst t) (nsnd' t) 79 | where -- Workaround for loss of type information with resugar. 80 | -- FIXME: GHC 8.8: Remove nsnd' and put a typesignature: 81 | -- sugarOption (resugar -> (t :: Tuple '[a, b])) 82 | nsnd' :: Tuple '[a, b] -> b 83 | nsnd' = nsnd 84 | 85 | some :: a -> Option a 86 | some = Option true 87 | 88 | none :: Syntax a => Option a 89 | none = Option false (err "fromSome: none") 90 | 91 | option :: Syntax b => b -> (a -> b) -> Option a -> b 92 | option noneCase someCase opt = isSome opt 93 | ? someCase (fromSome opt) 94 | $ noneCase 95 | 96 | optionM :: Syntax b => M b -> (a -> M b) -> Option a -> M b 97 | optionM noneCase someCase opt = ifM (isSome opt) 98 | (someCase (fromSome opt)) 99 | noneCase 100 | 101 | oplus :: Syntax a => Option a -> Option a -> Option a 102 | oplus a b = isSome a ? a $ b 103 | 104 | 105 | 106 | -------------------------------------------------------------------------------- 107 | -- * Conditional choice operator 108 | -------------------------------------------------------------------------------- 109 | 110 | -- http://zenzike.com/posts/2011-08-01-the-conditional-choice-operator 111 | 112 | -- | Conditional choice operator. Can be used together with ' prog :: Data Index -> Data Index 116 | -- > prog a 117 | -- > = a+1 ?> a+2 ?> a+3 ?> a+4 ?> a+5 122 | (?>) :: Data Bool -> a -> Option a 123 | cond ?> a = Option (not cond) a 124 | 125 | ( a -> Option a -> a 126 | a 130 | -------------------------------------------------------------------------------- /src/Feldspar/Mutable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE GADTs #-} 4 | 5 | -- | Mutable data structures, etc. 6 | 7 | module Feldspar.Mutable 8 | ( module Mutable 9 | , Buffer (..) 10 | , initBuffer' 11 | , initBuffer 12 | , newBuffer 13 | , newBuffer_ 14 | , tM 15 | , initBuffer2 16 | 17 | -- * Mutable multidimensional arrays 18 | , MDArr (..) 19 | , newMDArr 20 | , getMDArr 21 | , setMDArr 22 | , storableToMDArr 23 | , freezeMDArr 24 | ) where 25 | 26 | import qualified Prelude 27 | 28 | import Feldspar 29 | import Feldspar.Core.Language as Mutable 30 | import Feldspar.Vector 31 | 32 | -- | Indexable cyclic buffer 33 | data Buffer a = Buffer 34 | { indexBuf :: Data Index -> M a 35 | , putBuf :: a -> M () 36 | , withBuf :: forall b . Syntax b => (Pull DIM1 a -> M b) -> M b 37 | } 38 | 39 | -- Another option would be to represent a buffer as its state (the counter and the array), but the 40 | -- above representation leaves room for other implementations. 41 | 42 | --- | Create a new cyclic buffer 43 | initBuffer' :: forall a . Syntax a => Data (MArr (Internal a)) -> M (Buffer a) 44 | initBuffer' buf = do 45 | l <- arrLength buf 46 | ir <- newRef 0 47 | let get j = do 48 | i <- getRef ir 49 | fmap sugar $ getArr buf $ calcIndex l i j 50 | put a = do 51 | i <- getRef ir 52 | setRef ir ((i+1) `mod` l) 53 | setArr buf i $ desugar a 54 | with :: Syntax b => (Pull DIM1 a -> M b) -> M b 55 | with f = do 56 | i <- getRef ir 57 | withArray buf (f . freeze i) 58 | return (Buffer get put with) 59 | where 60 | calcIndex l i j = (l+i-j-1) `mod` l 61 | 62 | freeze :: Syntax b => Data Index -> Data [Internal b] -> Pull DIM1 b 63 | freeze i = permute (\l -> calcIndex l i) . map sugar . thawPull1 64 | 65 | -- | Create a new cyclic buffer initalized by the given vector (which also determines the size) 66 | initBuffer :: Syntax a => Pull DIM1 a -> M (Buffer a) 67 | initBuffer buf = thawArray (freezePull1 $ map desugar buf) >>= initBuffer' 68 | 69 | -- | Create a new cyclic buffer of the given length initialized by the given element 70 | newBuffer :: Syntax a => Data Length -> a -> M (Buffer a) 71 | newBuffer l init = newArr l (desugar init) >>= initBuffer' 72 | 73 | -- | Create a new cyclic buffer of the given length without initialization 74 | newBuffer_ :: Syntax a => Data Length -> M (Buffer a) 75 | newBuffer_ l = newArr_ l >>= initBuffer' 76 | 77 | tM :: Patch a a -> Patch (M a) (M a) 78 | tM _ = id 79 | 80 | initBuffer2' :: forall a . Syntax a => Data Length -> Data (MArr (Internal a)) 81 | -> M (Buffer a) 82 | initBuffer2' l buf = do 83 | ir <- newRef 0 84 | let get j = do 85 | i <- getRef ir 86 | fmap sugar $ getArr buf (j + i) 87 | put a = do 88 | i <- getRef ir 89 | setRef ir ((i+1) `mod` l) 90 | let a' = desugar a 91 | setArr buf i a' 92 | setArr buf (i+l) a' 93 | with :: Syntax b => (Pull DIM1 a -> M b) -> M b 94 | with f = do 95 | i <- getRef ir 96 | withArray buf (f . freeze i) 97 | return (Buffer get put with) 98 | where 99 | freeze :: Syntax b => Data Index -> Data [Internal b] -> Pull DIM1 b 100 | freeze i = take l . drop i . map sugar . thawPull1 101 | 102 | -- | Create a new cyclic buffer. This implementation uses a buffer twice 103 | -- as long as necessary to avoid all modulus operations when accessing 104 | -- the elements. 105 | initBuffer2 :: Syntax a => Pull DIM1 a -> M (Buffer a) 106 | initBuffer2 buf = thawArray (freezePush1 $ dup $ map desugar buf) >>= 107 | initBuffer2' (length buf) 108 | 109 | -- Mutable multidimensional arrays 110 | 111 | data MDArr sh a = MDArr (Data (MArr (Internal a))) (Shape sh) 112 | 113 | newMDArr :: Syntax a => Shape sh -> a -> M (MDArr sh a) 114 | newMDArr sh a = do arr <- newArr (size sh) (desugar a) 115 | return (MDArr arr sh) 116 | 117 | getMDArr :: Syntax a => MDArr sh a -> Shape sh -> M a 118 | getMDArr (MDArr marr sh) shi = do 119 | let i = toIndex shi sh 120 | fmap sugar (getArr marr i) 121 | 122 | setMDArr :: Syntax a => MDArr sh a -> Shape sh -> a -> M () 123 | setMDArr (MDArr marr sh) shi a = do 124 | let i = toIndex shi sh 125 | setArr marr i (desugar a) 126 | 127 | storableToMDArr :: (Storable vec, VecShape vec ~ sh, Syntax a) 128 | => vec a -> M (MDArr sh a) 129 | storableToMDArr vec = do marr <- thawArray arr 130 | return (MDArr marr sh) 131 | where Manifest arr sh = store vec 132 | 133 | freezeMDArr :: (Syntax a) => MDArr sh a -> M (Manifest sh a) 134 | freezeMDArr (MDArr marr sh) = do 135 | arr <- freezeArray marr 136 | return (Manifest arr sh) 137 | -------------------------------------------------------------------------------- /tests/gold/deepArrayCopy.c: -------------------------------------------------------------------------------- 1 | #include "deepArrayCopy.h" 2 | 3 | 4 | global struct awl_awl_unsignedS32 * copyArrayPos_awl_awl_unsignedS32(global struct awl_awl_unsignedS32 * dst, int32_t dstLen, global 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 | global struct awl_awl_unsignedS32 * copyArray_awl_awl_unsignedS32(global struct awl_awl_unsignedS32 * dst, int32_t dstLen, global 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 | global struct awl_awl_unsignedS32 * initCopyArray_awl_awl_unsignedS32(global struct awl_awl_unsignedS32 * dst, int32_t dstLen, global 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 | global struct awl_unsignedS32 * copyArrayPos_awl_unsignedS32(global struct awl_unsignedS32 * dst, int32_t dstLen, global 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 | global struct awl_unsignedS32 * copyArray_awl_unsignedS32(global struct awl_unsignedS32 * dst, int32_t dstLen, global struct awl_unsignedS32 * src, int32_t srcLen) 39 | { 40 | dst = copyArrayPos_awl_unsignedS32(dst, dstLen, src, srcLen, 0); 41 | return(dst); 42 | } 43 | 44 | global struct awl_unsignedS32 * initCopyArray_awl_unsignedS32(global struct awl_unsignedS32 * dst, int32_t dstLen, global 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 | global struct awl_awl_unsignedS32 * initArray_awl_awl_unsignedS32(global 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(global 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 | global struct awl_unsignedS32 * initArray_awl_unsignedS32(global 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(global 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_2xawl_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 | -------------------------------------------------------------------------------- /src/Onnx/Onnx/AttributeProto/AttributeType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -w #-} 3 | module Onnx.AttributeProto.AttributeType (AttributeType(..)) where 4 | import Prelude ((+), (/), (.)) 5 | import qualified Prelude as Prelude' 6 | import qualified Data.Typeable as Prelude' 7 | import qualified GHC.Generics as Prelude' 8 | import qualified Data.Data as Prelude' 9 | import qualified Text.ProtocolBuffers.Header as P' 10 | 11 | data AttributeType = UNDEFINED 12 | | FLOAT 13 | | INT 14 | | STRING 15 | | TENSOR 16 | | GRAPH 17 | | SPARSE_TENSOR 18 | | FLOATS 19 | | INTS 20 | | STRINGS 21 | | TENSORS 22 | | GRAPHS 23 | | SPARSE_TENSORS 24 | deriving (Prelude'.Read, Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, 25 | Prelude'.Generic) 26 | 27 | instance P'.Mergeable AttributeType 28 | 29 | instance Prelude'.Bounded AttributeType where 30 | minBound = UNDEFINED 31 | maxBound = SPARSE_TENSORS 32 | 33 | instance P'.Default AttributeType where 34 | defaultValue = UNDEFINED 35 | 36 | toMaybe'Enum :: Prelude'.Int -> P'.Maybe AttributeType 37 | toMaybe'Enum 0 = Prelude'.Just UNDEFINED 38 | toMaybe'Enum 1 = Prelude'.Just FLOAT 39 | toMaybe'Enum 2 = Prelude'.Just INT 40 | toMaybe'Enum 3 = Prelude'.Just STRING 41 | toMaybe'Enum 4 = Prelude'.Just TENSOR 42 | toMaybe'Enum 5 = Prelude'.Just GRAPH 43 | toMaybe'Enum 11 = Prelude'.Just SPARSE_TENSOR 44 | toMaybe'Enum 6 = Prelude'.Just FLOATS 45 | toMaybe'Enum 7 = Prelude'.Just INTS 46 | toMaybe'Enum 8 = Prelude'.Just STRINGS 47 | toMaybe'Enum 9 = Prelude'.Just TENSORS 48 | toMaybe'Enum 10 = Prelude'.Just GRAPHS 49 | toMaybe'Enum 12 = Prelude'.Just SPARSE_TENSORS 50 | toMaybe'Enum _ = Prelude'.Nothing 51 | 52 | instance Prelude'.Enum AttributeType where 53 | fromEnum UNDEFINED = 0 54 | fromEnum FLOAT = 1 55 | fromEnum INT = 2 56 | fromEnum STRING = 3 57 | fromEnum TENSOR = 4 58 | fromEnum GRAPH = 5 59 | fromEnum SPARSE_TENSOR = 11 60 | fromEnum FLOATS = 6 61 | fromEnum INTS = 7 62 | fromEnum STRINGS = 8 63 | fromEnum TENSORS = 9 64 | fromEnum GRAPHS = 10 65 | fromEnum SPARSE_TENSORS = 12 66 | toEnum 67 | = P'.fromMaybe (Prelude'.error "hprotoc generated code: toEnum failure for type Onnx.AttributeProto.AttributeType") . 68 | toMaybe'Enum 69 | succ UNDEFINED = FLOAT 70 | succ FLOAT = INT 71 | succ INT = STRING 72 | succ STRING = TENSOR 73 | succ TENSOR = GRAPH 74 | succ GRAPH = SPARSE_TENSOR 75 | succ SPARSE_TENSOR = FLOATS 76 | succ FLOATS = INTS 77 | succ INTS = STRINGS 78 | succ STRINGS = TENSORS 79 | succ TENSORS = GRAPHS 80 | succ GRAPHS = SPARSE_TENSORS 81 | succ _ = Prelude'.error "hprotoc generated code: succ failure for type Onnx.AttributeProto.AttributeType" 82 | pred FLOAT = UNDEFINED 83 | pred INT = FLOAT 84 | pred STRING = INT 85 | pred TENSOR = STRING 86 | pred GRAPH = TENSOR 87 | pred SPARSE_TENSOR = GRAPH 88 | pred FLOATS = SPARSE_TENSOR 89 | pred INTS = FLOATS 90 | pred STRINGS = INTS 91 | pred TENSORS = STRINGS 92 | pred GRAPHS = TENSORS 93 | pred SPARSE_TENSORS = GRAPHS 94 | pred _ = Prelude'.error "hprotoc generated code: pred failure for type Onnx.AttributeProto.AttributeType" 95 | 96 | instance P'.Wire AttributeType where 97 | wireSize ft' enum = P'.wireSize ft' (Prelude'.fromEnum enum) 98 | wirePut ft' enum = P'.wirePut ft' (Prelude'.fromEnum enum) 99 | wireGet 14 = P'.wireGetEnum toMaybe'Enum 100 | wireGet ft' = P'.wireGetErr ft' 101 | wireGetPacked 14 = P'.wireGetPackedEnum toMaybe'Enum 102 | wireGetPacked ft' = P'.wireGetErr ft' 103 | 104 | instance P'.GPB AttributeType 105 | 106 | instance P'.MessageAPI msg' (msg' -> AttributeType) AttributeType where 107 | getVal m' f' = f' m' 108 | 109 | instance P'.ReflectEnum AttributeType where 110 | reflectEnum 111 | = [(0, "UNDEFINED", UNDEFINED), (1, "FLOAT", FLOAT), (2, "INT", INT), (3, "STRING", STRING), (4, "TENSOR", TENSOR), 112 | (5, "GRAPH", GRAPH), (11, "SPARSE_TENSOR", SPARSE_TENSOR), (6, "FLOATS", FLOATS), (7, "INTS", INTS), (8, "STRINGS", STRINGS), 113 | (9, "TENSORS", TENSORS), (10, "GRAPHS", GRAPHS), (12, "SPARSE_TENSORS", SPARSE_TENSORS)] 114 | reflectEnumInfo _ 115 | = P'.EnumInfo (P'.makePNF (P'.pack ".onnx.AttributeProto.AttributeType") [] ["Onnx", "AttributeProto"] "AttributeType") 116 | ["Onnx", "AttributeProto", "AttributeType.hs"] 117 | [(0, "UNDEFINED"), (1, "FLOAT"), (2, "INT"), (3, "STRING"), (4, "TENSOR"), (5, "GRAPH"), (11, "SPARSE_TENSOR"), (6, "FLOATS"), 118 | (7, "INTS"), (8, "STRINGS"), (9, "TENSORS"), (10, "GRAPHS"), (12, "SPARSE_TENSORS")] 119 | Prelude'.False 120 | 121 | instance P'.TextType AttributeType where 122 | tellT = P'.tellShow 123 | getT = P'.getRead -------------------------------------------------------------------------------- /src/Onnx/Onnx/TensorProto/Segment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -w #-} 3 | module Onnx.TensorProto.Segment (Segment(..)) where 4 | import Prelude ((+), (/), (++), (.)) 5 | import qualified Prelude as Prelude' 6 | import qualified Data.Typeable as Prelude' 7 | import qualified GHC.Generics as Prelude' 8 | import qualified Data.Data as Prelude' 9 | import qualified Text.ProtocolBuffers.Header as P' 10 | 11 | data Segment = Segment{begin :: !(P'.Maybe P'.Int64), end :: !(P'.Maybe P'.Int64)} 12 | deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) 13 | 14 | instance P'.Mergeable Segment where 15 | mergeAppend (Segment x'1 x'2) (Segment y'1 y'2) = Segment (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) 16 | 17 | instance P'.Default Segment where 18 | defaultValue = Segment P'.defaultValue P'.defaultValue 19 | 20 | instance P'.Wire Segment where 21 | wireSize ft' self'@(Segment x'1 x'2) 22 | = case ft' of 23 | 10 -> calc'Size 24 | 11 -> P'.prependMessageSize calc'Size 25 | _ -> P'.wireSizeErr ft' self' 26 | where 27 | calc'Size = (P'.wireSizeOpt 1 3 x'1 + P'.wireSizeOpt 1 3 x'2) 28 | wirePutWithSize ft' self'@(Segment x'1 x'2) 29 | = case ft' of 30 | 10 -> put'Fields 31 | 11 -> put'FieldsSized 32 | _ -> P'.wirePutErr ft' self' 33 | where 34 | put'Fields = P'.sequencePutWithSize [P'.wirePutOptWithSize 8 3 x'1, P'.wirePutOptWithSize 16 3 x'2] 35 | put'FieldsSized 36 | = let size' = Prelude'.fst (P'.runPutM put'Fields) 37 | put'Size 38 | = do 39 | P'.putSize size' 40 | Prelude'.return (P'.size'WireSize size') 41 | in P'.sequencePutWithSize [put'Size, put'Fields] 42 | wireGet ft' 43 | = case ft' of 44 | 10 -> P'.getBareMessageWith (P'.catch'Unknown' P'.discardUnknown update'Self) 45 | 11 -> P'.getMessageWith (P'.catch'Unknown' P'.discardUnknown update'Self) 46 | _ -> P'.wireGetErr ft' 47 | where 48 | update'Self wire'Tag old'Self 49 | = case wire'Tag of 50 | 8 -> Prelude'.fmap (\ !new'Field -> old'Self{begin = Prelude'.Just new'Field}) (P'.wireGet 3) 51 | 16 -> Prelude'.fmap (\ !new'Field -> old'Self{end = Prelude'.Just new'Field}) (P'.wireGet 3) 52 | _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self 53 | 54 | instance P'.MessageAPI msg' (msg' -> Segment) Segment where 55 | getVal m' f' = f' m' 56 | 57 | instance P'.GPB Segment 58 | 59 | instance P'.ReflectDescriptor Segment where 60 | getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [8, 16]) 61 | reflectDescriptorInfo _ 62 | = Prelude'.read 63 | "DescriptorInfo {descName = ProtoName {protobufName = FIName \".onnx.TensorProto.Segment\", haskellPrefix = [], parentModule = [MName \"Onnx\",MName \"TensorProto\"], baseName = MName \"Segment\"}, descFilePath = [\"Onnx\",\"TensorProto\",\"Segment.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".onnx.TensorProto.Segment.begin\", haskellPrefix' = [], parentModule' = [MName \"Onnx\",MName \"TensorProto\",MName \"Segment\"], baseName' = FName \"begin\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 3}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".onnx.TensorProto.Segment.end\", haskellPrefix' = [], parentModule' = [MName \"Onnx\",MName \"TensorProto\",MName \"Segment\"], baseName' = FName \"end\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 3}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False, jsonInstances = False}" 64 | 65 | instance P'.TextType Segment where 66 | tellT = P'.tellSubMessage 67 | getT = P'.getSubMessage 68 | 69 | instance P'.TextMsg Segment where 70 | textPut msg 71 | = do 72 | P'.tellT "begin" (begin msg) 73 | P'.tellT "end" (end msg) 74 | textGet 75 | = do 76 | mods <- P'.sepEndBy (P'.choice [parse'begin, parse'end]) P'.spaces 77 | Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) 78 | where 79 | parse'begin 80 | = P'.try 81 | (do 82 | v <- P'.getT "begin" 83 | Prelude'.return (\ o -> o{begin = v})) 84 | parse'end 85 | = P'.try 86 | (do 87 | v <- P'.getT "end" 88 | Prelude'.return (\ o -> o{end = v})) --------------------------------------------------------------------------------