├── LICENSE ├── Readme.md ├── Setup.hs ├── benchmarks └── Benchmarks.hs ├── c_sources ├── common.h ├── convert.c ├── cpuid.c ├── decimate.c ├── filter.c ├── resample.c └── scale.c ├── examples └── fm │ ├── Coeffs.hs │ └── fm.hs ├── expts └── Benchmark.hs ├── hs_sources └── SDR │ ├── ArgUtils.hs │ ├── CPUID.hs │ ├── Demod.hs │ ├── FFT.hs │ ├── Filter.hs │ ├── FilterDesign.hs │ ├── FilterInternal.hs │ ├── NetworkStream.hs │ ├── PipeUtils.hs │ ├── Plot.hs │ ├── Pulse.hs │ ├── RTLSDRStream.hs │ ├── Serialize.hs │ ├── Util.hs │ └── VectorUtils.hs ├── sdr.cabal └── tests └── TestSuite.hs /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Adam Walker 2 | 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 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Adam Walker nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (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 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # SDR 2 | 3 | A Software Defined Radio library written in Haskell 4 | 5 | See the [blog post](https://adamwalker.github.io/Introducing-SDR/). 6 | 7 | # Features 8 | * Write software defined radio applications in Haskell 9 | * Signal processing blocks can be chained together using the [Pipes](https://hackage.haskell.org/package/pipes) library 10 | * Zero copy design 11 | * Signal processing functions are implemented in both Haskell and C: 12 | * Optimised C implementations of signal processing functions that utilise SIMD instructions 13 | * Performance of Haskell signal processing functions within a factor of 2 of C (without SIMD) thanks to the vector library, stream fusion and ghc's LLVM backend 14 | * Can filter, decimate and resample 15 | * Helper functions for FIR filter design using window functions and plotting of the frequency response 16 | * FFTs using [FFTW](http://www.fftw.org) 17 | * Line and waterfall plots using OpenGL 18 | * FM demodulation 19 | * PulseAudio sound sink 20 | * [rtl-sdr](http://sdr.osmocom.org/trac/wiki/rtl-sdr) and [BladeRF](https://nuand.com/) based radio sources/sinks supported and other sources are easily added 21 | * Extensive benchmark and test suites of signal processing functions 22 | 23 | See [sdr-apps](https://github.com/adamwalker/sdr-apps) for a collection of simple apps built on the library, [sdr-demo](https://github.com/adamwalker/sdr-demo) for a demo application and [bladerf-sdr-apps](https://github.com/adamwalker/bladerf-sdr-apps) to get started with the BladeRF. 24 | 25 | # Screenshot 26 | A chunk of the FM broadcast spectrum. Captured with an RTLSDR device and drawn as a waterfall using the [Plot](https://github.com/adamwalker/sdr/blob/master/hs_sources/SDR/Plot.hs) module. 27 | 28 | ![Screenshot](https://raw.githubusercontent.com/adamwalker/sdr/screenshots/screenshots/screenshot.png?raw=true) 29 | 30 | 31 | # Getting Started 32 | 33 | ## Installation 34 | 35 | This library will only build and run on 64 bit x86 Linux systems. 36 | 37 | You can install it from [Hackage](https://hackage.haskell.org/package/sdr): 38 | ``` 39 | cabal install sdr 40 | ``` 41 | 42 | If you want to use the BladeRF, you will also need [bladerf-pipes](https://github.com/adamwalker/bladerf-pipes) and [hlibBladeRF](https://github.com/victoredwardocallaghan/hlibBladeRF). 43 | 44 | ## Example Applications 45 | 46 | A collection of simple apps can be found [here](https://github.com/adamwalker/sdr-apps). These include an FM radio receiver, an OpenGL waterfall plotter and an AM radio receiver that can be used to listen to [Airband](https://en.wikipedia.org/wiki/Airband). 47 | 48 | Clone and build: 49 | 50 | ``` 51 | git clone https://github.com/adamwalker/sdr-apps 52 | cd sdr-apps 53 | cabal install 54 | ``` 55 | 56 | To run the FM receiver: 57 | 58 | (Assuming cabal-built binaries are in your path) 59 | ``` 60 | fm -f 61 | ``` 62 | 63 | To run the waterfall plot: 64 | ``` 65 | waterfall -f
-r 66 | ``` 67 | 68 | To run the AM receiver: 69 | ``` 70 | am -f
71 | ``` 72 | 73 | # Usage 74 | 75 | Documentation is available on [Hackage](https://hackage.haskell.org/package/sdr). 76 | 77 | An FM receiver: 78 | 79 | ```haskell 80 | import Control.Monad.Trans.Either 81 | import Data.Vector.Generic as VG 82 | import Pipes 83 | import qualified Pipes.Prelude as P 84 | 85 | 86 | import SDR.Filter 87 | import SDR.RTLSDRStream 88 | import SDR.Util 89 | import SDR.Demod 90 | import SDR.Pulse 91 | import SDR.CPUID 92 | 93 | --The filter coefficients are stored in another module 94 | import Coeffs 95 | 96 | samples = 8192 97 | frequency = 105700000 98 | 99 | main = eitherT putStrLn return $ do 100 | 101 | info <- lift getCPUInfo 102 | 103 | str <- sdrStream (defaultRTLSDRParams frequency 1280000) 1 (fromIntegral samples * 2) 104 | 105 | lift $ do 106 | 107 | sink <- pulseAudioSink 108 | 109 | deci <- fastDecimatorC info 8 coeffsRFDecim 110 | resp <- fastResamplerR info 3 10 coeffsAudioResampler 111 | filt <- fastFilterSymR info coeffsAudioFilter 112 | 113 | runEffect $ str 114 | >-> P.map (interleavedIQUnsignedByteToFloatFast info) 115 | >-> firDecimator deci samples 116 | >-> fmDemod 117 | >-> firResampler resp samples 118 | >-> firFilter filt samples 119 | >-> P.map (VG.map (* 0.2)) 120 | >-> sink 121 | ``` 122 | 123 | # Disclaimer 124 | I started this project to learn about signal processing. I still have no idea what I'm doing. 125 | 126 | Only tested on Arch Linux. 127 | 128 | If you actually use this library for anything, let me know: adamwalker10@gmail.com 129 | 130 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmarks/Benchmarks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | import Control.Monad.Primitive 4 | import Control.Monad 5 | import Foreign.C.Types 6 | import Foreign.Ptr 7 | import Unsafe.Coerce 8 | import Data.Complex 9 | 10 | import qualified Data.Vector.Generic as VG 11 | import qualified Data.Vector.Generic.Mutable as VGM 12 | import qualified Data.Vector.Storable as VS 13 | import qualified Data.Vector.Storable.Mutable as VSM 14 | import qualified Data.Vector.Fusion.Bundle as VFS 15 | import qualified Data.Vector.Fusion.Stream.Monadic as VFSM 16 | 17 | import Foreign.Storable.Complex 18 | import Criterion.Main 19 | 20 | import SDR.FilterInternal 21 | import SDR.Util 22 | import SDR.CPUID 23 | 24 | theBench :: IO () 25 | theBench = do 26 | --Setup 27 | let size = 16384 28 | numCoeffs = 128 29 | num = size - numCoeffs + 1 30 | decimation = 4 31 | interpolation = 3 32 | numCoeffsDiv2 = 64 33 | 34 | coeffsList :: [Float] 35 | coeffsList = take numCoeffs [0 ..] 36 | coeffs :: VS.Vector Float 37 | coeffs = VG.fromList $ take numCoeffs [0 ..] 38 | coeffsSym :: VS.Vector Float 39 | coeffsSym = VG.fromList $ take numCoeffsDiv2 [0 ..] 40 | inBuf :: VS.Vector Float 41 | inBuf = VG.fromList $ take size [0 ..] 42 | inBufComplex :: VS.Vector (Complex Float) 43 | inBufComplex = VG.fromList $ take size $ do 44 | i <- [0..] 45 | return $ i :+ i 46 | inBufRTLSDR :: VS.Vector CUChar 47 | inBufRTLSDR = VG.fromList $ take size [0 ..] 48 | inBufBladeRF :: VS.Vector CShort 49 | inBufBladeRF = VG.fromList $ take size [0 ..] 50 | 51 | numConv = 16386 52 | inBufConv :: VS.Vector CUChar 53 | inBufConv = VG.fromList $ take size $ concat $ repeat [0 .. 255] 54 | 55 | duplicate :: [a] -> [a] 56 | duplicate = concatMap func 57 | where func x = [x, x] 58 | 59 | coeffs2 :: VS.Vector Float 60 | coeffs2 = VG.fromList $ duplicate $ take numCoeffs [0 ..] 61 | 62 | outBuf :: VS.MVector RealWorld Float <- VGM.new size 63 | outBufComplex :: VS.MVector RealWorld (Complex Float) <- VGM.new size 64 | 65 | info <- getCPUInfo 66 | 67 | let hasFeatures :: [(CPUInfo -> Bool, a)] -> [a] 68 | hasFeatures = map snd . filter (($ info) . fst) 69 | 70 | resampler3 <- resampleCRR2 interpolation decimation coeffsList 71 | resampler4 <- resampleCSSERR interpolation decimation coeffsList 72 | resampler5 <- resampleCAVXRR interpolation decimation coeffsList 73 | 74 | resampler3C <- resampleCRC interpolation decimation coeffsList 75 | resampler4C <- resampleCSSERC interpolation decimation coeffsList 76 | resampler5C <- resampleCAVXRC interpolation decimation coeffsList 77 | 78 | --Benchmarks 79 | defaultMain [ 80 | bgroup "filter" [ 81 | bgroup "real" $ hasFeatures [ 82 | (const True, bench "highLevel" $ nfIO $ filterHighLevel coeffs num inBuf outBuf), 83 | (const True, bench "imperative1" $ nfIO $ filterImperative1 coeffs num inBuf outBuf), 84 | (const True, bench "imperative2" $ nfIO $ filterImperative2 coeffs num inBuf outBuf), 85 | (const True, bench "c" $ nfIO $ filterCRR coeffs num inBuf outBuf), 86 | (hasSSE42, bench "cSSE" $ nfIO $ filterCSSERR coeffs num inBuf outBuf), 87 | (hasSSE42, bench "cSSESym" $ nfIO $ filterCSSESymmetricRR coeffsSym num inBuf outBuf), 88 | (hasAVX, bench "cAVX" $ nfIO $ filterCAVXRR coeffs num inBuf outBuf), 89 | (hasAVX, bench "cAVXSym" $ nfIO $ filterCAVXSymmetricRR coeffsSym num inBuf outBuf) 90 | ], 91 | bgroup "complex" $ hasFeatures [ 92 | (const True, bench "highLevel" $ nfIO $ filterHighLevel coeffs num inBufComplex outBufComplex), 93 | (const True, bench "c" $ nfIO $ filterCRC coeffs num inBufComplex outBufComplex), 94 | (hasSSE42, bench "cSSE" $ nfIO $ filterCSSERC coeffs2 num inBufComplex outBufComplex), 95 | (hasSSE42, bench "cSSE2" $ nfIO $ filterCSSERC2 coeffs num inBufComplex outBufComplex), 96 | (hasSSE42, bench "cSSESym" $ nfIO $ filterCSSESymmetricRC coeffsSym num inBufComplex outBufComplex), 97 | (hasAVX, bench "cAVX" $ nfIO $ filterCAVXRC coeffs2 num inBufComplex outBufComplex), 98 | (hasAVX, bench "cAVX2" $ nfIO $ filterCAVXRC2 coeffs num inBufComplex outBufComplex), 99 | (hasAVX, bench "cAVXSym" $ nfIO $ filterCAVXSymmetricRC coeffsSym num inBufComplex outBufComplex) 100 | ] 101 | ], 102 | bgroup "decimate" [ 103 | bgroup "real" $ hasFeatures [ 104 | (const True, bench "highLevel" $ nfIO $ decimateHighLevel decimation coeffs (num `quot` decimation) inBuf outBuf), 105 | (const True, bench "c" $ nfIO $ decimateCRR decimation coeffs (num `quot` decimation) inBuf outBuf), 106 | (hasSSE42, bench "cSSE" $ nfIO $ decimateCSSERR decimation coeffs (num `quot` decimation) inBuf outBuf), 107 | (hasSSE42, bench "cSSESym" $ nfIO $ decimateCSSESymmetricRR decimation coeffsSym (num `quot` decimation) inBuf outBuf), 108 | (hasAVX, bench "cAVX" $ nfIO $ decimateCAVXRR decimation coeffs (num `quot` decimation) inBuf outBuf), 109 | (hasAVX, bench "cAVXSym" $ nfIO $ decimateCAVXSymmetricRR decimation coeffsSym (num `quot` decimation) inBuf outBuf) 110 | ], 111 | bgroup "complex" $ hasFeatures [ 112 | (const True, bench "highLevel" $ nfIO $ decimateHighLevel decimation coeffs (num `quot` decimation) inBufComplex outBufComplex), 113 | (const True, bench "c" $ nfIO $ decimateCRC decimation coeffs (num `quot` decimation) inBufComplex outBufComplex), 114 | (hasSSE42, bench "cSSE" $ nfIO $ decimateCSSERC decimation coeffs2 (num `quot` decimation) inBufComplex outBufComplex), 115 | (hasSSE42, bench "cSSE2" $ nfIO $ decimateCSSERC2 decimation coeffs (num `quot` decimation) inBufComplex outBufComplex), 116 | (hasSSE42, bench "cSSESym" $ nfIO $ decimateCSSESymmetricRC decimation coeffsSym (num `quot` decimation) inBufComplex outBufComplex), 117 | (hasAVX, bench "cAVX" $ nfIO $ decimateCAVXRC decimation coeffs2 (num `quot` decimation) inBufComplex outBufComplex), 118 | (hasAVX, bench "cAVX2" $ nfIO $ decimateCAVXRC2 decimation coeffs (num `quot` decimation) inBufComplex outBufComplex), 119 | (hasAVX, bench "cAVXSym" $ nfIO $ decimateCAVXSymmetricRC decimation coeffsSym (num `quot` decimation) inBufComplex outBufComplex) 120 | ] 121 | ], 122 | bgroup "resample" [ 123 | bgroup "real" $ hasFeatures [ 124 | (const True, bench "highLevel" $ nfIO $ resampleHighLevel interpolation decimation coeffs 0 (num `quot` decimation) inBuf outBuf), 125 | (const True, bench "c" $ nfIO $ resampleCRR (num `quot` decimation) interpolation decimation 0 coeffs inBuf outBuf), 126 | (const True, bench "c2" $ nfIO $ resampler3 (num `quot` decimation) 0 inBuf outBuf), 127 | (hasSSE42, bench "cSSE" $ nfIO $ resampler4 (num `quot` decimation) 0 inBuf outBuf), 128 | (hasAVX, bench "cAVX" $ nfIO $ resampler5 (num `quot` decimation) 0 inBuf outBuf) 129 | ], 130 | bgroup "complex" $ hasFeatures [ 131 | (const True, bench "highLevel" $ nfIO $ resampleHighLevel interpolation decimation coeffs 0 (num `quot` decimation) inBufComplex outBufComplex), 132 | (const True, bench "c" $ nfIO $ resampler3C (num `quot` decimation) 0 inBufComplex outBufComplex), 133 | (const True, bench "SSE" $ nfIO $ resampler4C (num `quot` decimation) 0 inBufComplex outBufComplex), 134 | (const True, bench "AVX" $ nfIO $ resampler5C (num `quot` decimation) 0 inBufComplex outBufComplex) 135 | ] 136 | ], 137 | bgroup "scaling" $ hasFeatures [ 138 | (const True, bench "c" $ nfIO $ scaleC 0.3 inBuf outBuf), 139 | (hasSSE42, bench "cSSE" $ nfIO $ scaleCSSE 0.3 inBuf outBuf), 140 | (hasAVX, bench "cAVX" $ nfIO $ scaleCAVX 0.3 inBuf outBuf) 141 | ], 142 | bgroup "conversion" [ 143 | bgroup "RTLSDR" $ hasFeatures [ 144 | (const True, bench "h" $ nf (interleavedIQUnsigned256ToFloat :: VS.Vector CUChar -> VS.Vector (Complex Float)) inBufRTLSDR), 145 | (const True, bench "c" $ nf interleavedIQUnsignedByteToFloat inBufRTLSDR), 146 | (hasSSE42, bench "cSSE" $ nf interleavedIQUnsignedByteToFloatSSE inBufRTLSDR), 147 | (hasAVX2, bench "cAVX" $ nf interleavedIQUnsignedByteToFloatAVX inBufRTLSDR) 148 | ], 149 | bgroup "BladeRF" $ hasFeatures [ 150 | (const True, bench "h" $ nf (interleavedIQSigned2048ToFloat :: VS.Vector CShort -> VS.Vector (Complex Float)) inBufBladeRF), 151 | (const True, bench "c" $ nf interleavedIQSignedWordToFloat inBufBladeRF), 152 | (hasSSE42, bench "cSSE" $ nf interleavedIQSignedWordToFloatSSE inBufBladeRF), 153 | (hasAVX2, bench "cAVX" $ nf interleavedIQSignedWordToFloatAVX inBufBladeRF) 154 | ] 155 | ] 156 | ] 157 | 158 | main = theBench 159 | -------------------------------------------------------------------------------- /c_sources/common.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Common functions used by filters, decimators and resamplers. 3 | * Includes real and complex dot products and SIMD horizontal additions. 4 | * TODO: better performance might be possible by avoiding unaligned memory accesses. 5 | */ 6 | 7 | #include 8 | 9 | /* 10 | * Real horizontal addition 11 | */ 12 | static inline __m128 sse_hadd_R(__m128 in){ 13 | __m128 accum; 14 | accum = _mm_hadd_ps(in, in); 15 | return _mm_hadd_ps(accum, accum); 16 | } 17 | 18 | static inline __m128 avx_hadd_R(__m256 in){ 19 | __m128 res1 = _mm256_extractf128_ps(in, 0); 20 | __m128 res2 = _mm256_extractf128_ps(in, 1); 21 | 22 | res1 = _mm_hadd_ps(res1, res1); 23 | res1 = _mm_hadd_ps(res1, res1); 24 | 25 | res2 = _mm_hadd_ps(res2, res2); 26 | res2 = _mm_hadd_ps(res2, res2); 27 | 28 | return _mm_add_ss(res1, res2); 29 | } 30 | 31 | /* 32 | * Real dot products 33 | */ 34 | static inline float dotprod_R(int num, float *a, float *b){ 35 | int i; 36 | float accum = 0; 37 | for(i=0; i 8 | #include 9 | #include 10 | 11 | /* 12 | * Conversion 13 | */ 14 | 15 | void convertC(int num, uint8_t *in, float *out){ 16 | int i; 17 | for(i=0; i 2047) res = 2047; 97 | if(res < -2048) res = -2048; 98 | 99 | out[i] = res; 100 | } 101 | } 102 | 103 | -------------------------------------------------------------------------------- /c_sources/cpuid.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void cpuid(uint32_t op, uint32_t *a, uint32_t *b, uint32_t *c, uint32_t *d){ 4 | asm volatile( 5 | "cpuid;" 6 | : "=a"(*a), "=b"(*b), "=c"(*c), "=d"(*d) 7 | : "a"(op) 8 | ); 9 | } 10 | 11 | void cpuid_extended(uint32_t op, uint32_t sub_op, uint32_t *a, uint32_t *b, uint32_t *c, uint32_t *d){ 12 | asm volatile( 13 | "cpuid;" 14 | : "=a"(*a), "=b"(*b), "=c"(*c), "=d"(*d) 15 | : "a"(op), "c"(sub_op) 16 | ); 17 | } 18 | -------------------------------------------------------------------------------- /c_sources/decimate.c: -------------------------------------------------------------------------------- 1 | /* 2 | * FIR decimation of complex and real data with real coefficients. 3 | * These exist because the pure Haskell implementations are slow. 4 | * Uses SIMD instructions for performance. 5 | */ 6 | 7 | #include 8 | #include 9 | #include 10 | 11 | #include "common.h" 12 | 13 | /* 14 | * Real coefficients, real inputs 15 | */ 16 | void decimateRR(int num, int factor, int numCoeffs, float *coeffs, float *inBuf, float *outBuf){ 17 | int i, k; 18 | for(i=0, k=0; i 8 | #include 9 | #include 10 | 11 | #include "common.h" 12 | 13 | /* 14 | * Real coefficients, real inputs 15 | */ 16 | void filterRR(int num, int numCoeffs, float *coeffs, float *inBuf, float *outBuf){ 17 | int i; 18 | for(i=0; i 8 | #include 9 | #include 10 | 11 | #include "common.h" 12 | 13 | /* 14 | * Rational downsampling 15 | */ 16 | void resampleRR(int buf_size, int coeff_size, int interpolation, int decimation, int filter_offset, float *coeffs, float *in_buf, float *out_buf){ 17 | int j, k, l; 18 | int input_offset = 0; 19 | for(k=0; k 8 | #include 9 | #include 10 | 11 | /* 12 | * Scaling 13 | */ 14 | 15 | void scale(int num, float factor, float *in_buf, float *out_buf){ 16 | int i; 17 | for(i=0; i-> P.map (interleavedIQUnsignedByteToFloatFast info) 36 | >-> firDecimator deci samples 37 | >-> fmDemod 38 | >-> firResampler resp samples 39 | >-> firFilter filt samples 40 | >-> P.map (VG.map (* 0.2)) 41 | >-> sink 42 | 43 | -------------------------------------------------------------------------------- /expts/Benchmark.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, RecordWildCards #-} 2 | 3 | import Control.Monad.Primitive 4 | import Control.Monad 5 | import Foreign.C.Types 6 | import Foreign.Ptr 7 | import Unsafe.Coerce 8 | import Data.Complex 9 | import Foreign.Marshal.Array 10 | 11 | import qualified Data.Vector.Generic as VG 12 | import qualified Data.Vector.Generic.Mutable as VGM 13 | import qualified Data.Vector.Storable as VS 14 | import qualified Data.Vector.Storable.Mutable as VSM 15 | import qualified Data.Vector.Fusion.Stream as VFS 16 | import qualified Data.Vector.Fusion.Stream.Monadic as VFSM 17 | 18 | import Foreign.Storable.Complex 19 | import Criterion.Main 20 | import Test.QuickCheck 21 | import Test.QuickCheck.Monadic 22 | 23 | -- | A class for things that can be multiplied by a scalar. 24 | class Mult a b where 25 | mult :: a -> b -> a 26 | 27 | instance (Num a) => Mult a a where 28 | mult = (*) 29 | 30 | instance (Num a) => Mult (Complex a) a where 31 | mult (x :+ y) z = (x * z) :+ (y * z) 32 | 33 | -- | Fill a mutable vector from a monadic stream 34 | {-# INLINE fill #-} 35 | fill :: (PrimMonad m, Functor m, VGM.MVector vm a) => VFS.MStream m a -> vm (PrimState m) a -> m () 36 | fill str outBuf = void $ VFSM.foldM' put 0 str 37 | where 38 | put i x = do 39 | VGM.unsafeWrite outBuf i x 40 | return $ i + 1 41 | 42 | {-# INLINE stride #-} 43 | stride :: VG.Vector v a => Int -> v a -> v a 44 | stride str inv = VG.unstream $ VFS.unfoldr func 0 45 | where 46 | len = VG.length inv 47 | func i | i >= len = Nothing 48 | | otherwise = Just (VG.unsafeIndex inv i, i + str) 49 | 50 | -- | The functions to be benchmarked 51 | 52 | -- | Filters 53 | 54 | filterHighLevel :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) => Int -> v b -> v a -> vm (PrimState m) a -> m () 55 | filterHighLevel num coeffs inBuf outBuf = fill (VFSM.generate num dotProd) outBuf 56 | where 57 | dotProd offset = VG.sum $ VG.zipWith mult (VG.unsafeDrop offset inBuf) coeffs 58 | 59 | type FilterCRR = CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 60 | type FilterRR = Int -> VS.Vector Float -> VS.Vector Float -> VS.MVector RealWorld Float -> IO () 61 | type FilterRC = Int -> VS.Vector Float -> VS.Vector (Complex Float) -> VS.MVector RealWorld (Complex Float) -> IO () 62 | 63 | filterFFIR :: FilterCRR -> FilterRR 64 | filterFFIR func num coeffs inBuf outBuf = 65 | VS.unsafeWith (unsafeCoerce coeffs) $ \cPtr -> 66 | VS.unsafeWith (unsafeCoerce inBuf) $ \iPtr -> 67 | VSM.unsafeWith (unsafeCoerce outBuf) $ \oPtr -> 68 | func (fromIntegral num) (fromIntegral $ VG.length coeffs) cPtr iPtr oPtr 69 | 70 | filterFFIC :: FilterCRR -> FilterRC 71 | filterFFIC func num coeffs inBuf outBuf = 72 | VS.unsafeWith (unsafeCoerce coeffs) $ \cPtr -> 73 | VS.unsafeWith (unsafeCoerce inBuf) $ \iPtr -> 74 | VSM.unsafeWith (unsafeCoerce outBuf) $ \oPtr -> 75 | func (fromIntegral num) (fromIntegral $ VG.length coeffs) cPtr iPtr oPtr 76 | 77 | -- | Decimation 78 | 79 | decimateHighLevel :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) => Int -> Int -> v b -> v a -> vm (PrimState m) a -> m () 80 | decimateHighLevel num factor coeffs inBuf outBuf = fill x outBuf 81 | where 82 | x = VFSM.map dotProd (VFSM.iterateN num (+ factor) 0) 83 | dotProd offset = VG.sum $ VG.zipWith mult (VG.unsafeDrop offset inBuf) coeffs 84 | 85 | type DecimateCRR = CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 86 | type DecimateRR = Int -> Int -> VS.Vector Float -> VS.Vector Float -> VS.MVector RealWorld Float -> IO () 87 | type DecimateRC = Int -> Int -> VS.Vector Float -> VS.Vector (Complex Float) -> VS.MVector RealWorld (Complex Float) -> IO () 88 | 89 | decimateFFIR :: DecimateCRR -> DecimateRR 90 | decimateFFIR func num factor coeffs inBuf outBuf = 91 | VS.unsafeWith (unsafeCoerce coeffs) $ \cPtr -> 92 | VS.unsafeWith (unsafeCoerce inBuf) $ \iPtr -> 93 | VSM.unsafeWith (unsafeCoerce outBuf) $ \oPtr -> 94 | func (fromIntegral num) (fromIntegral factor) (fromIntegral $ VG.length coeffs) cPtr iPtr oPtr 95 | 96 | decimateFFIC :: DecimateCRR -> DecimateRC 97 | decimateFFIC func num factor coeffs inBuf outBuf = 98 | VS.unsafeWith (unsafeCoerce coeffs) $ \cPtr -> 99 | VS.unsafeWith (unsafeCoerce inBuf) $ \iPtr -> 100 | VSM.unsafeWith (unsafeCoerce outBuf) $ \oPtr -> 101 | func (fromIntegral num) (fromIntegral factor) (fromIntegral $ VG.length coeffs) cPtr iPtr oPtr 102 | 103 | -- | Rational downsampling 104 | resampleHighLevel :: (PrimMonad m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) => Int -> Int -> Int -> Int -> v b -> v a -> vm (PrimState m) a -> m Int 105 | resampleHighLevel count interpolation decimation filterOffset coeffs inBuf outBuf = fill 0 filterOffset 0 106 | where 107 | fill i filterOffset inputOffset 108 | | i < count = do 109 | let dp = dotProd filterOffset inputOffset 110 | VGM.unsafeWrite outBuf i dp 111 | let (q, r) = quotRem (decimation - filterOffset - 1) interpolation 112 | inputOffset' = inputOffset + q + 1 113 | filterOffset' = interpolation - 1 - r 114 | filterOffset' `seq` inputOffset' `seq` fill (i + 1) filterOffset' inputOffset' 115 | | otherwise = return filterOffset 116 | dotProd filterOffset offset = VG.sum $ VG.zipWith mult (VG.unsafeDrop offset inBuf) (stride interpolation (VG.unsafeDrop filterOffset coeffs)) 117 | 118 | pad :: a -> Int -> [a] -> [a] 119 | pad with num list = list ++ replicate (num - length list) with 120 | 121 | strideList :: Int -> [a] -> [a] 122 | strideList s xs = go 0 xs 123 | where 124 | go _ [] = [] 125 | go 0 (x:xs) = x : go (s-1) xs 126 | go n (x:xs) = go (n - 1) xs 127 | 128 | roundUp :: Int -> Int -> Int 129 | roundUp num div = ((num + div - 1) `quot` div) * div 130 | 131 | data Coeffs = Coeffs { 132 | numCoeffs :: Int, 133 | numGroups :: Int, 134 | increments :: [Int], 135 | groups :: [[Float]] 136 | } 137 | 138 | prepareCoeffs :: Int -> Int -> Int -> [Float] -> Coeffs 139 | prepareCoeffs n interpolation decimation coeffs = Coeffs {..} 140 | where 141 | numCoeffs = maximum $ map (length . snd) dats 142 | numGroups = length groups 143 | increments = map fst dats 144 | 145 | groups :: [[Float]] 146 | groups = map (pad 0 (roundUp numCoeffs n)) $ map snd dats 147 | 148 | dats :: [(Int, [Float])] 149 | dats = func 0 150 | where 151 | 152 | func' 0 = [] 153 | func' x = func x 154 | 155 | func :: Int -> [(Int, [Float])] 156 | func offset = (increment, strideList interpolation $ drop offset coeffs) : func' offset' 157 | where 158 | (q, r) = quotRem (decimation - offset - 1) interpolation 159 | increment = q + 1 160 | offset' = interpolation - 1 - r 161 | 162 | resampleFFIR :: (Ptr CFloat -> Ptr CFloat -> IO ()) -> VS.Vector Float -> VSM.MVector RealWorld Float -> IO () 163 | resampleFFIR func inBuf outBuf = 164 | VS.unsafeWith (unsafeCoerce inBuf) $ \iPtr -> 165 | VS.unsafeWith (unsafeCoerce outBuf) $ \oPtr -> 166 | func iPtr oPtr 167 | 168 | type ResampleR = CInt -> CInt -> CInt -> CInt -> Ptr CInt -> Ptr (Ptr CFloat) -> Ptr CFloat -> Ptr CFloat -> IO () 169 | 170 | mkResampler :: ResampleR -> Int -> Int -> Int -> [Float] -> IO (Int -> Int -> VS.Vector Float -> VS.MVector RealWorld Float -> IO ()) 171 | mkResampler func n interpolation decimation coeffs = do 172 | groupsP <- mapM newArray $ map (map realToFrac) groups 173 | groupsPP <- newArray groupsP 174 | incrementsP <- newArray $ map fromIntegral increments 175 | return $ \num offset -> resampleFFIR $ func (fromIntegral num) (fromIntegral numCoeffs) (fromIntegral offset) (fromIntegral numGroups) incrementsP groupsPP 176 | where 177 | Coeffs {..} = prepareCoeffs n interpolation decimation coeffs 178 | 179 | theBench :: IO () 180 | theBench = do 181 | --Setup 182 | let size = 16384 183 | numCoeffs = 128 184 | num = size - numCoeffs + 1 185 | decimation = 4 186 | interpolation = 3 187 | numCoeffsDiv2 = 64 188 | 189 | coeffsList :: [Float] 190 | coeffsList = take numCoeffs [0 ..] 191 | coeffs :: VS.Vector Float 192 | coeffs = VG.fromList $ take numCoeffs [0 ..] 193 | coeffsSym :: VS.Vector Float 194 | coeffsSym = VG.fromList $ take numCoeffsDiv2 [0 ..] 195 | inBuf :: VS.Vector Float 196 | inBuf = VG.fromList $ take size [0 ..] 197 | inBufComplex :: VS.Vector (Complex Float) 198 | inBufComplex = VG.fromList $ take size $ do 199 | i <- [0..] 200 | return $ i :+ i 201 | 202 | numConv = 16386 203 | inBufConv :: VS.Vector CUChar 204 | inBufConv = VG.fromList $ take size $ concat $ repeat [0 .. 255] 205 | 206 | duplicate :: [a] -> [a] 207 | duplicate = concatMap func 208 | where func x = [x, x] 209 | 210 | coeffs2 :: VS.Vector Float 211 | coeffs2 = VG.fromList $ duplicate $ take numCoeffs [0 ..] 212 | 213 | outBuf :: VS.MVector RealWorld Float <- VGM.new size 214 | outBufComplex :: VS.MVector RealWorld (Complex Float) <- VGM.new size 215 | 216 | --Benchmarks 217 | defaultMain [ 218 | bgroup "filter" [ 219 | bgroup "real" [ 220 | bench "highLevel" $ nfIO $ filterHighLevel num coeffs inBuf outBuf 221 | ], 222 | bgroup "complex" [ 223 | bench "highLevel" $ nfIO $ filterHighLevel num coeffs inBufComplex outBufComplex 224 | ] 225 | ], 226 | bgroup "decimate" [ 227 | bgroup "real" [ 228 | bench "highLevel" $ nfIO $ decimateHighLevel (num `quot` decimation) decimation coeffs inBuf outBuf 229 | ], 230 | bgroup "complex" [ 231 | bench "highLevel" $ nfIO $ decimateHighLevel (num `quot` decimation) decimation coeffs inBufComplex outBufComplex 232 | ] 233 | ], 234 | bgroup "resample" [ 235 | bgroup "real" [ 236 | bench "highLevel" $ nfIO $ resampleHighLevel (num `quot` decimation) interpolation decimation 0 coeffs inBuf outBuf 237 | ], 238 | bgroup "complex" [ 239 | bench "highLevel" $ nfIO $ resampleHighLevel (num `quot` decimation) interpolation decimation 0 coeffs inBufComplex outBufComplex 240 | ] 241 | ] 242 | ] 243 | 244 | theTest = quickCheck $ conjoin [propFiltersComplex] 245 | where 246 | sizes = elements [1024, 2048, 4096, 8192, 16384, 32768, 65536] 247 | numCoeffs = elements [32, 64, 128, 256, 512] 248 | factors = elements [1, 2, 3, 4, 7, 9, 12, 15, 21] 249 | factors' = [1, 2, 3, 4, 7, 9, 12, 15, 21] 250 | propFiltersReal = forAll sizes $ \size -> 251 | forAll (vectorOf size (choose (-10, 10))) $ \inBuf -> 252 | forAll numCoeffs $ \numCoeffs -> 253 | forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs -> 254 | testFiltersReal size numCoeffs coeffs inBuf 255 | testFiltersReal :: Int -> Int -> [Float] -> [Float] -> Property 256 | testFiltersReal size numCoeffs coeffs inBuf = monadicIO $ do 257 | let vCoeffsHalf = VS.fromList coeffs 258 | vCoeffs = VS.fromList $ coeffs ++ reverse coeffs 259 | vInput = VS.fromList inBuf 260 | num = size - numCoeffs*2 + 1 261 | 262 | r1 <- run $ getResult num $ filterHighLevel num vCoeffs vInput 263 | 264 | propFiltersComplex = forAll sizes $ \size -> 265 | forAll (vectorOf size (choose (-10, 10))) $ \inBufR -> 266 | forAll (vectorOf size (choose (-10, 10))) $ \inBufI -> 267 | forAll numCoeffs $ \numCoeffs -> 268 | forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs -> 269 | assert $ all (r1 `eqDelta`) [r1] 270 | testFiltersComplex size numCoeffs coeffs $ zipWith (:+) inBufR inBufI 271 | testFiltersComplex :: Int -> Int -> [Float] -> [Complex Float] -> Property 272 | testFiltersComplex size numCoeffs coeffs inBuf = monadicIO $ do 273 | let vCoeffsHalf = VS.fromList coeffs 274 | vCoeffs = VS.fromList $ coeffs ++ reverse coeffs 275 | vInput = VS.fromList inBuf 276 | num = size - numCoeffs*2 + 1 277 | --vCoeffs2 = VG.fromList $ duplicate $ coeffs ++ reverse coeffs 278 | 279 | r1 <- run $ getResult num $ filterHighLevel num vCoeffs vInput 280 | 281 | propDecimationReal = forAll sizes $ \size -> 282 | forAll (vectorOf size (choose (-10, 10))) $ \inBuf -> 283 | forAll numCoeffs $ \numCoeffs -> 284 | forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs -> 285 | forAll factors $ \factor -> 286 | assert $ all (r1 `eqDeltaC`) [r1] 287 | testDecimationReal size numCoeffs factor coeffs inBuf 288 | testDecimationReal :: Int -> Int -> Int -> [Float] -> [Float] -> Property 289 | testDecimationReal size numCoeffs factor coeffs inBuf = monadicIO $ do 290 | let vCoeffsHalf = VS.fromList coeffs 291 | vCoeffs = VS.fromList $ coeffs ++ reverse coeffs 292 | vInput = VS.fromList inBuf 293 | num = (size - numCoeffs*2 + 1) `quot` factor 294 | 295 | r1 <- run $ getResult num $ decimateHighLevel num factor vCoeffs vInput 296 | 297 | propDecimationComplex = forAll sizes $ \size -> 298 | forAll (vectorOf size (choose (-10, 10))) $ \inBufR -> 299 | forAll (vectorOf size (choose (-10, 10))) $ \inBufI -> 300 | forAll numCoeffs $ \numCoeffs -> 301 | forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs -> 302 | forAll factors $ \factor -> 303 | assert $ all (r1 `eqDelta`) [r1] 304 | testDecimationComplex size numCoeffs factor coeffs $ zipWith (:+) inBufR inBufI 305 | testDecimationComplex :: Int -> Int -> Int -> [Float] -> [Complex Float] -> Property 306 | testDecimationComplex size numCoeffs factor coeffs inBuf = monadicIO $ do 307 | let vCoeffsHalf = VS.fromList coeffs 308 | vCoeffs = VS.fromList $ coeffs ++ reverse coeffs 309 | vInput = VS.fromList inBuf 310 | num = (size - numCoeffs*2 + 1) `quot` factor 311 | --vCoeffs2 = VG.fromList $ duplicate $ coeffs ++ reverse coeffs 312 | 313 | r1 <- run $ getResult num $ decimateHighLevel num factor vCoeffs vInput 314 | 315 | propResamplingReal = forAll sizes $ \size -> 316 | forAll (vectorOf size (choose (-10, 10))) $ \inBuf -> 317 | forAll numCoeffs $ \numCoeffs -> 318 | forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs -> 319 | forAll (elements $ tail factors') $ \decimation -> 320 | forAll (elements $ filter (< decimation) factors') $ \interpolation -> 321 | assert $ all (r1 `eqDeltaC`) [r1] 322 | testResamplingReal size numCoeffs interpolation decimation coeffs inBuf 323 | testResamplingReal :: Int -> Int -> Int -> Int -> [Float] -> [Float] -> Property 324 | testResamplingReal size numCoeffs interpolation decimation coeffs inBuf = monadicIO $ do 325 | let vCoeffsHalf = VS.fromList coeffs 326 | vCoeffs = VS.fromList $ coeffs ++ reverse coeffs 327 | vInput = VS.fromList inBuf 328 | num = (size - numCoeffs*2 + 1) `quot` decimation 329 | 330 | r1 <- run $ getResult num $ resampleHighLevel num interpolation decimation 0 vCoeffs vInput 331 | 332 | assert $ all (r1 `eqDelta`) [r1] 333 | getResult :: (VSM.Storable a) => Int -> (VS.MVector RealWorld a -> IO b) -> IO [a] 334 | getResult size func = do 335 | outBuf <- VGM.new size 336 | func outBuf 337 | out :: VS.Vector a <- VG.freeze outBuf 338 | return $ VG.toList out 339 | eqDelta x y = all (uncurry eqDelta') $ zip x y 340 | where 341 | eqDelta' x y = abs (x - y) < 0.01 342 | eqDeltaC x y = all (uncurry eqDelta') $ zip x y 343 | where 344 | eqDelta' x y = magnitude (x - y) < 0.01 345 | duplicate :: [a] -> [a] 346 | duplicate = concatMap func 347 | where func x = [x, x] 348 | 349 | main = theBench 350 | -------------------------------------------------------------------------------- /hs_sources/SDR/ArgUtils.hs: -------------------------------------------------------------------------------- 1 | {-| Utilities for parsing command line arguments that might be useful when writing a SDR application. Uses the optparse-applicative library. -} 2 | module SDR.ArgUtils ( 3 | parseSize 4 | ) where 5 | 6 | import Options.Applicative 7 | import Data.Decimal 8 | 9 | {-| Parse a number that may have a decimal point and a suffix, e.g. 2.56M -} 10 | parseSize :: ReadM Integer 11 | parseSize = eitherReader $ \arg -> case reads arg of 12 | [(r, suffix)] -> case suffix of 13 | [] -> return $ round (r :: Decimal) 14 | "K" -> return $ round $ r * 1000 15 | "M" -> return $ round $ r * 1000000 16 | "G" -> return $ round $ r * 1000000000 17 | x -> Left $ "Cannot parse suffix: `" ++ x ++ "'" 18 | _ -> Left $ "Cannot parse value: `" ++ arg ++ "'" 19 | 20 | -------------------------------------------------------------------------------- /hs_sources/SDR/CPUID.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | {-| This module is for detecting which SIMD instruction sets your CPU supports. In particular, it can detect SSE4.2, AVX and AVX2. -} 4 | module SDR.CPUID ( 5 | -- * Raw CPUID 6 | cpuid, 7 | cpuidExtended, 8 | 9 | -- * High level CPU capabilities 10 | CPUInfo(..), 11 | getCPUInfo, 12 | 13 | -- * Features 14 | hasSSE42, 15 | hasAVX, 16 | hasAVX2, 17 | 18 | -- * Convenience functions 19 | featureSelect 20 | ) where 21 | 22 | import Data.Word 23 | import Data.Bits 24 | import Foreign.Ptr 25 | import Foreign.Marshal.Alloc 26 | import Foreign.Storable 27 | import Data.List 28 | import Data.Maybe 29 | import Control.Applicative 30 | 31 | foreign import ccall unsafe "cpuid" 32 | cpuid_c :: Word32 -> Ptr Word32 -> Ptr Word32 -> Ptr Word32 -> Ptr Word32 -> IO () 33 | 34 | foreign import ccall unsafe "cpuid_extended" 35 | cpuidExtended_c :: Word32 -> Word32 -> Ptr Word32 -> Ptr Word32 -> Ptr Word32 -> Ptr Word32 -> IO () 36 | 37 | -- | Execute the CPUID instruction 38 | cpuid :: Word32 -- ^ Operation (EAX) 39 | -> IO (Word32, Word32, Word32, Word32) -- ^ Result (EAX, EBX, ECX, EDX) 40 | cpuid x = 41 | alloca $ \p1 -> 42 | alloca $ \p2 -> 43 | alloca $ \p3 -> 44 | alloca $ \p4 -> do 45 | cpuid_c x p1 p2 p3 p4 46 | (,,,) <$> peek p1 <*> peek p2 <*> peek p3 <*> peek p4 47 | 48 | -- | Execute the CPUID instruction setting ECX as well 49 | cpuidExtended :: Word32 -- ^ Operation (EAX) 50 | -> Word32 -- ^ ECX 51 | -> IO (Word32, Word32, Word32, Word32) -- ^ Result (EAX, EBX, ECX, EDX) 52 | cpuidExtended x y = 53 | alloca $ \p1 -> 54 | alloca $ \p2 -> 55 | alloca $ \p3 -> 56 | alloca $ \p4 -> do 57 | cpuidExtended_c x y p1 p2 p3 p4 58 | (,,,) <$> peek p1 <*> peek p2 <*> peek p3 <*> peek p4 59 | 60 | -- | Information about the features supported by your CPU 61 | data CPUInfo = CPUInfo { 62 | features :: Word32, 63 | extendedFeatures :: Maybe Word32 64 | } 65 | 66 | -- | Get a `CPUInfo` 67 | getCPUInfo :: IO CPUInfo 68 | getCPUInfo = do 69 | (x, _, _, _) <- cpuid 0 70 | (_, _, f, _) <- cpuid 1 71 | if x < 7 then 72 | return $ CPUInfo f Nothing 73 | else do 74 | (_, e, _, _) <- cpuidExtended 7 0 75 | return $ CPUInfo f (Just e) 76 | 77 | -- | Feature bit for SSE4.2 78 | sse42 = 20 79 | 80 | -- | Feature bit for AVX 81 | avx = 28 82 | 83 | -- | Extended feature bit for AVX2 84 | avx2 = 5 85 | 86 | -- | Check if the CPU supports SSE4.2 87 | hasSSE42 :: CPUInfo -> Bool 88 | hasSSE42 CPUInfo{..} = testBit features sse42 89 | 90 | -- | Check if the CPU supports AVX 91 | hasAVX :: CPUInfo -> Bool 92 | hasAVX CPUInfo{..} = testBit features avx 93 | 94 | -- | Check if the CPU supports AVX2 95 | hasAVX2 :: CPUInfo -> Bool 96 | hasAVX2 (CPUInfo _ Nothing) = False 97 | hasAVX2 (CPUInfo _ (Just f)) = testBit f avx2 98 | 99 | -- | Convenience function for selecting a function based on the features that the CPU supports 100 | featureSelect :: CPUInfo -- ^ The CPU features 101 | -> a -- ^ Default implementation 102 | -> [(CPUInfo -> Bool, a)] -- ^ List of (feature, implementation) pairs 103 | -> a -- ^ The selected implementation 104 | featureSelect info def list = maybe def snd $ find (($ info) . fst) list 105 | 106 | -------------------------------------------------------------------------------- /hs_sources/SDR/Demod.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | {-| FM demodulation pipes -} 4 | module SDR.Demod ( 5 | fmDemodStr, 6 | fmDemodVec, 7 | fmDemod 8 | ) where 9 | 10 | import Data.Complex 11 | import qualified Data.Vector.Generic as VG 12 | import qualified Data.Vector.Fusion.Stream.Monadic as VFSM 13 | import qualified Data.Vector.Fusion.Bundle.Monadic as VFBM 14 | import qualified Data.Vector.Fusion.Bundle.Size as VFBS 15 | 16 | import SDR.VectorUtils 17 | import Pipes 18 | 19 | -- | FM demodulate a stream of complex samples 20 | {-# INLINE fmDemodStr #-} 21 | fmDemodStr :: (RealFloat a, Monad m) 22 | => Complex a -- ^ The starting sample - i.e. the last sample in the last buffer 23 | -> VFSM.Stream m (Complex a) -- ^ The input stream 24 | -> VFSM.Stream m a -- ^ The output stream 25 | fmDemodStr = mapAccumMV func 26 | where 27 | {-# INLINE func #-} 28 | func last sample = return (sample, phase (sample * conjugate last)) 29 | 30 | -- | FM demodulate a vector of complex samples 31 | {-# INLINE fmDemodVec #-} 32 | fmDemodVec :: (RealFloat a, VG.Vector v (Complex a), VG.Vector v a) 33 | => Complex a -- ^ The starting sample - i.e. the last sample in the last buffer 34 | -> v (Complex a) -- ^ The input Vector 35 | -> v a -- ^ The output Vector 36 | fmDemodVec init inp = VG.unstream $ flip VFBM.fromStream (VFBS.Exact $ VG.length inp) $ fmDemodStr init $ VFBM.elements $ VG.stream inp 37 | 38 | -- | Pipe that performs FM demodulation 39 | {-# INLINE fmDemod #-} 40 | fmDemod :: (RealFloat a, VG.Vector v (Complex a), VG.Vector v a) => Pipe (v (Complex a)) (v a) IO () 41 | fmDemod = func 0 42 | where 43 | func lastSample = do 44 | dat <- await 45 | yield $ fmDemodVec lastSample dat 46 | func $ VG.unsafeIndex dat (VG.length dat - 1) 47 | -------------------------------------------------------------------------------- /hs_sources/SDR/FFT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} 2 | 3 | {-| Fast FFTs using FFTW -} 4 | module SDR.FFT ( 5 | -- * Windows 6 | hamming, 7 | hanning, 8 | blackman, 9 | 10 | -- * FFTs 11 | fftw', 12 | fftw, 13 | fftwReal', 14 | fftwReal, 15 | fftwParallel 16 | ) where 17 | 18 | import Control.Monad as CM 19 | import Foreign.Storable 20 | import Foreign.Storable.Complex 21 | import Foreign.C.Types 22 | import Data.Complex 23 | import Foreign.ForeignPtr 24 | import Control.Concurrent hiding (yield) 25 | import qualified Data.Map as Map 26 | import Data.Coerce 27 | 28 | import qualified Data.Vector.Generic as VG 29 | import qualified Data.Vector.Storable as VS 30 | import qualified Data.Vector.Storable.Mutable as VSM 31 | 32 | import Pipes 33 | import Numeric.FFTW 34 | 35 | import SDR.FilterDesign 36 | import SDR.VectorUtils 37 | 38 | mallocForeignBufferAligned :: forall a. Storable a => Int -> IO (ForeignPtr a) 39 | mallocForeignBufferAligned elems = do 40 | ptr <- fftwMalloc $ fromIntegral $ elems * sizeOf (undefined :: a) 41 | newForeignPtr fftwFreePtr ptr 42 | 43 | -- | Creates a function that performs a complex to complex DFT. 44 | fftw' :: (VG.Vector v (Complex Double)) 45 | => Int -- ^ The size of the input and output buffers 46 | -> IO (v (Complex Double) -> IO (VS.Vector (Complex Double))) 47 | fftw' samples = do 48 | ina <- mallocForeignBufferAligned samples 49 | out <- mallocForeignBufferAligned samples 50 | 51 | plan <- withForeignPtr ina $ \ip -> 52 | withForeignPtr out $ \op -> 53 | planDFT1d samples ip op Forward fftwEstimate 54 | 55 | return $ \inv' -> do 56 | out <- mallocForeignBufferAligned samples 57 | ina <- mallocForeignBufferAligned samples 58 | let inv = VSM.unsafeFromForeignPtr0 ina samples 59 | 60 | copyInto inv inv' 61 | 62 | let (fp, offset, length) = VSM.unsafeToForeignPtr inv 63 | 64 | withForeignPtr (coerce fp) $ \fpp -> 65 | withForeignPtr (coerce out) $ \op -> 66 | executeDFT plan fpp op 67 | 68 | return $ VS.unsafeFromForeignPtr0 out samples 69 | 70 | -- | Creates a Pipe that performs a complex to complex DFT. 71 | fftw :: (VG.Vector v (Complex Double)) 72 | => Int -- ^ The size of the input and output buffers 73 | -> IO (Pipe (v (Complex Double)) (VS.Vector (Complex Double)) IO ()) 74 | fftw samples = do 75 | func <- fftw' samples 76 | return $ for cat $ \dat -> lift (func dat) >>= yield 77 | 78 | -- | Creates a function that performs a real to complex DFT. 79 | fftwReal' :: (VG.Vector v Double) 80 | => Int -- ^ The size of the input Vector 81 | -> IO (v Double -> IO (VS.Vector (Complex Double))) 82 | fftwReal' samples = do 83 | --Allocate in and out buffers that wont be used because there doesnt seem to be a way to create a plan without them 84 | ina <- mallocForeignBufferAligned samples 85 | out <- mallocForeignBufferAligned samples 86 | 87 | plan <- withForeignPtr ina $ \ip -> 88 | withForeignPtr out $ \op -> 89 | planDFTR2C1d samples ip op fftwEstimate 90 | 91 | return $ \inv' -> do 92 | out <- mallocForeignBufferAligned ((samples `quot` 2) + 1) 93 | ina <- mallocForeignBufferAligned samples 94 | let inv = VSM.unsafeFromForeignPtr0 ina samples 95 | 96 | copyInto inv inv' 97 | let (fp, offset, length) = VSM.unsafeToForeignPtr inv 98 | 99 | withForeignPtr (coerce fp) $ \fpp -> 100 | withForeignPtr (coerce out) $ \op -> 101 | executeDFTR2C plan fpp op 102 | 103 | return $ VS.unsafeFromForeignPtr0 out samples 104 | 105 | -- | Creates a pipe that performs a real to complex DFT. 106 | fftwReal :: (VG.Vector v Double) 107 | => Int -- ^ The size of the input Vector 108 | -> IO (Pipe (v Double) (VS.Vector (Complex Double)) IO ()) 109 | fftwReal samples = do 110 | func <- fftwReal' samples 111 | return $ for cat $ \dat -> lift (func dat) >>= yield 112 | 113 | {-| Creates a pipe that uses multiple threads to perform complex to complex DFTs in 114 | a pipelined fashion. Each time a buffer is consumed, it is given to 115 | a pool of threads to perform the DFT. Then, if a thread has finished 116 | performing a previous DFT, the result is yielded. 117 | -} 118 | fftwParallel :: (VG.Vector v (Complex Double)) 119 | => Int -- ^ The number of threads to use 120 | -> Int -- ^ The size of the input Vector 121 | -> IO (Pipe (v (Complex Double)) (VS.Vector (Complex Double)) IO ()) 122 | fftwParallel threads samples = do 123 | --plan the DFT 124 | ina <- mallocForeignBufferAligned samples 125 | out <- mallocForeignBufferAligned samples 126 | 127 | plan <- withForeignPtr ina $ \ip -> 128 | withForeignPtr out $ \op -> 129 | planDFT1d samples ip op Forward fftwEstimate 130 | 131 | --setup the channels and worker threads 132 | inChan <- newChan 133 | outMap <- newMVar Map.empty 134 | 135 | CM.replicateM threads $ forkIO $ forever $ do 136 | (idx, res) <- readChan inChan 137 | 138 | out <- mallocForeignBufferAligned samples 139 | ina <- mallocForeignBufferAligned samples 140 | let inv = VSM.unsafeFromForeignPtr0 ina samples 141 | 142 | copyInto inv res 143 | 144 | let (fp, offset, length) = VSM.unsafeToForeignPtr inv 145 | 146 | withForeignPtr (coerce fp) $ \fpp -> 147 | withForeignPtr (coerce out) $ \op -> 148 | executeDFT plan fpp op 149 | 150 | theMap <- takeMVar outMap 151 | putMVar outMap $ Map.insert idx (VS.unsafeFromForeignPtr0 out samples) theMap 152 | 153 | --build the pipe 154 | let pipe nextIn nextOut = do 155 | dat <- await 156 | lift $ writeChan inChan (nextIn, dat) 157 | 158 | theMap <- lift $ takeMVar outMap 159 | case Map.lookup nextOut theMap of 160 | Nothing -> do 161 | lift $ putMVar outMap theMap 162 | pipe (nextIn + 1) nextOut 163 | Just dat -> do 164 | lift $ putMVar outMap $ Map.delete nextOut theMap 165 | yield dat 166 | pipe (nextIn + 1) (nextOut + 1) 167 | 168 | return $ pipe 0 0 169 | 170 | -------------------------------------------------------------------------------- /hs_sources/SDR/Filter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, FlexibleContexts, GADTs, ExistentialQuantification #-} 2 | 3 | {-| FIR filtering, decimation and resampling. 4 | 5 | FIR filters (and decimators, resamplers) work by taking successive dot products between the filter coefficients and the input data at increasing offsets. Sometimes the dot product fits entirely within one input buffer and other times it spans two input buffers (but never more because we assume that the filter length is less than the buffer size). 6 | 7 | We divide the filtering code by these two cases. Each filter (or decimator, resampler) is described by a data structure such as `Filter` with two functions, one for filtering within a single buffer and one that crosses buffers. 8 | 9 | The user must first create one of these data structures using the helper functions and pass this data structure to one of `firFilter`, `firDecimator`, or `firResampler` to create the `Pipe` that does the filtering. For example: 10 | 11 | > decimatorStruct <- fastDecimatorC cpuInfo decimation coeffs 12 | > let decimatorPipe :: Pipe (Vector (Complex Float)) (Vector (Complex Float)) IO () 13 | > decimatorPipe = firDecimator decimatorStruct outputSize 14 | 15 | There are polymorphic Haskell only implementations of filtering, decimation and resampling, for example, `haskellFilter`. In addition, there are optimised C implementations that use SIMD instructions on x86 machines, such as `fastFilterR`. These are always specialized to either real or complex numbers. There are also even faster implementations specialized for the case where the filter coefficients are symmetric as in a linear phase filter such as `fastFilterSymR`. 16 | 17 | The Haskell implementations are reasonably fast due to the Vector library and GHC's LLVM backend, however, if speed is important you are much better off with the C implementations. 18 | 19 | In the future we may avoid the cross buffer filtering function by mapping the buffers consecutively in memory as (I believe) GNU Radio does. 20 | 21 | An extensive benchmark suite exists in the /benchmarks subdirectory of this package. 22 | -} 23 | module SDR.Filter ( 24 | -- * Types 25 | Filter(..), 26 | Decimator(..), 27 | Resampler(..), 28 | 29 | -- * Helper Functions 30 | -- ** Filters 31 | haskellFilter, 32 | 33 | -- *** Real Data 34 | fastFilterCR, 35 | fastFilterSSER, 36 | fastFilterAVXR, 37 | fastFilterR, 38 | 39 | -- *** Complex Data 40 | fastFilterCC, 41 | fastFilterSSEC, 42 | fastFilterAVXC, 43 | fastFilterC, 44 | 45 | -- *** Linear Phase Real Data 46 | fastFilterSymSSER, 47 | fastFilterSymAVXR, 48 | fastFilterSymR, 49 | 50 | -- ** Decimators 51 | haskellDecimator, 52 | 53 | -- *** Real Data 54 | fastDecimatorCR, 55 | fastDecimatorSSER, 56 | fastDecimatorAVXR, 57 | fastDecimatorR, 58 | 59 | -- *** Complex Data 60 | fastDecimatorCC, 61 | fastDecimatorSSEC, 62 | fastDecimatorAVXC, 63 | fastDecimatorC, 64 | 65 | -- *** Linear Phase Real Data 66 | fastDecimatorSymSSER, 67 | fastDecimatorSymAVXR, 68 | fastDecimatorSymR, 69 | 70 | -- ** Resamplers 71 | haskellResampler, 72 | 73 | -- *** Real Data 74 | fastResamplerCR, 75 | fastResamplerSSER, 76 | fastResamplerAVXR, 77 | fastResamplerR, 78 | 79 | -- *** Complex Data 80 | fastResamplerCC, 81 | fastResamplerSSEC, 82 | fastResamplerAVXC, 83 | fastResamplerC, 84 | 85 | -- * Filter 86 | firFilter, 87 | 88 | -- * Decimate 89 | firDecimator, 90 | 91 | -- * Resample 92 | firResampler, 93 | 94 | -- * DC Blocking Filter 95 | dcBlockingFilter 96 | ) where 97 | 98 | import Control.Applicative 99 | import Data.Complex 100 | import Control.Exception hiding (assert) 101 | import qualified Data.Vector.Generic as VG 102 | import qualified Data.Vector.Generic.Mutable as VGM 103 | import qualified Data.Vector.Storable as VS 104 | import Control.Monad.Primitive 105 | 106 | import Pipes 107 | 108 | import SDR.Util 109 | import SDR.FilterInternal hiding (mkResampler, mkResamplerC) 110 | import SDR.CPUID 111 | 112 | {- | A `Filter` contains all of the information needed by the `filterr` 113 | function to perform filtering. i.e. it contains the filter coefficients 114 | and pointers to the functions to do the actual filtering. 115 | -} 116 | data Filter m v vm a = Filter { 117 | numCoeffsF :: Int, 118 | filterOne :: Int -> v a -> vm (PrimState m) a -> m (), 119 | filterCross :: Int -> v a -> v a -> vm (PrimState m) a -> m () 120 | } 121 | 122 | {- | A `Decimator` contains all of the information needed by the `decimate` 123 | function to perform decimation i.e. it contains the filter coefficients 124 | and pointers to the functions to do the actual decimation. 125 | -} 126 | data Decimator m v vm a = Decimator { 127 | numCoeffsD :: Int, 128 | decimationD :: Int, 129 | decimateOne :: Int -> v a -> vm (PrimState m) a -> m (), 130 | decimateCross :: Int -> v a -> v a -> vm (PrimState m) a -> m () 131 | } 132 | 133 | {- | A `Resampler` contains all of the information needed by the `resample` 134 | function to perform resampling i.e. it contains the filter coefficients 135 | and pointers to the functions to do the actual resampling. 136 | -} 137 | data Resampler m v vm a = forall dat. Resampler { 138 | numCoeffsR :: Int, 139 | decimationR :: Int, 140 | interpolationR :: Int, 141 | startDat :: dat, 142 | resampleOne :: dat -> Int -> v a -> vm (PrimState m) a -> m (dat, Int), 143 | resampleCross :: dat -> Int -> v a -> v a -> vm (PrimState m) a -> m (dat, Int) 144 | } 145 | 146 | duplicate :: [a] -> [a] 147 | duplicate = concatMap func 148 | where func x = [x, x] 149 | 150 | {-# INLINE haskellFilter #-} 151 | -- | Returns a slow Filter data structure entirely implemented in Haskell 152 | haskellFilter :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) 153 | => [b] -- ^ The filter coefficients 154 | -> IO (Filter m v vm a) -- ^ The `Filter` data structure 155 | haskellFilter coeffs = do 156 | let vCoeffs = VG.fromList coeffs 157 | evaluate vCoeffs 158 | let filterOne = filterHighLevel vCoeffs 159 | filterCross = filterCrossHighLevel vCoeffs 160 | numCoeffsF = length coeffs 161 | return Filter {..} 162 | 163 | mkFilter :: Int 164 | -> FilterRR 165 | -> [Float] 166 | -> IO (Filter IO VS.Vector VS.MVector Float) 167 | mkFilter sizeMultiple filterFunc coeffs = do 168 | let l = length coeffs 169 | numCoeffsF = roundUp l sizeMultiple 170 | diff = numCoeffsF - l 171 | vCoeffs = VG.fromList $ coeffs ++ replicate diff 0 172 | evaluate vCoeffs 173 | let filterOne = filterFunc vCoeffs 174 | filterCross = filterCrossHighLevel vCoeffs 175 | return Filter {..} 176 | 177 | -- | Returns a fast Filter data structure implemented in C. For filtering real data with real coefficients. 178 | fastFilterCR :: [Float] -- ^ The filter coefficients 179 | -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure 180 | fastFilterCR = mkFilter 1 filterCRR 181 | 182 | -- | Returns a fast Filter data structure implemented in C using SSE instructions. For filtering real data with real coefficients. 183 | fastFilterSSER :: [Float] -- ^ The filter coefficients 184 | -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure 185 | fastFilterSSER = mkFilter 4 filterCSSERR 186 | 187 | -- | Returns a fast Filter data structure implemented in C using AVX instructions. For filtering real data with real coefficients. 188 | fastFilterAVXR :: [Float] -- ^ The filter coefficients 189 | -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure 190 | fastFilterAVXR = mkFilter 8 filterCAVXRR 191 | 192 | -- | Returns a fast Filter data structure implemented in C using the fastest SIMD instruction set your processor supports. For filtering real data with real coefficients. 193 | fastFilterR :: CPUInfo -- ^ The CPU's capabilities 194 | -> [Float] -- ^ The filter coefficients 195 | -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure 196 | fastFilterR info = featureSelect info fastFilterCR [(hasAVX, fastFilterAVXR), (hasSSE42, fastFilterSSER)] 197 | 198 | mkFilterC :: Int 199 | -> FilterRC 200 | -> [Float] 201 | -> IO (Filter IO VS.Vector VS.MVector (Complex Float)) 202 | mkFilterC sizeMultiple filterFunc coeffs = do 203 | let l = length coeffs 204 | numCoeffsF = roundUp sizeMultiple l 205 | diff = numCoeffsF - l 206 | vCoeffs = VG.fromList $ duplicate $ coeffs ++ replicate diff 0 207 | vCoeffs2 = VG.fromList $ coeffs ++ replicate diff 0 208 | evaluate vCoeffs 209 | let filterOne = filterFunc vCoeffs 210 | filterCross = filterCrossHighLevel vCoeffs2 211 | return Filter {..} 212 | 213 | -- | Returns a fast Filter data structure implemented in C For filtering complex data with real coefficients. 214 | fastFilterCC :: [Float] -- ^ The filter coefficients 215 | -> IO (Filter IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Filter` data structure 216 | fastFilterCC = mkFilterC 1 filterCRC 217 | 218 | -- | Returns a fast Filter data structure implemented in C using SSE instructions. For filtering complex data with real coefficients. 219 | fastFilterSSEC :: [Float] -- ^ The filter coefficients 220 | -> IO (Filter IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Filter` data structure 221 | fastFilterSSEC = mkFilterC 2 filterCSSERC 222 | 223 | -- | Returns a fast Filter data structure implemented in C using AVX instructions. For filtering complex data with real coefficients. 224 | fastFilterAVXC :: [Float] -- ^ The filter coefficients 225 | -> IO (Filter IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Filter` data structure 226 | fastFilterAVXC = mkFilterC 4 filterCAVXRC 227 | 228 | -- | Returns a fast Filter data structure implemented in C using the fastest SIMD instruction set your processor supports. For filtering complex data with real coefficients. 229 | fastFilterC :: CPUInfo -- ^ The CPU's capabilities 230 | -> [Float] -- ^ The filter coefficients 231 | -> IO (Filter IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Filter` data structure 232 | fastFilterC info = featureSelect info fastFilterCC [(hasAVX, fastFilterAVXC), (hasSSE42, fastFilterSSEC)] 233 | 234 | mkFilterSymR :: FilterRR 235 | -> [Float] 236 | -> IO (Filter IO VS.Vector VS.MVector Float) 237 | mkFilterSymR filterFunc coeffs = do 238 | let vCoeffs = VG.fromList coeffs 239 | let vCoeffs2 = VG.fromList $ coeffs ++ reverse coeffs 240 | evaluate vCoeffs 241 | evaluate vCoeffs2 242 | let filterOne = filterFunc vCoeffs 243 | filterCross = filterCrossHighLevel vCoeffs2 244 | numCoeffsF = length coeffs * 2 245 | return Filter {..} 246 | 247 | -- | Returns a fast Filter data structure implemented in C using SSE instructions. For filtering real data with real coefficients. For filters with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4. 248 | fastFilterSymSSER :: [Float] -- ^ The first half of the filter coefficients 249 | -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure 250 | fastFilterSymSSER = mkFilterSymR filterCSSESymmetricRR 251 | 252 | -- | Returns a fast Filter data structure implemented in C using AVX instructions. For filtering real data with real coefficients. For filters with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4. 253 | fastFilterSymAVXR :: [Float] -- ^ The first half of the filter coefficients 254 | -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure 255 | fastFilterSymAVXR = mkFilterSymR filterCAVXSymmetricRR 256 | 257 | -- | Returns a fast Filter data structure implemented in C using the fastest SIMD instruction set your processor supports. For filtering complex data with real coefficients. For filters with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4. 258 | fastFilterSymR :: CPUInfo -- ^ The CPU's capabilities 259 | -> [Float] -- ^ The filter coefficients 260 | -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure 261 | fastFilterSymR info = featureSelect info (error "At least SSE4.2 required") [(hasAVX, fastFilterSymAVXR), (hasSSE42, fastFilterSymSSER)] 262 | 263 | {-# INLINE haskellDecimator #-} 264 | -- | Returns a slow Decimator data structure entirely implemented in Haskell 265 | haskellDecimator :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) 266 | => Int -- ^ The decimation factor 267 | -> [b] -- ^ The filter coefficients 268 | -> IO (Decimator m v vm a) -- ^ The `Decimator` data structure 269 | haskellDecimator decimationD coeffs = do 270 | let vCoeffs = VG.fromList coeffs 271 | evaluate vCoeffs 272 | let decimateOne = decimateHighLevel decimationD vCoeffs 273 | decimateCross = decimateCrossHighLevel decimationD vCoeffs 274 | numCoeffsD = length coeffs 275 | return $ Decimator {..} 276 | 277 | mkDecimator :: Int 278 | -> DecimateRR 279 | -> Int 280 | -> [Float] 281 | -> IO (Decimator IO VS.Vector VS.MVector Float) 282 | mkDecimator sizeMultiple filterFunc decimationD coeffs = do 283 | let l = length coeffs 284 | numCoeffsD = roundUp l sizeMultiple 285 | diff = numCoeffsD - l 286 | vCoeffs = VG.fromList $ coeffs ++ replicate diff 0 287 | evaluate vCoeffs 288 | let decimateOne = filterFunc decimationD vCoeffs 289 | decimateCross = decimateCrossHighLevel decimationD vCoeffs 290 | return Decimator {..} 291 | 292 | -- | Returns a fast Decimator data structure implemented in C. For decimating real data with real coefficients. 293 | fastDecimatorCR :: Int -- ^ The decimation factor 294 | -> [Float] -- ^ The filter coefficients 295 | -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure 296 | fastDecimatorCR = mkDecimator 1 decimateCRR 297 | 298 | -- | Returns a fast Decimator data structure implemented in C using SSE instructions. For decimating real data with real coefficients. 299 | fastDecimatorSSER :: Int -- ^ The decimation factor 300 | -> [Float] -- ^ The filter coefficients 301 | -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure 302 | fastDecimatorSSER = mkDecimator 4 decimateCSSERR 303 | 304 | -- | Returns a fast Decimator data structure implemented in C using AVX instructions. For decimating real data with real coefficients. 305 | fastDecimatorAVXR :: Int -- ^ The decimation factor 306 | -> [Float] -- ^ The filter coefficients 307 | -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure 308 | fastDecimatorAVXR = mkDecimator 8 decimateCAVXRR 309 | 310 | -- | Returns a fast Decimator data structure implemented in C using the fastest SIMD instruction set your processor supports. For decimating real data with real coefficients. 311 | fastDecimatorR :: CPUInfo -- ^ The CPU's capabilities 312 | -> Int -- ^ The decimation factor 313 | -> [Float] -- ^ The filter coefficients 314 | -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure 315 | fastDecimatorR info = featureSelect info fastDecimatorCR [(hasAVX, fastDecimatorAVXR), (hasSSE42, fastDecimatorSSER)] 316 | 317 | mkDecimatorC :: Int 318 | -> DecimateRC 319 | -> Int 320 | -> [Float] 321 | -> IO (Decimator IO VS.Vector VS.MVector (Complex Float)) 322 | mkDecimatorC sizeMultiple filterFunc decimationD coeffs = do 323 | let l = length coeffs 324 | numCoeffsD = roundUp l sizeMultiple 325 | diff = numCoeffsD - l 326 | vCoeffs = VG.fromList $ duplicate $ coeffs ++ replicate diff 0 327 | vCoeffs2 = VG.fromList $ coeffs ++ replicate diff 0 328 | evaluate vCoeffs 329 | let decimateOne = filterFunc decimationD vCoeffs 330 | decimateCross = decimateCrossHighLevel decimationD vCoeffs2 331 | return Decimator {..} 332 | 333 | -- | Returns a fast Decimator data structure implemented in C. For decimating complex data with real coefficients. 334 | fastDecimatorCC :: Int -- ^ The decimation factor 335 | -> [Float] -- ^ The filter coefficients 336 | -> IO (Decimator IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Decimator` data structure 337 | fastDecimatorCC = mkDecimatorC 1 decimateCRC 338 | 339 | -- | Returns a fast Decimator data structure implemented in C using SSE instructions. For decimating complex data with real coefficients. 340 | fastDecimatorSSEC :: Int -- ^ The decimation factor 341 | -> [Float] -- ^ The filter coefficients 342 | -> IO (Decimator IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Decimator` data structure 343 | fastDecimatorSSEC = mkDecimatorC 2 decimateCSSERC 344 | 345 | -- | Returns a fast Decimator data structure implemented in C using AVX instructions. For decimating complex data with real coefficients. 346 | fastDecimatorAVXC :: Int -- ^ The decimation factor 347 | -> [Float] -- ^ The filter coefficients 348 | -> IO (Decimator IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Decimator` data structure 349 | fastDecimatorAVXC = mkDecimatorC 4 decimateCAVXRC 350 | 351 | -- | Returns a fast Decimator data structure implemented in C using the fastest SIMD instruction set your processor supports. For decimating complex data with real coefficients. 352 | fastDecimatorC :: CPUInfo -- ^ The CPU's capabilities 353 | -> Int -- ^ The decimation factor 354 | -> [Float] -- ^ The filter coefficients 355 | -> IO (Decimator IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Decimator` data structure 356 | fastDecimatorC info = featureSelect info fastDecimatorCC [(hasAVX, fastDecimatorAVXC), (hasSSE42, fastDecimatorSSEC)] 357 | 358 | mkDecimatorSymR :: DecimateRR 359 | -> Int 360 | -> [Float] 361 | -> IO (Decimator IO VS.Vector VS.MVector Float) 362 | mkDecimatorSymR filterFunc decimationD coeffs = do 363 | let vCoeffs = VG.fromList coeffs 364 | let vCoeffs2 = VG.fromList $ coeffs ++ reverse coeffs 365 | evaluate vCoeffs 366 | evaluate vCoeffs2 367 | let decimateOne = filterFunc decimationD vCoeffs 368 | decimateCross = decimateCrossHighLevel decimationD vCoeffs2 369 | numCoeffsD = length coeffs * 2 370 | 371 | return Decimator {..} 372 | -- | Returns a fast Decimator data structure implemented in C using SSE instructions. For decimating real data with real coefficients. For decimators with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4. 373 | fastDecimatorSymSSER :: Int -- ^ The decimation factor 374 | -> [Float] -- ^ The first half of the filter coefficients 375 | -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure 376 | fastDecimatorSymSSER = mkDecimatorSymR decimateCSSESymmetricRR 377 | 378 | -- | Returns a fast Decimator data structure implemented in C using AVX instructions. For decimating real data with real coefficients. For decimators with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4. 379 | fastDecimatorSymAVXR :: Int -- ^ The decimation factor 380 | -> [Float] -- ^ The first half of the filter coefficients 381 | -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure 382 | fastDecimatorSymAVXR = mkDecimatorSymR decimateCAVXSymmetricRR 383 | 384 | -- | Returns a fast Decimator data structure implemented in C using the fastest SIMD instruction set your processor supports. For decimating real data with real coefficients. For decimators with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4. 385 | fastDecimatorSymR :: CPUInfo -- ^ The CPU's capabilities 386 | -> Int -- ^ The decimation factor 387 | -> [Float] -- ^ The filter coefficients 388 | -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure 389 | fastDecimatorSymR info = featureSelect info (error "at least AVX required") [(hasAVX, fastDecimatorSymAVXR), (hasSSE42, fastDecimatorSymSSER)] 390 | 391 | {-# INLINE haskellResampler #-} 392 | -- | Returns a slow Resampler data structure entirely implemented in Haskell 393 | haskellResampler :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) 394 | => Int -- ^ The interpolation factor 395 | -> Int -- ^ The decimation factor 396 | -> [b] -- ^ The filter coefficients 397 | -> IO (Resampler m v vm a) -- ^ The `Resampler` data structure 398 | haskellResampler interpolationR decimationR coeffs = do 399 | let vCoeffs = VG.fromList coeffs 400 | evaluate vCoeffs 401 | let resampleOne v w x y = func <$> resampleHighLevel interpolationR decimationR vCoeffs v w x y 402 | resampleCross v w x y z = func <$> resampleCrossHighLevel interpolationR decimationR vCoeffs v w x y z 403 | numCoeffsR = length coeffs 404 | func x = (x, x) 405 | startDat = 0 406 | return Resampler {..} 407 | 408 | mkResampler :: Int 409 | -> ResampleRR 410 | -> Int 411 | -> Int 412 | -> [Float] 413 | -> IO (Resampler IO VS.Vector VS.MVector Float) 414 | mkResampler sizeMultiple filterFunc interpolationR decimationR coeffs = do 415 | let vCoeffs = VG.fromList coeffs 416 | evaluate vCoeffs 417 | resamp <- filterFunc interpolationR decimationR coeffs 418 | let resampleOne v w x y = func1 <$> resamp (fst v) w x y 419 | resampleCross (group, offset) count x y z = do 420 | offset' <- resampleCrossHighLevel interpolationR decimationR vCoeffs offset count x y z 421 | return (((group + count) `mod` interpolationR, offset'), offset') 422 | numCoeffsR = roundUp (length coeffs) (interpolationR * sizeMultiple) 423 | func1 group = let offset = interpolationR - 1 - ((interpolationR + group * decimationR - 1) `mod` interpolationR) in ((group, offset), offset) 424 | startDat = (0, 0) 425 | return Resampler {..} 426 | 427 | mkResamplerC :: Int 428 | -> ResampleRC 429 | -> Int 430 | -> Int 431 | -> [Float] 432 | -> IO (Resampler IO VS.Vector VS.MVector (Complex Float)) 433 | mkResamplerC sizeMultiple filterFunc interpolationR decimationR coeffs = do 434 | let vCoeffs = VG.fromList coeffs 435 | evaluate vCoeffs 436 | resamp <- filterFunc interpolationR decimationR coeffs 437 | let resampleOne v w x y = func1 <$> resamp (fst v) w x y 438 | resampleCross (group, offset) count x y z = do 439 | offset' <- resampleCrossHighLevel interpolationR decimationR vCoeffs offset count x y z 440 | return (((group + count) `mod` interpolationR, offset'), offset') 441 | numCoeffsR = roundUp (length coeffs) (interpolationR * sizeMultiple) 442 | func1 group = let offset = interpolationR - 1 - ((interpolationR + group * decimationR - 1) `mod` interpolationR) in ((group, offset), offset) 443 | startDat = (0, 0) 444 | return Resampler {..} 445 | 446 | -- | Returns a fast Resampler data structure implemented in C. For filtering real data with real coefficients. 447 | fastResamplerCR :: Int -- ^ The interpolation factor 448 | -> Int -- ^ The decimation factor 449 | -> [Float] -- ^ The filter coefficients 450 | -> IO (Resampler IO VS.Vector VS.MVector Float) -- ^ The `Resampler` data structure 451 | fastResamplerCR = mkResampler 1 resampleCRR2 452 | 453 | -- | Returns a fast Resampler data structure implemented in C using SSE instructions. For filtering real data with real coefficients. 454 | fastResamplerSSER :: Int -- ^ The interpolation factor 455 | -> Int -- ^ The decimation factor 456 | -> [Float] -- ^ The filter coefficients 457 | -> IO (Resampler IO VS.Vector VS.MVector Float) -- ^ The `Resampler` data structure 458 | fastResamplerSSER = mkResampler 4 resampleCSSERR 459 | 460 | -- | Returns a fast Resampler data structure implemented in C using AVX instructions. For filtering real data with real coefficients. 461 | fastResamplerAVXR :: Int -- ^ The interpolation factor 462 | -> Int -- ^ The decimation factor 463 | -> [Float] -- ^ The filter coefficients 464 | -> IO (Resampler IO VS.Vector VS.MVector Float) -- ^ The `Resampler` data structure 465 | fastResamplerAVXR = mkResampler 8 resampleCAVXRR 466 | 467 | -- | Returns a fast Resampler data structure implemented in C using the fastest SIMD instruction set your processor supports. For resampling real data with real coefficients. 468 | fastResamplerR :: CPUInfo -- ^ The CPU's capabilities 469 | -> Int -- ^ The interpolation factor 470 | -> Int -- ^ The decimation factor 471 | -> [Float] -- ^ The filter coefficients 472 | -> IO (Resampler IO VS.Vector VS.MVector Float) -- ^ The `Resampler` data structure 473 | fastResamplerR info = featureSelect info fastResamplerCR [(hasAVX, fastResamplerAVXR), (hasSSE42, fastResamplerSSER)] 474 | 475 | -- | Returns a fast Resampler data structure implemented in C. For filtering complex data with real coefficients. 476 | fastResamplerCC :: Int -- ^ The interpolation factor 477 | -> Int -- ^ The decimation factor 478 | -> [Float] -- ^ The filter coefficients 479 | -> IO (Resampler IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Resampler` data structure 480 | fastResamplerCC = mkResamplerC 1 resampleCRC 481 | 482 | -- | Returns a fast Resampler data structure implemented in C using SSE instructions. For filtering complex data with real coefficients. 483 | fastResamplerSSEC :: Int -- ^ The interpolation factor 484 | -> Int -- ^ The decimation factor 485 | -> [Float] -- ^ The filter coefficients 486 | -> IO (Resampler IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Resampler` data structure 487 | fastResamplerSSEC = mkResamplerC 4 resampleCSSERC 488 | 489 | -- | Returns a fast Resampler data structure implemented in C using AVX instructions. For filtering complex data with real coefficients. 490 | fastResamplerAVXC :: Int -- ^ The interpolation factor 491 | -> Int -- ^ The decimation factor 492 | -> [Float] -- ^ The filter coefficients 493 | -> IO (Resampler IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Resampler` data structure 494 | fastResamplerAVXC = mkResamplerC 8 resampleCAVXRC 495 | 496 | -- | Returns a fast Resampler data structure implemented in C using the fastest SIMD instruction set your processor supports. For resampling complex data with real coefficients. 497 | fastResamplerC :: CPUInfo -- ^ The CPU's capabilities 498 | -> Int -- ^ The interpolation factor 499 | -> Int -- ^ The decimation factor 500 | -> [Float] -- ^ The filter coefficients 501 | -> IO (Resampler IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Resampler` data structure 502 | fastResamplerC info = featureSelect info fastResamplerCC [(hasAVX, fastResamplerAVXC), (hasSSE42, fastResamplerSSEC)] 503 | 504 | data Buffer v a = Buffer { 505 | buffer :: v a, 506 | offset :: Int 507 | } 508 | 509 | space Buffer{..} = VGM.length buffer - offset 510 | 511 | newBuffer :: (PrimMonad m, VGM.MVector vm a) => Int -> m (Buffer (vm (PrimState m)) a) 512 | newBuffer size = do 513 | buf <- VGM.new size 514 | return $ Buffer buf 0 515 | 516 | advanceOutBuf :: (PrimMonad m, VG.Vector v a) => Int -> Buffer (VG.Mutable v (PrimState m)) a -> Int -> Pipe b (v a) m (Buffer (VG.Mutable v (PrimState m)) a) 517 | advanceOutBuf blockSizeOut buf@(Buffer bufOut offsetOut) count = 518 | if count == space buf then do 519 | bufOutF <- lift $ VG.unsafeFreeze bufOut 520 | yield bufOutF 521 | lift $ newBuffer blockSizeOut 522 | else 523 | return $ Buffer bufOut (offsetOut + count) 524 | 525 | -- | My own assert implementation since the GHC one doesnt seem to work even with optimisations disabled and using -fno-ignore-asserts 526 | assert loc False = error loc 527 | assert loc True = return () 528 | 529 | --Filtering 530 | {-# INLINE firFilter #-} 531 | {-| Create a pipe that performs filtering -} 532 | firFilter :: (PrimMonad m, Functor m, VG.Vector v a, Num a) 533 | => Filter m v (VG.Mutable v) a -- ^ The `Filter` data structure 534 | -> Int -- ^ The output block size 535 | -> Pipe (v a) (v a) m () -- ^ The `Pipe` that does the filtering 536 | firFilter Filter{..} blockSizeOut = do 537 | inBuf <- await 538 | outBuf <- lift $ newBuffer blockSizeOut 539 | simple inBuf outBuf 540 | 541 | where 542 | 543 | simple bufIn bufferOut@(Buffer bufOut offsetOut) = do 544 | assert "filter 1" (VG.length bufIn >= numCoeffsF) 545 | 546 | let count = min (VG.length bufIn - numCoeffsF + 1) (space bufferOut) 547 | lift $ filterOne count bufIn (VGM.unsafeDrop offsetOut bufOut) 548 | 549 | bufferOut' <- advanceOutBuf blockSizeOut bufferOut count 550 | let bufIn' = VG.drop count bufIn 551 | 552 | case VG.length bufIn' < numCoeffsF of 553 | False -> simple bufIn' bufferOut' 554 | True -> do 555 | next <- await 556 | crossover bufIn' next bufferOut' 557 | 558 | crossover bufLast bufNext bufferOut@(Buffer bufOut offsetOut) = do 559 | assert "filter 2" (VG.length bufLast < numCoeffsF) 560 | assert "filter 3" (VG.length bufLast > 0) 561 | 562 | let count = min (VG.length bufLast) (space bufferOut) 563 | lift $ filterCross count bufLast bufNext (VGM.unsafeDrop offsetOut bufOut) 564 | 565 | bufferOut' <- advanceOutBuf blockSizeOut bufferOut count 566 | 567 | case VG.length bufLast == count of 568 | True -> simple bufNext bufferOut' 569 | False -> crossover (VG.drop count bufLast) bufNext bufferOut' 570 | 571 | --Decimation 572 | {-# INLINE firDecimator #-} 573 | {-| Create a pipe that performs decimation -} 574 | firDecimator :: (PrimMonad m, Functor m, VG.Vector v a, Num a) 575 | => Decimator m v (VG.Mutable v) a -- ^ The `Decimator` data structure 576 | -> Int -- ^ The output block size 577 | -> Pipe (v a) (v a) m () -- ^ The `Pipe` that does the decimation 578 | firDecimator Decimator{..} blockSizeOut = do 579 | inBuf <- await 580 | outBuf <- lift $ newBuffer blockSizeOut 581 | simple inBuf outBuf 582 | 583 | where 584 | 585 | simple bufIn bufferOut@(Buffer bufOut offsetOut) = do 586 | assert "decimate 1" (VG.length bufIn >= numCoeffsD) 587 | 588 | let count = min (((VG.length bufIn - numCoeffsD) `quot` decimationD) + 1) (space bufferOut) 589 | lift $ decimateOne count bufIn (VGM.unsafeDrop offsetOut bufOut) 590 | 591 | bufferOut' <- advanceOutBuf blockSizeOut bufferOut count 592 | let bufIn' = VG.drop (count * decimationD) bufIn 593 | 594 | case VG.length bufIn' < numCoeffsD of 595 | False -> simple bufIn' bufferOut' 596 | True -> do 597 | next <- await 598 | crossover bufIn' next bufferOut' 599 | 600 | crossover bufLast bufNext bufferOut@(Buffer bufOut offsetOut) = do 601 | assert "decimate 2" (VG.length bufLast < numCoeffsD) 602 | assert "decimate 3" (VG.length bufLast > 0) 603 | 604 | let count = min (VG.length bufLast `quotUp` decimationD) (space bufferOut) 605 | lift $ decimateCross count bufLast bufNext (VGM.unsafeDrop offsetOut bufOut) 606 | 607 | bufferOut' <- advanceOutBuf blockSizeOut bufferOut count 608 | 609 | case VG.length bufLast <= count * decimationD of 610 | True -> simple (VG.drop (count * decimationD - VG.length bufLast) bufNext) bufferOut' 611 | False -> crossover (VG.drop (count * decimationD) bufLast) bufNext bufferOut' 612 | 613 | {- 614 | Rational Downsampling: 615 | 616 | Input upsampled by 3: |**|**|**|**|**|**|**|**|**|**|**| 617 | Output downsampled by 7: |******|******|******|******|***** 618 | 619 | Consider here ^ 620 | Next output is here ^ 621 | 622 | Filter offset is 2 623 | 624 | k is number of used inputs 625 | 626 | filterOffset + k*interpolation = decimation + filterOffset' 627 | where 628 | k > 0 629 | 0 <= filterOffset, filterOffset' < interpolation 630 | 631 | k*interpolation - filterOffset' = decimation - filterOffset 632 | k*interpolation - filterOffset' - 1 = decimation - filterOffset - 1 633 | 634 | (k-1) * interpolation + (interpolation - filterOffset' - 1) = decimation - filterOffset - 1 635 | 636 | k = (decimation - filterOffset - 1) / interpolation + 1 637 | filterOffset' = interpolation - 1 - (decimation - filterOffset - 1) % interpolation 638 | 639 | Only works if decimation > interpolation 640 | 641 | -} 642 | 643 | {- 644 | Rational Upsampling: 645 | 646 | Input upsampled by 7: |******|******|******|******|***** 647 | Output downsampled by 3: |**|**|**|**|**|**|**|**|**|**|**| 648 | 649 | Consider Here ^ 650 | Next sample is ^ 651 | 652 | Filter offset is 4 653 | 654 | filterOffset + k * interpolation = decimation + filterOffset' 655 | where 656 | k = {0, 1} 657 | 0 <= filterOffset, filterOffset' < interpolation 658 | 659 | k * interpolation + (interpolation - filterOffset' - 1) = decimation - filterOffset + interpolation - 1 660 | 661 | k = (decimation - filterOffset + interpolation - 1) / interpolation 662 | 663 | ============================ 664 | 665 | Or, equivalently, 666 | 667 | k = 0 | filterOffset >= decimation 668 | 1 | otherwise 669 | 670 | o = o - decimation + k * interpolation 671 | 672 | -} 673 | 674 | --Rational resampling 675 | quotUp q d = (q + (d - 1)) `quot` d 676 | 677 | {-# INLINE firResampler #-} 678 | {-| Create a pipe that performs resampling -} 679 | firResampler :: (PrimMonad m, VG.Vector v a, Num a) 680 | => Resampler m v (VG.Mutable v) a -- ^ The `Resampler` data structure 681 | -> Int -- ^ The output block size 682 | -> Pipe (v a) (v a) m () -- ^ The `Pipe` that does the resampling 683 | firResampler Resampler{..} blockSizeOut = do 684 | inBuf <- await 685 | outBuf <- lift $ newBuffer blockSizeOut 686 | simple inBuf outBuf startDat 0 687 | 688 | where 689 | 690 | simple bufIn bufferOut@(Buffer bufOut offsetOut) dat filterOffset = do 691 | assert "resample 1" (VG.length bufIn * interpolationR >= numCoeffsR - filterOffset) 692 | --available number of samples == interpolation * num_input 693 | --required number of samples == decimation * (num_output - 1) + filter_length - filter_offset 694 | let count = min (((VG.length bufIn * interpolationR - numCoeffsR + filterOffset) `quot` decimationR) + 1) (space bufferOut) 695 | (dat, endOffset) <- lift $ resampleOne dat count bufIn (VGM.unsafeDrop offsetOut bufOut) 696 | assert "resample 2" ((count * decimationR + endOffset - filterOffset) `rem` interpolationR == 0) 697 | bufferOut' <- advanceOutBuf blockSizeOut bufferOut count 698 | --samples no longer needed starting from filterOffset == count * decimation - filterOffset 699 | --inputs lying in this region == (count * decimation - filterOffset) / interpolation (rounding up) 700 | let usedInput = (count * decimationR - filterOffset) `quotUp` interpolationR 701 | bufIn' = VG.drop usedInput bufIn 702 | 703 | case VG.length bufIn' * interpolationR < numCoeffsR - endOffset of 704 | False -> simple bufIn' bufferOut' dat endOffset 705 | True -> do 706 | next <- await 707 | --TODO: why is this not needed in filter and decimator 708 | case VG.length bufIn' == 0 of 709 | True -> simple next bufferOut' dat endOffset 710 | False -> crossover bufIn' next bufferOut' dat endOffset 711 | 712 | crossover bufLast bufNext bufferOut@(Buffer bufOut offsetOut) dat filterOffset = do 713 | assert "resample 3" (VG.length bufLast * interpolationR < numCoeffsR - filterOffset) 714 | --outputsComputable is the number of outputs that need to be computed for the last buffer to no longer be needed 715 | --outputsComputable * decimation == numInput * interpolation + filterOffset + k 716 | let outputsComputable = (VG.length bufLast * interpolationR + filterOffset) `quotUp` decimationR 717 | count = min outputsComputable (space bufferOut) 718 | assert "resample 4" (count /= 0) 719 | (dat, endOffset) <- lift $ resampleCross dat count bufLast bufNext (VGM.unsafeDrop offsetOut bufOut) 720 | assert "resample 5" ((count * decimationR + endOffset - filterOffset) `rem` interpolationR == 0) 721 | bufferOut' <- advanceOutBuf blockSizeOut bufferOut count 722 | 723 | let inputUsed = (count * decimationR - filterOffset) `quotUp` interpolationR 724 | 725 | case inputUsed >= VG.length bufLast of 726 | True -> simple (VG.drop (inputUsed - VG.length bufLast) bufNext) bufferOut' dat endOffset 727 | False -> crossover (VG.drop inputUsed bufLast) bufNext bufferOut' dat endOffset 728 | 729 | -- | A DC blocking filter 730 | dcBlockingFilter :: Pipe (VS.Vector Float) (VS.Vector Float) IO () 731 | dcBlockingFilter = func 0 0 732 | where 733 | func lastSample lastOutput = do 734 | dat <- await 735 | out <- lift $ VGM.new (VG.length dat) 736 | (lastSample, lastOutput) <- lift $ dcBlocker (VG.length dat) lastSample lastOutput dat out 737 | outF <- lift $ VG.unsafeFreeze out 738 | yield outF 739 | func lastSample lastOutput 740 | 741 | -------------------------------------------------------------------------------- /hs_sources/SDR/FilterDesign.hs: -------------------------------------------------------------------------------- 1 | {-| Filter design and plotting of frequency responses. -} 2 | 3 | module SDR.FilterDesign ( 4 | -- * Sinc Function 5 | sinc, 6 | 7 | -- * Root raised cosine 8 | srrc, 9 | 10 | -- * Windows 11 | hanning, 12 | hamming, 13 | blackman, 14 | 15 | -- * Convenience Functions 16 | windowedSinc, 17 | 18 | -- * Frequency Response Plot 19 | plotFrequency 20 | ) where 21 | 22 | import Graphics.Rendering.Chart.Easy 23 | import Graphics.Rendering.Chart.Backend.Cairo 24 | import Data.Complex 25 | 26 | import qualified Data.Vector.Generic as VG 27 | 28 | -- | Compute a sinc function 29 | sinc :: (Floating n, VG.Vector v n) 30 | => Int -- ^ The length. Must be odd. 31 | -> n -- ^ The cutoff frequency (from 0 to 1) 32 | -> v n 33 | sinc size cutoff = VG.generate size (func . (-) ((size - 1) `quot` 2)) 34 | where 35 | func 0 = cutoff 36 | func idx = sin (pi * cutoff * fromIntegral idx) / (fromIntegral idx * pi) 37 | 38 | -- | Compute a Hanning window. 39 | hanning :: (Floating n, VG.Vector v n) 40 | => Int -- ^ The length of the window 41 | -> v n 42 | hanning size = VG.generate size func 43 | where 44 | func idx = 0.5 * (1 - cos((2 * pi * fromIntegral idx) / (fromIntegral size - 1))) 45 | 46 | -- | Compute a Hamming window. 47 | hamming :: (Floating n, VG.Vector v n) 48 | => Int -- ^ The length of the window 49 | -> v n 50 | hamming size = VG.generate size func 51 | where 52 | func idx = 0.54 - 0.46 * cos((2 * pi * fromIntegral idx) / (fromIntegral size - 1)) 53 | 54 | -- | Compute a Blackman window. 55 | blackman :: (Floating n, VG.Vector v n) 56 | => Int -- ^ The length of the window 57 | -> v n 58 | blackman size = VG.generate size func 59 | where 60 | func idx = 0.42 - 0.5 * cos((2 * pi * fromIntegral idx) / (fromIntegral size - 1)) + 0.08 * cos((4 * pi * fromIntegral idx) / (fromIntegral size - 1)) 61 | 62 | -- | Compute a windowed sinc function 63 | windowedSinc :: (Floating n, VG.Vector v n) 64 | => Int -- ^ The length 65 | -> n -- ^ The cutoff frequency (from 0 to 1) 66 | -> (Int -> v n) -- ^ The window function 67 | -> v n 68 | windowedSinc size cutoff window = VG.zipWith (*) (sinc size cutoff) (window size) 69 | 70 | signal :: [Double] -> [Double] -> [(Double, Double)] 71 | signal coeffs xs = [ (x / pi, func x) | x <- xs ] 72 | where 73 | func phase = magnitude $ sum $ zipWith (\index mag -> mkPolar mag (phase * (- index))) (iterate (+ 1) (- ((fromIntegral (length coeffs) - 1) / 2))) coeffs 74 | 75 | -- | Given filter coefficients, plot their frequency response and save the graph as a png file 76 | plotFrequency :: [Double] -- ^ The filter coefficients 77 | -> FilePath -- ^ The filename 78 | -> IO () 79 | plotFrequency coeffs fName = toFile def fName $ do 80 | layout_title .= "Frequency Response" 81 | plot (line "Frequency Response" [signal coeffs $ takeWhile (< pi) $ iterate (+ 0.01) 0]) 82 | 83 | --ts is really the ratio ts / sampling period 84 | -- | Square root raised cosine 85 | srrc :: (Ord a, Floating a) 86 | => Int -- ^ size: from [-n .. n] 87 | -> Int -- ^ sampling period 88 | -> a -- ^ beta 89 | -> [a] 90 | srrc n ts beta = map func [(-n) .. n] 91 | where 92 | func x 93 | | x == 0 = 1 - beta + 4 * beta / pi 94 | | abs (fromIntegral x) ~= (fromIntegral ts / (4 * beta)) = (beta / sqrt 2) * ((1 + 2/pi) * sin (pi / (4 * beta)) + (1 - 2/pi) * cos (pi / (4 * beta))) 95 | | otherwise = (sin (pi * xdivts * (1 - beta)) + 4 * beta * xdivts * cos (pi * xdivts * (1 + beta))) / (pi * xdivts * (1 - (4 * beta * xdivts) ** 2)) 96 | where 97 | xdivts = fromIntegral x / fromIntegral ts 98 | x ~= y = abs (x - y) < 0.001 99 | 100 | -------------------------------------------------------------------------------- /hs_sources/SDR/FilterInternal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, BangPatterns, RecordWildCards #-} 2 | 3 | {-| Functions used internally by the SDR.Filter module. Most of these are 4 | not actually used but exist for benchmarking purposes to determine the 5 | fastest filter implementation. 6 | -} 7 | module SDR.FilterInternal where 8 | 9 | import Control.Monad.Primitive 10 | import Control.Monad 11 | import Foreign.C.Types 12 | import Foreign.Ptr 13 | import Data.Coerce 14 | import Data.Complex 15 | import Foreign.Marshal.Array 16 | import Foreign.Marshal.Alloc 17 | import Foreign.Storable 18 | 19 | import qualified Data.Vector.Generic as VG 20 | import qualified Data.Vector.Generic.Mutable as VGM 21 | import qualified Data.Vector.Storable as VS 22 | import qualified Data.Vector.Storable.Mutable as VSM 23 | import qualified Data.Vector.Fusion.Bundle as VFB 24 | 25 | import SDR.VectorUtils 26 | import SDR.Util 27 | 28 | {-# INLINE filterHighLevel #-} 29 | filterHighLevel :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) => v b -> Int -> v a -> vm (PrimState m) a -> m () 30 | filterHighLevel coeffs num inBuf outBuf = fill (VFB.generate num dotProd) outBuf 31 | where 32 | dotProd offset = VG.sum $ VG.zipWith mult (VG.unsafeDrop offset inBuf) coeffs 33 | 34 | {-# INLINE filterImperative1 #-} 35 | filterImperative1 :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) => v b -> Int -> v a -> vm (PrimState m) a -> m () 36 | filterImperative1 coeffs num inBuf outBuf = go 0 37 | where 38 | go offset 39 | | offset < num = do 40 | let res = dotProd offset 41 | VGM.unsafeWrite outBuf offset res 42 | go $ offset + 1 43 | | otherwise = return () 44 | dotProd offset = VG.sum $ VG.zipWith mult (VG.unsafeDrop offset inBuf) coeffs 45 | 46 | {-# INLINE filterImperative2 #-} 47 | filterImperative2 :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) => v b -> Int -> v a -> vm (PrimState m) a -> m () 48 | filterImperative2 coeffs num inBuf outBuf = go 0 49 | where 50 | go offset 51 | | offset < num = do 52 | let res = dotProd (VG.unsafeDrop offset inBuf) 53 | VGM.unsafeWrite outBuf offset res 54 | go $ offset + 1 55 | | otherwise = return () 56 | dotProd buf = go 0 0 57 | where 58 | go !accum j 59 | | j < VG.length coeffs = go (VG.unsafeIndex buf j `mult` VG.unsafeIndex coeffs j + accum) (j + 1) 60 | | otherwise = accum 61 | 62 | type FilterCRR = CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 63 | type FilterRR = VS.Vector Float -> Int -> VS.Vector Float -> VS.MVector RealWorld Float -> IO () 64 | type FilterRC = VS.Vector Float -> Int -> VS.Vector (Complex Float) -> VS.MVector RealWorld (Complex Float) -> IO () 65 | 66 | filterFFIR :: FilterCRR -> FilterRR 67 | filterFFIR func coeffs num inBuf outBuf = 68 | VS.unsafeWith (VS.unsafeCoerceVector coeffs) $ \cPtr -> 69 | VS.unsafeWith (VS.unsafeCoerceVector inBuf) $ \iPtr -> 70 | VSM.unsafeWith (VSM.unsafeCoerceMVector outBuf) $ \oPtr -> 71 | func (fromIntegral num) (fromIntegral $ VG.length coeffs) cPtr iPtr oPtr 72 | 73 | filterFFIC :: FilterCRR -> FilterRC 74 | filterFFIC func coeffs num inBuf outBuf = 75 | VS.unsafeWith (VS.unsafeCoerceVector coeffs) $ \cPtr -> 76 | VS.unsafeWith (VS.unsafeCast inBuf) $ \iPtr -> 77 | VSM.unsafeWith (VSM.unsafeCast outBuf) $ \oPtr -> 78 | func (fromIntegral num) (fromIntegral $ VG.length coeffs) cPtr iPtr oPtr 79 | 80 | foreign import ccall unsafe "filterRR" 81 | filterRR_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 82 | 83 | filterCRR :: FilterRR 84 | filterCRR = filterFFIR filterRR_c 85 | 86 | foreign import ccall unsafe "filterRC" 87 | filterRC_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 88 | 89 | filterCRC :: FilterRC 90 | filterCRC = filterFFIC filterRC_c 91 | 92 | foreign import ccall unsafe "filterSSERR" 93 | filterSSERR_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 94 | 95 | filterCSSERR :: FilterRR 96 | filterCSSERR = filterFFIR filterSSERR_c 97 | 98 | foreign import ccall unsafe "filterSSESymmetricRR" 99 | filterSSESymmetricRR_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 100 | 101 | filterCSSESymmetricRR :: FilterRR 102 | filterCSSESymmetricRR = filterFFIR filterSSESymmetricRR_c 103 | 104 | foreign import ccall unsafe "filterSSERC" 105 | filterSSERC_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 106 | 107 | filterCSSERC :: FilterRC 108 | filterCSSERC = filterFFIC filterSSERC_c 109 | 110 | foreign import ccall unsafe "filterSSERC2" 111 | filterSSERC2_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 112 | 113 | filterCSSERC2 :: FilterRC 114 | filterCSSERC2 = filterFFIC filterSSERC2_c 115 | 116 | foreign import ccall unsafe "filterAVXRR" 117 | filterAVXRR_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 118 | 119 | filterCAVXRR :: FilterRR 120 | filterCAVXRR = filterFFIR filterAVXRR_c 121 | 122 | foreign import ccall unsafe "filterAVXSymmetricRR" 123 | filterAVXSymmetricRR_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 124 | 125 | filterCAVXSymmetricRR :: FilterRR 126 | filterCAVXSymmetricRR = filterFFIR filterAVXSymmetricRR_c 127 | 128 | foreign import ccall unsafe "filterAVXRC" 129 | filterAVXRC_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 130 | 131 | filterCAVXRC :: FilterRC 132 | filterCAVXRC = filterFFIC filterAVXRC_c 133 | 134 | foreign import ccall unsafe "filterAVXRC2" 135 | filterAVXRC2_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 136 | 137 | filterCAVXRC2 :: FilterRC 138 | filterCAVXRC2 = filterFFIC filterAVXRC2_c 139 | 140 | foreign import ccall unsafe "filterSSESymmetricRC" 141 | filterSSESymmetricRC_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 142 | 143 | filterCSSESymmetricRC :: FilterRC 144 | filterCSSESymmetricRC = filterFFIC filterSSESymmetricRC_c 145 | 146 | foreign import ccall unsafe "filterAVXSymmetricRC" 147 | filterAVXSymmetricRC_c :: CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 148 | 149 | filterCAVXSymmetricRC :: FilterRC 150 | filterCAVXSymmetricRC = filterFFIC filterAVXSymmetricRC_c 151 | 152 | -- Decimation 153 | 154 | {-# INLINE decimateHighLevel #-} 155 | decimateHighLevel :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) => Int -> v b -> Int -> v a -> vm (PrimState m) a -> m () 156 | decimateHighLevel factor coeffs num inBuf outBuf = fill x outBuf 157 | where 158 | x = VFB.map dotProd (VFB.iterateN num (+ factor) 0) 159 | dotProd offset = VG.sum $ VG.zipWith mult (VG.unsafeDrop offset inBuf) coeffs 160 | 161 | type DecimateCRR = CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 162 | type DecimateRR = Int -> VS.Vector Float -> Int -> VS.Vector Float -> VS.MVector RealWorld Float -> IO () 163 | type DecimateRC = Int -> VS.Vector Float -> Int -> VS.Vector (Complex Float) -> VS.MVector RealWorld (Complex Float) -> IO () 164 | 165 | decimateFFIR :: DecimateCRR -> DecimateRR 166 | decimateFFIR func factor coeffs num inBuf outBuf = 167 | VS.unsafeWith (VS.unsafeCoerceVector coeffs) $ \cPtr -> 168 | VS.unsafeWith (VS.unsafeCoerceVector inBuf) $ \iPtr -> 169 | VSM.unsafeWith (VSM.unsafeCoerceMVector outBuf) $ \oPtr -> 170 | func (fromIntegral num) (fromIntegral factor) (fromIntegral $ VG.length coeffs) cPtr iPtr oPtr 171 | 172 | decimateFFIC :: DecimateCRR -> DecimateRC 173 | decimateFFIC func factor coeffs num inBuf outBuf = 174 | VS.unsafeWith (VS.unsafeCoerceVector coeffs) $ \cPtr -> 175 | VS.unsafeWith (VS.unsafeCast inBuf) $ \iPtr -> 176 | VSM.unsafeWith (VSM.unsafeCast outBuf) $ \oPtr -> 177 | func (fromIntegral num) (fromIntegral factor) (fromIntegral $ VG.length coeffs) cPtr iPtr oPtr 178 | 179 | foreign import ccall unsafe "decimateRR" 180 | decimateCRR_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 181 | 182 | decimateCRR :: DecimateRR 183 | decimateCRR = decimateFFIR decimateCRR_c 184 | 185 | foreign import ccall unsafe "decimateRC" 186 | decimateCRC_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 187 | 188 | decimateCRC :: DecimateRC 189 | decimateCRC = decimateFFIC decimateCRC_c 190 | 191 | foreign import ccall unsafe "decimateSSERR" 192 | decimateSSERR_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 193 | 194 | decimateCSSERR :: DecimateRR 195 | decimateCSSERR = decimateFFIR decimateSSERR_c 196 | 197 | foreign import ccall unsafe "decimateSSERC" 198 | decimateSSERC_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 199 | 200 | decimateCSSERC :: DecimateRC 201 | decimateCSSERC = decimateFFIC decimateSSERC_c 202 | 203 | foreign import ccall unsafe "decimateSSERC2" 204 | decimateSSERC2_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 205 | 206 | decimateCSSERC2 :: DecimateRC 207 | decimateCSSERC2 = decimateFFIC decimateSSERC2_c 208 | 209 | foreign import ccall unsafe "decimateAVXRR" 210 | decimateAVXRR_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 211 | 212 | decimateCAVXRR :: DecimateRR 213 | decimateCAVXRR = decimateFFIR decimateAVXRR_c 214 | 215 | foreign import ccall unsafe "decimateAVXRC" 216 | decimateAVXRC_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 217 | 218 | decimateCAVXRC :: DecimateRC 219 | decimateCAVXRC = decimateFFIC decimateAVXRC_c 220 | 221 | foreign import ccall unsafe "decimateAVXRC2" 222 | decimateAVXRC2_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 223 | 224 | decimateCAVXRC2 :: DecimateRC 225 | decimateCAVXRC2 = decimateFFIC decimateAVXRC2_c 226 | 227 | foreign import ccall unsafe "decimateSSESymmetricRR" 228 | decimateSSESymmetricRR_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 229 | 230 | decimateCSSESymmetricRR :: DecimateRR 231 | decimateCSSESymmetricRR = decimateFFIR decimateSSESymmetricRR_c 232 | 233 | foreign import ccall unsafe "decimateAVXSymmetricRR" 234 | decimateAVXSymmetricRR_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 235 | 236 | decimateCAVXSymmetricRR :: DecimateRR 237 | decimateCAVXSymmetricRR = decimateFFIR decimateAVXSymmetricRR_c 238 | 239 | foreign import ccall unsafe "decimateSSESymmetricRC" 240 | decimateSSESymmetricRC_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 241 | 242 | decimateCSSESymmetricRC :: DecimateRC 243 | decimateCSSESymmetricRC = decimateFFIC decimateSSESymmetricRC_c 244 | 245 | foreign import ccall unsafe "decimateAVXSymmetricRC" 246 | decimateAVXSymmetricRC_c :: CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 247 | 248 | decimateCAVXSymmetricRC :: DecimateRC 249 | decimateCAVXSymmetricRC = decimateFFIC decimateAVXSymmetricRC_c 250 | 251 | -- Resampling 252 | {-# INLINE resampleHighLevel #-} 253 | resampleHighLevel :: (PrimMonad m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) => Int -> Int -> v b -> Int -> Int -> v a -> vm (PrimState m) a -> m Int 254 | resampleHighLevel interpolation decimation coeffs filterOffset count inBuf outBuf = fill 0 filterOffset 0 255 | where 256 | fill i filterOffset inputOffset 257 | | i < count = do 258 | let dp = dotProd filterOffset inputOffset 259 | VGM.unsafeWrite outBuf i dp 260 | let (q, r) = divMod (decimation - filterOffset - 1) interpolation 261 | inputOffset' = inputOffset + q + 1 262 | filterOffset' = interpolation - 1 - r 263 | filterOffset' `seq` inputOffset' `seq` fill (i + 1) filterOffset' inputOffset' 264 | | otherwise = return filterOffset 265 | dotProd filterOffset offset = VG.sum $ VG.zipWith mult (VG.unsafeDrop offset inBuf) (stride interpolation (VG.unsafeDrop filterOffset coeffs)) 266 | 267 | foreign import ccall unsafe "resampleRR" 268 | resample_c :: CInt -> CInt -> CInt -> CInt -> CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 269 | 270 | resampleCRR :: Int -> Int -> Int -> Int -> VS.Vector Float -> VS.Vector Float -> VS.MVector RealWorld Float -> IO () 271 | resampleCRR num interpolation decimation offset coeffs inBuf outBuf = 272 | VS.unsafeWith (VS.unsafeCoerceVector coeffs) $ \cPtr -> 273 | VS.unsafeWith (VS.unsafeCoerceVector inBuf) $ \iPtr -> 274 | VSM.unsafeWith (VSM.unsafeCoerceMVector outBuf) $ \oPtr -> 275 | resample_c (fromIntegral num) (fromIntegral $ VG.length coeffs) (fromIntegral interpolation) (fromIntegral decimation) (fromIntegral offset) cPtr iPtr oPtr 276 | 277 | pad :: a -> Int -> [a] -> [a] 278 | pad with num list = list ++ replicate (num - length list) with 279 | 280 | strideList :: Int -> [a] -> [a] 281 | strideList s xs = go 0 xs 282 | where 283 | go _ [] = [] 284 | go 0 (x:xs) = x : go (s-1) xs 285 | go n (x:xs) = go (n - 1) xs 286 | 287 | roundUp :: Int -> Int -> Int 288 | roundUp num div = ((num + div - 1) `quot` div) * div 289 | 290 | data Coeffs = Coeffs { 291 | numCoeffs :: Int, 292 | numGroups :: Int, 293 | increments :: [Int], 294 | groups :: [[Float]] 295 | } 296 | 297 | prepareCoeffs :: Int -> Int -> Int -> [Float] -> Coeffs 298 | prepareCoeffs n interpolation decimation coeffs = Coeffs {..} 299 | where 300 | numCoeffs = maximum $ map (length . snd) dats 301 | numGroups = length groups 302 | increments = map fst dats 303 | 304 | groups :: [[Float]] 305 | groups = map (pad 0 (roundUp numCoeffs n)) $ map snd dats 306 | 307 | dats :: [(Int, [Float])] 308 | dats = func 0 309 | where 310 | 311 | func' 0 = [] 312 | func' x = func x 313 | 314 | func :: Int -> [(Int, [Float])] 315 | func offset = (increment, strideList interpolation $ drop offset coeffs) : func' offset' 316 | where 317 | (q, r) = divMod (decimation - offset - 1) interpolation 318 | increment = q + 1 319 | offset' = interpolation - 1 - r 320 | 321 | resampleFFIR :: (Ptr CFloat -> Ptr CFloat -> IO CInt) -> VS.Vector Float -> VSM.MVector RealWorld Float -> IO Int 322 | resampleFFIR func inBuf outBuf = liftM fromIntegral $ 323 | VS.unsafeWith (VS.unsafeCoerceVector inBuf) $ \iPtr -> 324 | VSM.unsafeWith (VSM.unsafeCoerceMVector outBuf) $ \oPtr -> 325 | func iPtr oPtr 326 | 327 | resampleFFIC :: (Ptr CFloat -> Ptr CFloat -> IO CInt) -> VS.Vector (Complex Float) -> VSM.MVector RealWorld (Complex Float) -> IO Int 328 | resampleFFIC func inBuf outBuf = liftM fromIntegral $ 329 | VS.unsafeWith (VS.unsafeCast inBuf) $ \iPtr -> 330 | VSM.unsafeWith (VSM.unsafeCast outBuf) $ \oPtr -> 331 | func iPtr oPtr 332 | 333 | type ResampleR = CInt -> CInt -> CInt -> CInt -> Ptr CInt -> Ptr (Ptr CFloat) -> Ptr CFloat -> Ptr CFloat -> IO CInt 334 | 335 | mkResampler :: ResampleR -> Int -> Int -> Int -> [Float] -> IO (Int -> Int -> VS.Vector Float -> VS.MVector RealWorld Float -> IO Int) 336 | mkResampler func n interpolation decimation coeffs = do 337 | groupsP <- mapM newArray $ map (map realToFrac) groups 338 | groupsPP <- newArray groupsP 339 | incrementsP <- newArray $ map fromIntegral increments 340 | return $ \offset num -> resampleFFIR $ func (fromIntegral num) (fromIntegral numCoeffs) (fromIntegral offset) (fromIntegral numGroups) incrementsP groupsPP 341 | where 342 | Coeffs {..} = prepareCoeffs n interpolation decimation coeffs 343 | 344 | type ResampleRR = Int -> Int -> [Float] -> IO (Int -> Int -> VS.Vector Float -> VS.MVector RealWorld Float -> IO Int) 345 | 346 | foreign import ccall unsafe "resample2RR" 347 | resample2_c :: CInt -> CInt -> CInt -> CInt -> Ptr CInt -> Ptr (Ptr CFloat) -> Ptr CFloat -> Ptr CFloat -> IO CInt 348 | 349 | resampleCRR2 :: ResampleRR 350 | resampleCRR2 = mkResampler resample2_c 1 351 | 352 | foreign import ccall unsafe "resampleSSERR" 353 | resampleCSSERR_c :: CInt -> CInt -> CInt -> CInt -> Ptr CInt -> Ptr (Ptr CFloat) -> Ptr CFloat -> Ptr CFloat -> IO CInt 354 | 355 | resampleCSSERR :: ResampleRR 356 | resampleCSSERR = mkResampler resampleCSSERR_c 4 357 | 358 | foreign import ccall unsafe "resampleAVXRR" 359 | resampleAVXRR_c :: CInt -> CInt -> CInt -> CInt -> Ptr CInt -> Ptr (Ptr CFloat) -> Ptr CFloat -> Ptr CFloat -> IO CInt 360 | 361 | resampleCAVXRR :: ResampleRR 362 | resampleCAVXRR = mkResampler resampleAVXRR_c 8 363 | 364 | type ResampleRC = Int -> Int -> [Float] -> IO (Int -> Int -> VS.Vector (Complex Float) -> VS.MVector RealWorld (Complex Float) -> IO Int) 365 | 366 | mkResamplerC :: ResampleR -> Int -> Int -> Int -> [Float] -> IO (Int -> Int -> VS.Vector (Complex Float) -> VS.MVector RealWorld (Complex Float) -> IO Int) 367 | mkResamplerC func n interpolation decimation coeffs = do 368 | groupsP <- mapM newArray $ map (map realToFrac) groups 369 | groupsPP <- newArray groupsP 370 | incrementsP <- newArray $ map fromIntegral increments 371 | return $ \offset num -> resampleFFIC $ func (fromIntegral num) (fromIntegral numCoeffs) (fromIntegral offset) (fromIntegral numGroups) incrementsP groupsPP 372 | where 373 | Coeffs {..} = prepareCoeffs n interpolation decimation coeffs 374 | 375 | foreign import ccall unsafe "resample2RC" 376 | resample2RC_c :: CInt -> CInt -> CInt -> CInt -> Ptr CInt -> Ptr (Ptr CFloat) -> Ptr CFloat -> Ptr CFloat -> IO CInt 377 | 378 | resampleCRC :: ResampleRC 379 | resampleCRC = mkResamplerC resample2RC_c 1 380 | 381 | foreign import ccall unsafe "resampleSSERC" 382 | resampleCSSERC_c :: CInt -> CInt -> CInt -> CInt -> Ptr CInt -> Ptr (Ptr CFloat) -> Ptr CFloat -> Ptr CFloat -> IO CInt 383 | 384 | resampleCSSERC :: ResampleRC 385 | resampleCSSERC = mkResamplerC resampleCSSERC_c 4 386 | 387 | foreign import ccall unsafe "resampleAVXRC" 388 | resampleAVXRC_c :: CInt -> CInt -> CInt -> CInt -> Ptr CInt -> Ptr (Ptr CFloat) -> Ptr CFloat -> Ptr CFloat -> IO CInt 389 | 390 | resampleCAVXRC :: ResampleRC 391 | resampleCAVXRC = mkResamplerC resampleAVXRC_c 8 392 | 393 | {- 394 | - Cross buffer 395 | -} 396 | 397 | {-# INLINE decimateCrossHighLevel #-} 398 | decimateCrossHighLevel :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) => Int -> v b -> Int -> v a -> v a -> vm (PrimState m) a -> m () 399 | decimateCrossHighLevel factor coeffs num lastBuf nextBuf outBuf = fill x outBuf 400 | where 401 | x = VFB.map dotProd (VFB.iterateN num (+ factor) 0) 402 | dotProd i = VG.sum $ VG.zipWith mult (VG.unsafeDrop i lastBuf VG.++ nextBuf) coeffs 403 | 404 | {-# INLINE filterCrossHighLevel #-} 405 | filterCrossHighLevel :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) => v b -> Int -> v a -> v a -> vm (PrimState m) a -> m () 406 | filterCrossHighLevel coeffs num lastBuf nextBuf outBuf = fill (VFB.generate num dotProd) outBuf 407 | where 408 | dotProd i = VG.sum $ VG.zipWith mult (VG.unsafeDrop i lastBuf VG.++ nextBuf) coeffs 409 | 410 | {-# INLINE resampleCrossHighLevel #-} 411 | resampleCrossHighLevel :: (PrimMonad m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a) => Int -> Int -> v b -> Int -> Int -> v a -> v a -> vm (PrimState m) a -> m Int 412 | resampleCrossHighLevel interpolation decimation coeffs filterOffset count lastBuf nextBuf outBuf = fill 0 filterOffset 0 413 | where 414 | fill i filterOffset inputOffset 415 | | i < count = do 416 | let dp = dotProd filterOffset inputOffset 417 | VGM.unsafeWrite outBuf i dp 418 | let (q, r) = divMod (decimation - filterOffset - 1) interpolation 419 | inputOffset' = inputOffset + q + 1 420 | filterOffset' = interpolation - 1 - r 421 | filterOffset' `seq` inputOffset' `seq` fill (i + 1) filterOffset' inputOffset' 422 | | otherwise = return filterOffset 423 | dotProd filterOffset i = VG.sum $ VG.zipWith mult (VG.unsafeDrop i lastBuf VG.++ nextBuf) (stride interpolation (VG.unsafeDrop filterOffset coeffs)) 424 | 425 | foreign import ccall unsafe "dcBlocker" 426 | c_dcBlocker :: CInt -> CFloat -> CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 427 | 428 | dcBlocker :: Int -> Float -> Float -> VS.Vector Float -> VS.MVector RealWorld Float -> IO (Float, Float) 429 | dcBlocker num lastSample lastOutput inBuf outBuf = 430 | alloca $ \fsp -> 431 | alloca $ \fop -> 432 | VS.unsafeWith (VS.unsafeCoerceVector inBuf) $ \iPtr -> 433 | VSM.unsafeWith (VSM.unsafeCoerceMVector outBuf) $ \oPtr -> do 434 | c_dcBlocker (fromIntegral num) (realToFrac lastSample) (realToFrac lastOutput) fsp fop iPtr oPtr 435 | r1 <- peek fsp 436 | r2 <- peek fop 437 | return (realToFrac r1, realToFrac r2) 438 | -------------------------------------------------------------------------------- /hs_sources/SDR/NetworkStream.hs: -------------------------------------------------------------------------------- 1 | module SDR.NetworkStream ( 2 | udpSendSocket, 3 | udpRecvSocket, 4 | udpSource, 5 | udpSink 6 | ) where 7 | 8 | import Control.Monad 9 | import Network.Socket (Socket, SockAddr) 10 | import qualified Network.Socket as Socket 11 | import Network.Socket.ByteString (sendAllTo, recv) 12 | import Foreign.Storable 13 | import qualified Data.Vector.Storable as VS 14 | import Data.Vector.Storable.ByteString 15 | import Pipes 16 | 17 | udpSendSocket :: IO Socket 18 | udpSendSocket = Socket.socket Socket.AF_INET Socket.Datagram Socket.defaultProtocol 19 | 20 | udpRecvSocket 21 | :: SockAddr 22 | -> IO Socket 23 | udpRecvSocket addr = do 24 | socket <- udpSendSocket 25 | Socket.bind socket addr 26 | return socket 27 | 28 | udpSource 29 | :: Storable a 30 | => Socket 31 | -> Int 32 | -> Producer (VS.Vector a) IO () 33 | udpSource sock size = forever $ do 34 | s <- lift $ recv sock size 35 | yield $ byteStringToVector s 36 | 37 | udpSink 38 | :: Storable a 39 | => Socket 40 | -> SockAddr 41 | -> Consumer (VS.Vector a) IO () 42 | udpSink dev addr = for cat $ liftIO . flip (sendAllTo dev) addr . vectorToByteString 43 | -------------------------------------------------------------------------------- /hs_sources/SDR/PipeUtils.hs: -------------------------------------------------------------------------------- 1 | {-| Pipes utility functions -} 2 | module SDR.PipeUtils ( 3 | fork, 4 | combine, 5 | printStream, 6 | devnull, 7 | rate, 8 | pMapAccum 9 | ) where 10 | 11 | import Data.Time.Clock 12 | import Pipes 13 | import Control.Monad 14 | 15 | -- | Fork a pipe 16 | fork :: Monad m => Producer a m r -> Producer a (Producer a m) r 17 | fork prod = runEffect $ hoist (lift . lift) prod >-> fork' 18 | where 19 | fork' = forever $ do 20 | res <- await 21 | lift $ yield res 22 | lift $ lift $ yield res 23 | 24 | -- | Combine two consumers into a single consumer 25 | combine :: Monad m => Consumer a m r -> Consumer a m r -> Consumer a m r 26 | combine x y = runEffect $ runEffect (fork func >-> hoist (lift . lift) x) >-> hoist lift y 27 | where 28 | func :: Monad m => Producer a (Consumer a m) r 29 | func = forever $ lift await >>= yield 30 | 31 | -- | A consumer that prints everything to stdout 32 | printStream :: (Show a) => Int -> Consumer a IO () 33 | printStream samples = for cat $ lift . print 34 | 35 | -- | A consumer that discards everything 36 | devnull :: Monad m => Consumer a m () 37 | devnull = forever await 38 | 39 | -- | Passthrough pipe that prints the sample rate 40 | rate :: Int -> Pipe a a IO b 41 | rate samples = do 42 | start <- lift getCurrentTime 43 | let rate' buffers = do 44 | res <- await 45 | 46 | time <- lift getCurrentTime 47 | let diff = diffUTCTime time start 48 | diffSecs :: Double 49 | diffSecs = fromRational $ toRational diff 50 | 51 | lift $ print $ buffers * fromIntegral samples / diffSecs 52 | 53 | yield res 54 | rate' (buffers + 1) 55 | rate' 1 56 | 57 | -- | mapAccum for Pipes 58 | pMapAccum :: (Monad m) 59 | => (acc -> x -> (acc, y)) -- ^ Accumulating function 60 | -> acc -- ^ Initial value of the accumulator 61 | -> Pipe x y m () 62 | pMapAccum func acc = go acc 63 | where 64 | go acc = do 65 | dat <- await 66 | let (acc', res) = func acc dat 67 | yield res 68 | go acc' 69 | 70 | -------------------------------------------------------------------------------- /hs_sources/SDR/Plot.hs: -------------------------------------------------------------------------------- 1 | {-| Create graphical plots of signals and their spectrums. Uses OpenGL. -} 2 | module SDR.Plot ( 3 | 4 | -- * Line Graphs 5 | plotLine, 6 | plotLineAxes, 7 | 8 | -- * Waterfalls 9 | plotWaterfall, 10 | --plotWaterfallAxes, 11 | 12 | -- * Filled In Line Graphs 13 | plotFill, 14 | plotFillAxes, 15 | 16 | -- * Axes 17 | zeroAxes, 18 | centeredAxes 19 | ) where 20 | 21 | import Control.Monad.Trans.Except 22 | import qualified Data.Vector.Storable as VS 23 | import Graphics.Rendering.OpenGL 24 | import Graphics.Rendering.Cairo 25 | 26 | import Pipes 27 | import Data.Colour.Names 28 | import Graphics.Rendering.Pango 29 | 30 | import Graphics.DynamicGraph.Line 31 | import Graphics.DynamicGraph.Waterfall 32 | import Graphics.DynamicGraph.FillLine 33 | import Graphics.DynamicGraph.Axis 34 | import Graphics.DynamicGraph.RenderCairo 35 | import Graphics.DynamicGraph.Window 36 | 37 | -- | Create a window and plot a dynamic line graph of the incoming data. 38 | plotLine :: Int -- ^ Window width 39 | -> Int -- ^ Window height 40 | -> Int -- ^ Number of samples in each buffer 41 | -> Int -- ^ Number of vertices in graph 42 | -> ExceptT String IO (Consumer (VS.Vector GLfloat) IO ()) 43 | plotLine width height samples resolution = window width height $ fmap pipeify $ renderLine samples resolution 44 | 45 | -- | Create a window and plot a dynamic line graph of the incoming data. With Axes. 46 | plotLineAxes :: Int -- ^ Window width 47 | -> Int -- ^ Window height 48 | -> Int -- ^ Number of samples in each buffer 49 | -> Int -- ^ Number of vertices in graph 50 | -> Render () -- ^ Cairo Render object that draws the axes 51 | -> ExceptT String IO (Consumer (VS.Vector GLfloat) IO ()) 52 | plotLineAxes width height samples xResolution rm = window width height $ do 53 | --render the graph 54 | renderFunc <- renderLine samples xResolution 55 | 56 | --render the axes 57 | renderAxisFunc <- renderCairo rm width height 58 | 59 | return $ for cat $ \dat -> lift $ do 60 | blend $= Disabled 61 | 62 | viewport $= (Position 50 50, Size (fromIntegral width - 100) (fromIntegral height - 100)) 63 | renderFunc dat 64 | 65 | blend $= Enabled 66 | blendFunc $= (SrcAlpha, OneMinusSrcAlpha) 67 | 68 | viewport $= (Position 0 0, Size (fromIntegral width) (fromIntegral height)) 69 | renderAxisFunc 70 | 71 | -- | Create a window and plot a waterfall of the incoming data. 72 | plotWaterfall :: Int -- ^ Window width 73 | -> Int -- ^ Window height 74 | -> Int -- ^ Number of columns 75 | -> Int -- ^ Number of rows 76 | -> [GLfloat] -- ^ The color map 77 | -> ExceptT String IO (Consumer (VS.Vector GLfloat) IO ()) 78 | plotWaterfall windowWidth windowHeight width height colorMap = window windowWidth windowHeight $ renderWaterfall width height colorMap 79 | 80 | {- 81 | -- | Create a window and plot a waterfall of the incoming data. With Axes. TODO: doesnt work. 82 | plotWaterfallAxes :: Int -- ^ Window width 83 | -> Int -- ^ Window height 84 | -> Int -- ^ Number of columns 85 | -> Int -- ^ Number of rows 86 | -> [GLfloat] -- ^ The color map 87 | -> Render () -- ^ Cairo Render object that draws the axes 88 | -> EitherT String IO (Consumer (VS.Vector GLfloat) IO ()) 89 | plotWaterfallAxes windowWidth windowHeight width height colorMap rm = window windowWidth windowHeight $ do 90 | renderPipe <- renderWaterfall width height colorMap 91 | 92 | renderAxisFunc <- renderCairo rm width height 93 | 94 | return $ (>-> renderPipe) $ for cat $ \dat -> do 95 | lift $ viewport $= (Position 0 0, Size (fromIntegral width) (fromIntegral height)) 96 | lift renderAxisFunc 97 | 98 | lift $ viewport $= (Position 50 50, Size (fromIntegral width - 100) (fromIntegral height - 100)) 99 | 100 | yield dat 101 | -} 102 | 103 | -- | Create a window and plot a dynamic filled in line graph of the incoming data. 104 | plotFill :: Int -- ^ Window width 105 | -> Int -- ^ Window height 106 | -> Int -- ^ Number of samples in each buffer 107 | -> [GLfloat] -- ^ The color map 108 | -> ExceptT String IO (Consumer (VS.Vector GLfloat) IO ()) 109 | plotFill width height samples colorMap = window width height $ fmap pipeify $ renderFilledLine samples colorMap 110 | 111 | -- | Create a window and plot a dynamic filled in line graph of the incoming data. With Axes. 112 | plotFillAxes :: Int -- ^ Window width 113 | -> Int -- ^ Window height 114 | -> Int -- ^ Number of samples in each buffer 115 | -> [GLfloat] -- ^ The color map 116 | -> Render () -- ^ Cairo Render object that draws the axes 117 | -> ExceptT String IO (Consumer (VS.Vector GLfloat) IO ()) 118 | plotFillAxes width height samples colorMap rm = window width height $ do 119 | renderFunc <- renderFilledLine samples colorMap 120 | 121 | renderAxisFunc <- renderCairo rm width height 122 | 123 | return $ for cat $ \dat -> lift $ do 124 | viewport $= (Position 50 50, Size (fromIntegral width - 100) (fromIntegral height - 100)) 125 | renderFunc dat 126 | 127 | blend $= Enabled 128 | blendFunc $= (SrcAlpha, OneMinusSrcAlpha) 129 | 130 | viewport $= (Position 0 0, Size (fromIntegral width) (fromIntegral height)) 131 | renderAxisFunc 132 | 133 | -- | Create a Cairo `Render` monad that draws a set of axes with 0 at the bottom left. 134 | zeroAxes :: Int -- ^ Image width 135 | -> Int -- ^ Image height 136 | -> Double -- ^ X axis span 137 | -> Double -- ^ X axis grid interval 138 | -> Render () 139 | zeroAxes width height bandwidth interval = do 140 | blankCanvasAlpha black 0 (fromIntegral width) (fromIntegral height) 141 | let xSeparation = (interval / bandwidth) * (fromIntegral width - 100) 142 | ySeparation = 0.2 * (fromIntegral height - 100) 143 | xCoords = takeWhile (< (fromIntegral width - 50)) $ iterate (+ xSeparation) 50 144 | yCoords = takeWhile (> 50) $ iterate (\x -> x - ySeparation) (fromIntegral height - 50) 145 | ctx <- liftIO $ cairoCreateContext Nothing 146 | xAxisLabels ctx white (map (\n -> show n ++ " KHz" ) (takeWhile (< bandwidth) $ iterate (+ interval) 0)) xCoords (fromIntegral height - 50) 147 | drawAxes (fromIntegral width) (fromIntegral height) 50 50 50 50 white 2 148 | xAxisGrid gray 1 [] 50 (fromIntegral height - 50) xCoords 149 | yAxisGrid gray 1 [4, 2] 50 (fromIntegral width - 50) yCoords 150 | 151 | -- | Create a Cairo `Render` monad that draws a set of axes with the X axis centered on a specified value. 152 | centeredAxes :: Int -- ^ Image width 153 | -> Int -- ^ Image height 154 | -> Double -- ^ Center X value 155 | -> Double -- ^ X axis span 156 | -> Double -- ^ X axis grid interval 157 | -> Render () 158 | centeredAxes width height cFreq bandwidth interval = do 159 | blankCanvasAlpha black 0 (fromIntegral width) (fromIntegral height) 160 | let xSeparation = (interval / bandwidth) * (fromIntegral width - 100) 161 | firstXLabel = fromIntegral (ceiling ((cFreq - (bandwidth / 2)) / interval)) * interval 162 | fract x = x - fromIntegral (floor x) 163 | xOffset = fract ((cFreq - (bandwidth / 2)) / interval) * xSeparation 164 | ySeparation = 0.2 * (fromIntegral height - 100) 165 | xCoords = takeWhile (< (fromIntegral width - 50)) $ iterate (+ xSeparation) (50 + xOffset) 166 | yCoords = takeWhile (> 50) $ iterate (\x -> x - ySeparation) (fromIntegral height - 50) 167 | ctx <- liftIO $ cairoCreateContext Nothing 168 | xAxisLabels ctx white (map (\n -> show n ++ " MHZ") (takeWhile (< (cFreq + bandwidth / 2)) $ iterate (+ interval) firstXLabel)) xCoords (fromIntegral height - 50) 169 | drawAxes (fromIntegral width) (fromIntegral height) 50 50 50 50 white 2 170 | xAxisGrid gray 1 [] 50 (fromIntegral height - 50) xCoords 171 | yAxisGrid gray 1 [4, 2] 50 (fromIntegral width - 50) yCoords 172 | 173 | -------------------------------------------------------------------------------- /hs_sources/SDR/Pulse.hs: -------------------------------------------------------------------------------- 1 | {-| Pulse Audio Pipes sink -} 2 | module SDR.Pulse ( 3 | pulseAudioSink, 4 | doPulse 5 | ) where 6 | 7 | import Foreign.ForeignPtr 8 | import Foreign.C.Types 9 | import Control.Concurrent 10 | import Data.ByteString.Internal 11 | import Data.Vector.Storable as VS 12 | 13 | import Sound.Pulse.Simple 14 | import Pipes 15 | import Pipes.Concurrent 16 | 17 | -- | Returns a consumer that sends all incoming data to pulseaudio. Runs Pulse Audio output writing in a different thread. This is probably what you want as it does not block the entire pipline while the data is being played. 18 | pulseAudioSink :: IO (Consumer (VS.Vector Float) IO ()) 19 | pulseAudioSink = do 20 | (output, input) <- spawn $ bounded 1 21 | doIt <- doPulse 22 | forkOS $ runEffect $ fromInput input >-> doIt 23 | return $ toOutput output 24 | 25 | -- | Returns a consumer that sends all incoming data to pulseaudio. 26 | doPulse :: IO (Consumer (VS.Vector Float) IO ()) 27 | doPulse = do 28 | s <- simpleNew Nothing "Haskell SDR" Play Nothing "Software Defined Radio library" (SampleSpec (F32 LittleEndian) 48000 1) Nothing Nothing 29 | return $ for cat $ \buf -> 30 | lift $ do 31 | let (fp, offset, length) = VS.unsafeToForeignPtr buf 32 | simpleWriteRaw s (PS (castForeignPtr fp) (offset * 4) (length * 4)) 33 | 34 | -------------------------------------------------------------------------------- /hs_sources/SDR/RTLSDRStream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | {-| Stream samples from a Realtek RTL2832U based device -} 4 | module SDR.RTLSDRStream ( 5 | RTLSDRParams(..), 6 | defaultRTLSDRParams, 7 | setRTLSDRParams, 8 | sdrStream, 9 | sdrStreamFromDevice 10 | ) where 11 | 12 | import Control.Monad 13 | import Control.Monad.Trans.Except 14 | import Data.Word 15 | import Data.Int 16 | import Foreign.ForeignPtr 17 | import Foreign.C.Types 18 | import Control.Concurrent hiding (yield) 19 | import Foreign.Marshal.Utils 20 | import qualified Data.Vector.Storable as VS 21 | 22 | import Pipes 23 | import Pipes.Concurrent 24 | import RTLSDR 25 | 26 | -- | RTLSDR configuration parameters 27 | data RTLSDRParams = RTLSDRParams { 28 | centerFreq :: Word32, 29 | sampleRate :: Word32, 30 | freqCorrection :: Int32, 31 | tunerGain :: Maybe Int32 32 | } 33 | 34 | -- | Some reasonable default parameters 35 | defaultRTLSDRParams :: Word32 -- ^ Frequency 36 | -> Word32 -- ^ Sample rate 37 | -> RTLSDRParams 38 | defaultRTLSDRParams freq sampleRate = RTLSDRParams freq sampleRate 0 Nothing 39 | 40 | -- | Set the configuration parameters for a device 41 | setRTLSDRParams :: RTLSDR -- ^ Device handle 42 | -> RTLSDRParams -- ^ Parameters 43 | -> IO () 44 | setRTLSDRParams dev RTLSDRParams{..} = do 45 | setCenterFreq dev centerFreq 46 | setSampleRate dev sampleRate 47 | setFreqCorrection dev freqCorrection 48 | case tunerGain of 49 | Nothing -> setTunerGainMode dev False 50 | Just g -> setTunerGainMode dev True >> setTunerGain dev g 51 | return () 52 | 53 | -- | Returns a producer that streams data from a Realtek RTL2832U based device. You probably want to use `interleavedIQUnsigned256ToFloat` to turn it into a list of complex Floats. This function initializes and configures the device for you. Use `sdrStreamFromDevice` if you need more control over how the device is configured or want to configure it yourself. 54 | sdrStream :: RTLSDRParams -- ^ Configuration parameters 55 | -> Word32 -- ^ Number of buffers 56 | -> Word32 -- ^ Buffer length 57 | -> ExceptT String IO (Producer (VS.Vector CUChar) IO ()) -- ^ Either a string describing the error that occurred or the Producer 58 | sdrStream params bufNum bufLen = do 59 | lift $ putStrLn "Initializing RTLSDR device..." 60 | 61 | dev' <- lift $ open 0 62 | dev <- maybe (throwE "Failed to open device") return dev' 63 | 64 | lift $ do 65 | t <- getTunerType dev 66 | putStrLn $ "Found a: " ++ show t 67 | setRTLSDRParams dev params 68 | sdrStreamFromDevice dev bufNum bufLen 69 | 70 | -- | Returns a producer that streams data from a Realtek RTL2832U based device. You probably want to use `interleavedIQUnsigned256ToFloat` to turn it into a list of complex Floats. This function takes a pre-configured device handle to stream from. 71 | sdrStreamFromDevice :: RTLSDR -- ^ Device handle 72 | -> Word32 -- ^ Number of buffers 73 | -> Word32 -- ^ Buffer length 74 | -> IO (Producer (VS.Vector CUChar) IO ()) -- ^ The producer 75 | sdrStreamFromDevice dev bufNum bufLen = do 76 | resetBuffer dev 77 | 78 | (output, input) <- spawn unbounded 79 | 80 | forkOS $ void $ readAsync dev bufNum bufLen $ \dat num -> void $ do 81 | let numBytes = fromIntegral $ bufNum * bufLen 82 | fp <- mallocForeignPtrArray numBytes 83 | withForeignPtr fp $ \fpp -> moveBytes fpp dat numBytes 84 | let v = VS.unsafeFromForeignPtr0 fp numBytes 85 | atomically (send output v) 86 | 87 | return $ fromInput input 88 | 89 | -------------------------------------------------------------------------------- /hs_sources/SDR/Serialize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} 2 | 3 | {-| Utility functions for serializing and deserializing samples. -} 4 | module SDR.Serialize ( 5 | 6 | -- * Slow Serialization\/Deserialization 7 | -- | Slow functions for serializing\/deserializing vectors to\/from bytestrings using the Cereal library. There must be a better way to do this that doesn't involve copying. 8 | 9 | -- ** Floats 10 | floatVecToByteString, 11 | floatVecFromByteString, 12 | 13 | -- ** Doubles 14 | doubleVecToByteString, 15 | doubleVecFromByteString, 16 | 17 | -- * Fast Serialization\/Deserialization 18 | -- | Fast functions for serializing\/deserializing storable vectors to\/from bytestrings. 19 | toByteString, 20 | fromByteString, 21 | 22 | -- * Pipes 23 | -- | Pipes that perform fast serialization/deserialization to a Handle. 24 | toHandle, 25 | fromHandle 26 | ) where 27 | 28 | import Foreign.ForeignPtr 29 | import Foreign.Storable 30 | import Data.ByteString.Internal 31 | import Data.ByteString as BS 32 | import System.IO 33 | 34 | import qualified Data.Vector.Generic as VG hiding ((++)) 35 | import qualified Data.Vector.Storable as VS hiding ((++)) 36 | 37 | import Pipes 38 | import qualified Pipes.Prelude as P 39 | import qualified Pipes.ByteString as PB 40 | import Data.Serialize hiding (Done) 41 | import qualified Data.Serialize as S 42 | 43 | -- | Convert a Vector of Floats to a ByteString. 44 | floatVecToByteString :: VG.Vector v Float => v Float -> ByteString 45 | floatVecToByteString vect = runPut $ VG.mapM_ putFloat32le vect 46 | 47 | -- | Convert a Vector of Doubles to a ByteString. 48 | doubleVecToByteString :: VG.Vector v Double => v Double -> ByteString 49 | doubleVecToByteString vect = runPut $ VG.mapM_ putFloat64le vect 50 | 51 | -- | Convert a ByteString to a Vector of Floats. 52 | floatVecFromByteString :: VG.Vector v Float => ByteString -> v Float 53 | floatVecFromByteString bs = VG.unfoldrN (BS.length bs `div` 4) go bs 54 | where 55 | go bs = case runGetPartial getFloat32le bs of 56 | Fail _ _ -> Nothing 57 | Partial _ -> error "floatVecFromByteString: Partial" 58 | S.Done r b -> Just (r, b) 59 | 60 | -- | Convert a ByteString to a Vector of Doubles. 61 | doubleVecFromByteString :: VG.Vector v Double => ByteString -> v Double 62 | doubleVecFromByteString bs = VG.unfoldrN (BS.length bs `div` 8) go bs 63 | where 64 | go bs = case runGetPartial getFloat64le bs of 65 | Fail _ _ -> Nothing 66 | Partial _ -> error "doubleVecFromByteString" 67 | S.Done r b -> Just (r, b) 68 | 69 | -- | Convert a Vector of Storable values to a ByteString. This is fast as it is just a cast. 70 | toByteString :: forall a. Storable a => VS.Vector a -> ByteString 71 | toByteString dat = let (fp, o, sz) = VS.unsafeToForeignPtr dat in PS (castForeignPtr fp) o (sz * sizeOf (undefined :: a)) 72 | 73 | -- | Convert a ByteString to a Vector of Storable values. This is fast as it is just a cast. 74 | fromByteString :: forall a. Storable a => ByteString -> VS.Vector a 75 | fromByteString (PS fp o l) = VS.unsafeFromForeignPtr (castForeignPtr fp) o (l `quot` sizeOf (undefined :: a)) 76 | 77 | -- | Given a Handle, create a Consumer that dumps the Vectors written to it to a Handle. 78 | toHandle :: (Storable a) => Handle -> Consumer (VS.Vector a) IO () 79 | toHandle handle = P.map toByteString >-> PB.toHandle handle 80 | 81 | -- | Given a Handle, create a Producer that creates Vectors from data read from the Handle. 82 | fromHandle :: forall a. (Storable a) => Int -> Handle -> Producer (VS.Vector a) IO () 83 | fromHandle samples handle = PB.hGet (samples * sizeOf (undefined :: a)) handle >-> P.map fromByteString 84 | 85 | -------------------------------------------------------------------------------- /hs_sources/SDR/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-} 2 | 3 | {-| Various utiliy signal processing functions -} 4 | module SDR.Util ( 5 | -- * Classes 6 | Mult, 7 | mult, 8 | 9 | -- * Conversion to floating point for reception 10 | -- ** RTLSDR 11 | interleavedIQUnsigned256ToFloat, 12 | interleavedIQUnsignedByteToFloat, 13 | interleavedIQUnsignedByteToFloatSSE, 14 | interleavedIQUnsignedByteToFloatAVX, 15 | interleavedIQUnsignedByteToFloatFast, 16 | 17 | -- ** BladeRF 18 | interleavedIQSigned2048ToFloat, 19 | interleavedIQSignedWordToFloat, 20 | interleavedIQSignedWordToFloatSSE, 21 | interleavedIQSignedWordToFloatAVX, 22 | interleavedIQSignedWordToFloatFast, 23 | 24 | -- * Conversion from floating point for transmission 25 | -- ** BladeRF 26 | complexFloatToInterleavedIQSigned2048, 27 | complexFloatToInterleavedIQSignedWord, 28 | 29 | -- * Scaling 30 | scaleC, 31 | scaleCSSE, 32 | scaleCAVX, 33 | scaleFast, 34 | 35 | -- * Mapping over complex numbers 36 | cplxMap, 37 | 38 | -- * Frequency shifting 39 | halfBandUp, 40 | quarterBandUp, 41 | 42 | -- * Data streams 43 | streamString, 44 | streamRandom, 45 | 46 | -- * Automatic gain control 47 | agc, 48 | agcPipe, 49 | 50 | -- * Squashing initialization into the Pipe 51 | combineInit, 52 | combineInitTrans 53 | ) where 54 | 55 | import Foreign.C.Types 56 | import Data.Complex 57 | import qualified Data.Vector.Generic as VG 58 | import qualified Data.Vector.Generic.Mutable as VGM 59 | import qualified Data.Vector.Storable as VS 60 | import qualified Data.Vector.Storable.Mutable as VSM 61 | import Control.Monad.Primitive 62 | import Data.Coerce 63 | import Foreign.Ptr 64 | import System.IO.Unsafe 65 | import Foreign.Storable.Complex 66 | import Control.Monad 67 | import qualified System.Random.MWC as R 68 | import Data.Bits 69 | import Pipes 70 | import qualified Pipes.Prelude as P 71 | import Data.Word 72 | import Foreign.Storable 73 | import Control.Arrow as A 74 | import Data.Tuple 75 | 76 | import SDR.CPUID 77 | import SDR.VectorUtils 78 | import SDR.PipeUtils 79 | 80 | -- | A class for things that can be multiplied by a scalar. 81 | class Mult a b where 82 | mult :: a -> b -> a 83 | 84 | instance (Num a) => Mult a a where 85 | mult = (*) 86 | 87 | instance (Num a) => Mult (Complex a) a where 88 | mult (x :+ y) z = (x * z) :+ (y * z) 89 | 90 | -- | Create a vector of complex floating samples from a vector of interleaved I Q components. Each input element ranges from 0 to 255. This is the format that RTLSDR devices use. 91 | {-# INLINE interleavedIQUnsigned256ToFloat #-} 92 | interleavedIQUnsigned256ToFloat :: (Num a, Integral a, Num b, Fractional b, VG.Vector v1 a, VG.Vector v2 (Complex b)) => v1 a -> v2 (Complex b) 93 | interleavedIQUnsigned256ToFloat input = VG.generate (VG.length input `quot` 2) convert 94 | where 95 | {-# INLINE convert #-} 96 | convert idx = convert' (input `VG.unsafeIndex` (2 * idx)) :+ convert' (input `VG.unsafeIndex` (2 * idx + 1)) 97 | {-# INLINE convert' #-} 98 | convert' val = (fromIntegral val - 128) / 128 99 | 100 | foreign import ccall unsafe "convertC" 101 | convertC_c :: CInt -> Ptr CUChar -> Ptr CFloat -> IO () 102 | 103 | -- | Same as `interleavedIQUnsigned256ToFloat` but written in C and specialized for unsigned byte inputs and Float outputs. 104 | interleavedIQUnsignedByteToFloat :: VS.Vector CUChar -> VS.Vector (Complex Float) 105 | interleavedIQUnsignedByteToFloat inBuf = unsafePerformIO $ do 106 | outBuf <- VGM.new $ VG.length inBuf `quot` 2 107 | VS.unsafeWith inBuf $ \iPtr -> 108 | VSM.unsafeWith (VSM.unsafeCast outBuf) $ \oPtr -> 109 | convertC_c (fromIntegral $ VG.length inBuf) iPtr oPtr 110 | VG.freeze outBuf 111 | 112 | foreign import ccall unsafe "convertCSSE" 113 | convertCSSE_c :: CInt -> Ptr CUChar -> Ptr CFloat -> IO () 114 | 115 | -- | Same as `interleavedIQUnsigned256ToFloat` but written in C using SSE intrinsics and specialized for unsigned byte inputs and Float outputs. 116 | interleavedIQUnsignedByteToFloatSSE :: VS.Vector CUChar -> VS.Vector (Complex Float) 117 | interleavedIQUnsignedByteToFloatSSE inBuf = unsafePerformIO $ do 118 | outBuf <- VGM.new $ VG.length inBuf `quot` 2 119 | VS.unsafeWith inBuf $ \iPtr -> 120 | VSM.unsafeWith (VSM.unsafeCast outBuf) $ \oPtr -> 121 | convertCSSE_c (fromIntegral $ VG.length inBuf) iPtr oPtr 122 | VG.freeze outBuf 123 | 124 | foreign import ccall unsafe "convertCAVX" 125 | convertCAVX_c :: CInt -> Ptr CUChar -> Ptr CFloat -> IO () 126 | 127 | -- | Same as `interleavedIQUnsigned256ToFloat` but written in C using AVX intrinsics and specialized for unsigned byte inputs and Float outputs. 128 | interleavedIQUnsignedByteToFloatAVX :: VS.Vector CUChar -> VS.Vector (Complex Float) 129 | interleavedIQUnsignedByteToFloatAVX inBuf = unsafePerformIO $ do 130 | outBuf <- VGM.new $ VG.length inBuf `quot` 2 131 | VS.unsafeWith inBuf $ \iPtr -> 132 | VSM.unsafeWith (VSM.unsafeCast outBuf) $ \oPtr -> 133 | convertCAVX_c (fromIntegral $ VG.length inBuf) iPtr oPtr 134 | VG.freeze outBuf 135 | 136 | -- | Same as `interleavedIQUnsigned256ToFloat` but uses the fastest SIMD instruction set your processor supports and specialized for unsigned byte inputs and Float outputs. 137 | interleavedIQUnsignedByteToFloatFast :: CPUInfo -> VS.Vector CUChar -> VS.Vector (Complex Float) 138 | interleavedIQUnsignedByteToFloatFast info = featureSelect info interleavedIQUnsignedByteToFloat [(hasAVX2, interleavedIQUnsignedByteToFloatAVX), (hasSSE42, interleavedIQUnsignedByteToFloatSSE)] 139 | 140 | -- | Create a vector of complex float samples from a vector of interleaved I Q components. Each input element ranges from -2048 to 2047. This is the format that the BladeRF uses. 141 | {-# INLINE interleavedIQSigned2048ToFloat #-} 142 | interleavedIQSigned2048ToFloat :: (Num a, Integral a, Num b, Fractional b, VG.Vector v1 a, VG.Vector v2 (Complex b)) => v1 a -> v2 (Complex b) 143 | interleavedIQSigned2048ToFloat input = VG.generate (VG.length input `quot` 2) convert 144 | where 145 | {-# INLINE convert #-} 146 | convert idx = convert' (input `VG.unsafeIndex` (2 * idx)) :+ convert' (input `VG.unsafeIndex` (2 * idx + 1)) 147 | {-# INLINE convert' #-} 148 | convert' val = fromIntegral val / 2048 149 | 150 | foreign import ccall unsafe "convertCBladeRF" 151 | convertCBladeRF_c :: CInt -> Ptr CShort -> Ptr CFloat -> IO () 152 | 153 | -- | Same as `interleavedIQUnsigned256ToFloat` but written in C and specialized for signed short inputs and Float outputs. 154 | interleavedIQSignedWordToFloat :: VS.Vector CShort -> VS.Vector (Complex Float) 155 | interleavedIQSignedWordToFloat inBuf = unsafePerformIO $ do 156 | outBuf <- VGM.new $ VG.length inBuf `quot` 2 157 | VS.unsafeWith inBuf $ \iPtr -> 158 | VSM.unsafeWith (VSM.unsafeCast outBuf) $ \oPtr -> 159 | convertCBladeRF_c (fromIntegral $ VG.length inBuf) iPtr oPtr 160 | VG.freeze outBuf 161 | 162 | foreign import ccall unsafe "convertCSSEBladeRF" 163 | convertCSSEBladeRF_c :: CInt -> Ptr CShort -> Ptr CFloat -> IO () 164 | 165 | -- | Same as `interleavedIQUnsigned256ToFloat` but written in C using SSE intrinsics and specialized for signed short inputs and Float outputs. 166 | interleavedIQSignedWordToFloatSSE :: VS.Vector CShort -> VS.Vector (Complex Float) 167 | interleavedIQSignedWordToFloatSSE inBuf = unsafePerformIO $ do 168 | outBuf <- VGM.new $ VG.length inBuf `quot` 2 169 | VS.unsafeWith inBuf $ \iPtr -> 170 | VSM.unsafeWith (VSM.unsafeCast outBuf) $ \oPtr -> 171 | convertCSSEBladeRF_c (fromIntegral $ VG.length inBuf) iPtr oPtr 172 | VG.freeze outBuf 173 | 174 | foreign import ccall unsafe "convertCAVXBladeRF" 175 | convertCAVXBladeRF_c :: CInt -> Ptr CShort -> Ptr CFloat -> IO () 176 | 177 | -- | Same as `interleavedIQUnsigned256ToFloat` but written in C using AVX intrinsics and specialized for signed short inputs and Float outputs. 178 | interleavedIQSignedWordToFloatAVX :: VS.Vector CShort -> VS.Vector (Complex Float) 179 | interleavedIQSignedWordToFloatAVX inBuf = unsafePerformIO $ do 180 | outBuf <- VGM.new $ VG.length inBuf `quot` 2 181 | VS.unsafeWith inBuf $ \iPtr -> 182 | VSM.unsafeWith (VSM.unsafeCast outBuf) $ \oPtr -> 183 | convertCAVXBladeRF_c (fromIntegral $ VG.length inBuf) iPtr oPtr 184 | VG.freeze outBuf 185 | 186 | -- | Same as `interleavedIQSigned2048ToFloat` but uses the fastest SIMD instruction set your processor supports and specialized for signed short inputs and Float outputs. 187 | interleavedIQSignedWordToFloatFast :: CPUInfo -> VS.Vector CShort -> VS.Vector (Complex Float) 188 | interleavedIQSignedWordToFloatFast info = featureSelect info interleavedIQSignedWordToFloat [(hasAVX2, interleavedIQSignedWordToFloatAVX), (hasSSE42, interleavedIQSignedWordToFloatSSE)] 189 | 190 | -- | Create a vector of interleaved I Q component integral samples from a vector of complex Floats. Each input ranges from -2048 to 2047. This is the format the BladeRF uses. 191 | complexFloatToInterleavedIQSigned2048 :: (Integral b, RealFrac a, VG.Vector v1 (Complex a), VG.Vector v2 b) => v1 (Complex a) -> v2 b 192 | complexFloatToInterleavedIQSigned2048 input = VG.generate (VG.length input * 2) convert 193 | where 194 | {-# INLINE convert #-} 195 | convert idx 196 | | even idx = convert' $ realPart (input `VG.unsafeIndex` (idx `quot` 2)) 197 | | odd idx = convert' $ imagPart (input `VG.unsafeIndex` (idx `quot` 2)) 198 | {-# INLINE convert' #-} 199 | convert' val = round $ val * 2048 200 | 201 | foreign import ccall unsafe "convertBladeRFTransmit" 202 | convertBladeRFTransmit_c :: CInt -> Ptr CFloat -> Ptr CShort -> IO () 203 | 204 | -- | Same as `complexFloatToInterleavedIQSigned2048` but written in C and specialized for Float inputs and signed short outputs. 205 | complexFloatToInterleavedIQSignedWord :: VS.Vector (Complex Float) -> VS.Vector CShort 206 | complexFloatToInterleavedIQSignedWord inBuf = unsafePerformIO $ do 207 | outBuf <- VGM.new $ VG.length inBuf * 2 208 | VS.unsafeWith (VS.unsafeCast inBuf) $ \iPtr -> 209 | VSM.unsafeWith outBuf $ \oPtr -> 210 | convertBladeRFTransmit_c (fromIntegral $ VG.length inBuf * 2) iPtr oPtr 211 | VG.freeze outBuf 212 | 213 | -- | Scaling 214 | foreign import ccall unsafe "scale" 215 | scale_c :: CInt -> CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 216 | 217 | -- | Scale a vector, written in C 218 | scaleC :: Float -- ^ Scale factor 219 | -> VS.Vector Float -- ^ Input vector 220 | -> VS.MVector RealWorld Float -- ^ Output vector 221 | -> IO () 222 | scaleC factor inBuf outBuf = 223 | VS.unsafeWith (VS.unsafeCoerceVector inBuf) $ \iPtr -> 224 | VSM.unsafeWith (VSM.unsafeCoerceMVector outBuf) $ \oPtr -> 225 | scale_c (fromIntegral (VG.length inBuf)) (coerce factor) iPtr oPtr 226 | 227 | foreign import ccall unsafe "scaleSSE" 228 | scaleSSE_c :: CInt -> CFloat -> Ptr CFloat -> Ptr CFloat-> IO () 229 | 230 | -- | Scale a vector, written in C using SSE intrinsics 231 | scaleCSSE :: Float -- ^ Scale factor 232 | -> VS.Vector Float -- ^ Input vector 233 | -> VS.MVector RealWorld Float -- ^ Output vector 234 | -> IO () 235 | scaleCSSE factor inBuf outBuf = 236 | VS.unsafeWith (VS.unsafeCoerceVector inBuf) $ \iPtr -> 237 | VSM.unsafeWith (VSM.unsafeCoerceMVector outBuf) $ \oPtr -> 238 | scaleSSE_c (fromIntegral (VG.length inBuf)) (coerce factor) iPtr oPtr 239 | 240 | foreign import ccall unsafe "scaleAVX" 241 | scaleAVX_c :: CInt -> CFloat -> Ptr CFloat -> Ptr CFloat -> IO () 242 | 243 | -- | Scale a vector, written in C using AVX intrinsics 244 | scaleCAVX :: Float -- ^ Scale factor 245 | -> VS.Vector Float -- ^ Input vector 246 | -> VS.MVector RealWorld Float -- ^ Output vector 247 | -> IO () 248 | scaleCAVX factor inBuf outBuf = 249 | VS.unsafeWith (VS.unsafeCoerceVector inBuf) $ \iPtr -> 250 | VSM.unsafeWith (VSM.unsafeCoerceMVector outBuf) $ \oPtr -> 251 | scaleAVX_c (fromIntegral (VG.length inBuf)) (coerce factor) iPtr oPtr 252 | 253 | -- | Scale a vector. Uses the fastest SIMD instruction set your processor supports. 254 | scaleFast :: CPUInfo -> Float -> VS.Vector Float -> VS.MVector RealWorld Float -> IO () 255 | scaleFast info = featureSelect info scaleC [(hasAVX, scaleCAVX), (hasSSE42, scaleCSSE)] 256 | 257 | -- | Apply a function to both parts of a complex number 258 | cplxMap :: (a -> b) -- ^ The function 259 | -> Complex a -- ^ Input complex number 260 | -> Complex b -- ^ Output complex number 261 | cplxMap f (x :+ y) = f x :+ f y 262 | 263 | -- | Multiplication by this vector shifts all frequencies up by 1/2 of the sampling frequency 264 | halfBandUp :: (VG.Vector v n, Num n) 265 | => Int -- ^ The length of the Vector 266 | -> v n 267 | halfBandUp size = VG.generate size func 268 | where 269 | func idx 270 | | even idx = 1 271 | | otherwise = -1 272 | 273 | -- | Multiplication by this vector shifts all frequencies up by 1/4 of the sampling frequency 274 | quarterBandUp :: (VG.Vector v (Complex n), Num n) 275 | => Int -- ^ The length of the Vector 276 | -> v (Complex n) 277 | quarterBandUp size = VG.generate size func 278 | where 279 | func idx 280 | | m == 0 = 1 :+ 0 281 | | m == 1 = 0 :+ 1 282 | | m == 2 = (-1) :+ 0 283 | | m == 3 = 0 :+ (-1) 284 | where 285 | m = idx `mod` 4 286 | 287 | -- | A Producer that streams vectors of the bits that make up the string argument concatenated repeatedly. Each bit is encoded as a float with value (+1) for 1 and (-1) for 0. 288 | streamString :: forall m b. (FiniteBits b, Monad m) 289 | => [b] -- ^ The string whose bits are to be streamed 290 | -> Int -- ^ The size of each streamed vector 291 | -> Producer (VS.Vector Float) m () 292 | streamString str size = P.unfoldr (return . Right . func) (str, 0) 293 | where 294 | bitsPerChar = finiteBitSize (undefined :: b) 295 | toFloat :: Bool -> Float 296 | toFloat x = if x then 1 else (-1) 297 | func = vUnfoldr size funcy 298 | where 299 | funcy ([], offsetChar) = funcy (str, 0) 300 | funcy (rem@(x:xs), offsetChar) 301 | | offsetChar == bitsPerChar = funcy (xs, 0) 302 | | otherwise = (toFloat $ testBit x offsetChar, (rem, offsetChar + 1)) 303 | 304 | -- | A Producer that streams vectors of random bits. Each bit is encoded as a float with value (+1) for 1 and (-1) for 0. 305 | streamRandom :: forall m. PrimMonad m 306 | => Int -- ^ The size of each streamed vector 307 | -> Producer (VS.Vector Float) m () 308 | streamRandom size = do 309 | gen <- lift R.create 310 | start <- lift $ R.uniform gen 311 | P.unfoldr (liftM Right . func gen) (start, 0) 312 | where 313 | toFloat :: Bool -> Float 314 | toFloat x = if x then 1 else (-1) 315 | func :: R.Gen (PrimState m) -> (Word64, Int) -> m (VS.Vector Float, (Word64, Int)) 316 | func gen = vUnfoldrM size funcy 317 | where 318 | funcy (current, offset) = do 319 | let res = toFloat $ testBit current offset 320 | if offset == 63 then do 321 | current' <- R.uniform gen 322 | return (res, (current', 0)) 323 | else return (res, (current, offset+1)) 324 | 325 | (a :+ b) `cdiv` y = (a/y) :+ (b/y) 326 | (a :+ b) `cmul` y = (a*y) :+ (b*y) 327 | 328 | -- | Simple automatic gain control 329 | agc :: (Num a, Storable a, RealFloat a) 330 | => a -- ^ a 331 | -> a -- ^ reference 332 | -> a -- ^ initial state 333 | -> VS.Vector (Complex a) -- ^ input vector 334 | -> (a, VS.Vector (Complex a)) -- ^ (final state, output vector) 335 | agc mu reference state input = A.first snd $ swap $ vUnfoldr (VS.length input) go (0, state) 336 | where 337 | go (offset, state) = 338 | let 339 | corrected = (input VS.! offset) `cmul` state 340 | state' = state + mu * (reference - magnitude corrected) 341 | in (corrected, (offset + 1, state')) 342 | 343 | -- | Simple automatic gain control pipe 344 | agcPipe :: (Num a, Storable a, RealFloat a, Monad m) 345 | => a -- ^ a 346 | -> a -- ^ reference 347 | -> Pipe (VS.Vector (Complex a)) (VS.Vector (Complex a)) m () 348 | agcPipe mu reference = pMapAccum (agc mu reference) 1 349 | 350 | -- | Specializes to combineInit :: IO (Pipe a b IO ()) -> Pipe a b IO () 351 | combineInit :: (Monad m, MonadTrans t, Monad (t m)) => m (t m a) -> t m a 352 | combineInit = join . lift 353 | 354 | -- | Specializes to combineInitTrans :: EitherT String IO (Pipe a b IO ()) -> Pipe a b (EitherT String IO) () 355 | combineInitTrans :: (Monad (t1 m), Monad (t (t1 m)), MonadTrans t, Monad m, MFunctor t, MonadTrans t1) => (t1 m) ((t m) a) -> t (t1 m) a 356 | combineInitTrans = combineInit . fmap (hoist lift) 357 | 358 | -------------------------------------------------------------------------------- /hs_sources/SDR/VectorUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | {-| Various Vector based utility functions -} 4 | module SDR.VectorUtils ( 5 | mapAccumMV, 6 | stride, 7 | fill, 8 | copyInto, 9 | vUnfoldr, 10 | vUnfoldrM 11 | ) where 12 | 13 | import Control.Monad 14 | import Control.Monad.Primitive 15 | import Control.Monad.ST 16 | 17 | import qualified Data.Vector.Generic as VG 18 | import qualified Data.Vector.Generic.Mutable as VGM 19 | import qualified Data.Vector.Fusion.Bundle as VFB 20 | import Data.Vector.Fusion.Stream.Monadic as VFSM 21 | 22 | {-| Like mapAccumL but monadic and over vectors. Doesn't return the 23 | accumulator at the end because it doesn't seem to be possible to do 24 | this with the Stream datatype, making this function pretty useless. 25 | -} 26 | mapAccumMV :: (Monad m) 27 | => (acc -> x -> m (acc, y)) -- ^ The function 28 | -> acc -- ^ The initial accumulator 29 | -> VFSM.Stream m x -- ^ The input stream 30 | -> Stream m y -- ^ The output stream 31 | mapAccumMV func z (VFSM.Stream step s) = VFSM.Stream step' (s, z) 32 | where 33 | step' (s, acc) = do 34 | r <- step s 35 | case r of 36 | VFB.Yield y s' -> do 37 | (!acc', !res) <- func acc y 38 | return $ VFB.Yield res (s', acc') 39 | VFB.Skip s' -> return $ VFB.Skip (s', acc) 40 | VFB.Done -> return VFB.Done 41 | 42 | {-| Create a vector from another vector containing only the elements that 43 | occur every stride elements in the source vector. 44 | -} 45 | {-# INLINE stride #-} 46 | stride :: VG.Vector v a 47 | => Int -- ^ The stride 48 | -> v a -- ^ The input Vector 49 | -> v a -- ^ The output Vector 50 | stride str inv = VG.unstream $ VFB.unfoldr func 0 51 | where 52 | len = VG.length inv 53 | func i | i >= len = Nothing 54 | | otherwise = Just (VG.unsafeIndex inv i, i + str) 55 | 56 | -- | Fill a mutable vector from a monadic stream. This appears to be missing from the Vector library. 57 | {-# INLINE fill #-} 58 | fill :: (PrimMonad m, Functor m, VGM.MVector vm a) 59 | => VFB.Bundle v a -- ^ The input Stream 60 | -> vm (PrimState m) a -- ^ The mutable Vector to stream into 61 | -> m () 62 | fill str outBuf = void $ VFB.foldM' put 0 str 63 | where 64 | put i x = do 65 | VGM.unsafeWrite outBuf i x 66 | return $ i + 1 67 | 68 | -- | Copy a Vector into a mutable vector 69 | {-# INLINE copyInto #-} 70 | copyInto :: (PrimMonad m, VGM.MVector vm a, VG.Vector v a) 71 | => vm (PrimState m) a -- ^ The destination 72 | -> v a -- ^ The source 73 | -> m () 74 | copyInto dst src = fill (VG.stream src) dst 75 | 76 | -- | Similar to unfoldrN from the vector package but the generator function cannot terminate and it returns the final value of the seed in addition to the vector 77 | {-# INLINE vUnfoldr #-} 78 | vUnfoldr :: VG.Vector v x 79 | => Int -- ^ Generates a vector with this size 80 | -> (acc -> (x, acc)) -- ^ The generator function 81 | -> acc -- ^ The initial value of the seed 82 | -> (v x, acc) -- ^ The (vector, final value of seed) result 83 | vUnfoldr size func acc = runST $ do 84 | vect <- VGM.new size 85 | acc' <- go vect 0 acc 86 | vect' <- VG.unsafeFreeze vect 87 | return (vect', acc') 88 | where 89 | go vect offset acc = go' offset acc 90 | where 91 | go' offset acc 92 | | offset == size = return acc 93 | | otherwise = do 94 | let (res, acc') = func acc 95 | VGM.write vect offset res 96 | go' (offset + 1) acc' 97 | 98 | -- | The same as `vUnfoldr` but the generator function is monadic 99 | {-# INLINE vUnfoldrM #-} 100 | vUnfoldrM :: (PrimMonad m, VG.Vector v x) 101 | => Int -- ^ Generates a vector with this size 102 | -> (acc -> m (x, acc)) -- ^ The monadic generator function 103 | -> acc -- ^ The initial value of the seed 104 | -> m (v x, acc) -- ^ The (vector, final value of seed) result 105 | vUnfoldrM size func acc = do 106 | vect <- VGM.new size 107 | acc' <- go vect 0 acc 108 | vect' <- VG.unsafeFreeze vect 109 | return (vect', acc') 110 | where 111 | go vect offset acc = go' offset acc 112 | where 113 | go' offset acc 114 | | offset == size = return acc 115 | | otherwise = do 116 | (res, acc') <- func acc 117 | VGM.write vect offset res 118 | go' (offset + 1) acc' 119 | 120 | -------------------------------------------------------------------------------- /sdr.cabal: -------------------------------------------------------------------------------- 1 | name: sdr 2 | version: 0.1.0.14 3 | synopsis: A software defined radio library 4 | description: 5 | Write software defined radio applications in Haskell. 6 | . 7 | Features: 8 | . 9 | * Signal processing blocks can be chained together using the library 10 | . 11 | * Zero copy design 12 | . 13 | * Signal processing functions are implemented in both Haskell and C (with SIMD acceleration) 14 | . 15 | * Can FIR filter, decimate and resample 16 | . 17 | * Helper functions for FIR filter design using window functions and plotting of the frequency response 18 | . 19 | * FFTs using 20 | . 21 | * Line and waterfall plots using OpenGL 22 | . 23 | * FM demodulation 24 | . 25 | * PulseAudio sound sink 26 | . 27 | * and based radio sources/sinks supported and other sources are easily added 28 | . 29 | See for more features and screenshots. 30 | . 31 | A collection of simple apps that use this library can be found . These include an FM radio receiver, an OpenGL waterfall plotter and an AM radio receiver. 32 | 33 | license: BSD3 34 | license-file: LICENSE 35 | author: Adam Walker 36 | maintainer: adamwalker10@gmail.com 37 | copyright: 2023 Adam Walker 38 | category: Software Defined Radio 39 | homepage: https://github.com/adamwalker/sdr 40 | bug-reports: https://github.com/adamwalker/sdr/issues 41 | build-type: Simple 42 | extra-source-files: Readme.md 43 | cabal-version: >=1.10 44 | 45 | source-repository head 46 | type: git 47 | location: https://github.com/adamwalker/sdr 48 | 49 | library 50 | if arch(i386) 51 | Buildable: False 52 | exposed-modules: 53 | SDR.Pulse, 54 | SDR.RTLSDRStream, 55 | SDR.Util, 56 | SDR.Plot, 57 | SDR.Filter, 58 | SDR.Demod, 59 | SDR.FFT, 60 | SDR.FilterInternal, 61 | SDR.Serialize, 62 | SDR.PipeUtils, 63 | SDR.VectorUtils, 64 | SDR.ArgUtils, 65 | SDR.FilterDesign, 66 | SDR.CPUID 67 | SDR.NetworkStream 68 | -- other-modules: 69 | other-extensions: ScopedTypeVariables, GADTs 70 | build-depends: 71 | base >=4.7 && <5, 72 | fftwRaw >=0.1 && <0.2, 73 | bytestring >=0.10 && <0.12, 74 | pulse-simple >=0.1 && <0.2, 75 | pipes >=4.1 && <4.4, 76 | pipes-concurrency >=2.0 && <2.1, 77 | time >=1.4 && <1.13, 78 | rtlsdr >=0.1 && <0.2, 79 | storable-complex >=0.2 && <0.3, 80 | pipes-bytestring >=2.0 && <2.2, 81 | dynamic-graph >=0.1.0.12 && <0.2, 82 | array >=0.4 && <0.6, 83 | vector >=0.11 && <0.14, 84 | tuple >=0.2 && <0.4, 85 | OpenGL >=2.11 && <3.1, 86 | GLFW-b >=1.4.8 && <4, 87 | primitive >=0.5 && <0.9, 88 | colour >=2.3 && <2.4, 89 | pango >=0.13 && <0.14, 90 | containers >=0.5 && <0.7, 91 | cairo >=0.13 && <0.14, 92 | cereal >=0.4 && <0.6, 93 | optparse-applicative >=0.11 && <0.19, 94 | Decimal >=0.4 && <0.6, 95 | Chart >=1.3 && <1.10, 96 | Chart-cairo >=1.3 && <1.10, 97 | transformers >=0.5 && <0.7, 98 | network >=3 && <4, 99 | bytestring-to-vector >=0.3 && <0.5, 100 | mwc-random >=0.15 && <0.16 101 | -- hs-source-dirs: 102 | default-language: Haskell2010 103 | ghc-options: -O2 104 | includes: c_sources/common.h 105 | install-includes: c_sources/common.h 106 | c-sources: 107 | c_sources/filter.c, 108 | c_sources/decimate.c, 109 | c_sources/convert.c, 110 | c_sources/resample.c, 111 | c_sources/scale.c, 112 | c_sources/cpuid.c 113 | hs-source-dirs: hs_sources 114 | cc-options: -mavx2 -msse4 -g 115 | 116 | Test-Suite test 117 | type: exitcode-stdio-1.0 118 | main-is: TestSuite.hs 119 | build-depends: 120 | base >=4.6 && <5, 121 | QuickCheck >=2.8 && <2.15, 122 | vector >=0.11 && <0.14, 123 | primitive >=0.5 && <0.9, 124 | storable-complex >=0.2 && <0.3, 125 | test-framework >=0.8 && <0.9, 126 | test-framework-quickcheck2 >=0.3 && <0.4, 127 | sdr 128 | hs-source-dirs: tests 129 | ghc-options: -O2 130 | default-language: Haskell2010 131 | 132 | benchmark benchmark 133 | type: exitcode-stdio-1.0 134 | main-is: Benchmarks.hs 135 | build-depends: 136 | base >=4.6 && <5, 137 | criterion >=1.0 && <1.7, 138 | vector >=0.11 && <0.14, 139 | primitive >=0.5 && <0.9, 140 | storable-complex >=0.2 && <0.3, 141 | sdr 142 | hs-source-dirs: benchmarks 143 | ghc-options: -O2 144 | default-language: Haskell2010 145 | 146 | -------------------------------------------------------------------------------- /tests/TestSuite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | import Control.Monad.Primitive 4 | import Data.Complex 5 | import Control.Monad 6 | 7 | import qualified Data.Vector.Generic as VG 8 | import qualified Data.Vector.Generic.Mutable as VGM 9 | import qualified Data.Vector.Storable as VS 10 | import qualified Data.Vector.Storable.Mutable as VSM 11 | 12 | import Test.QuickCheck 13 | import Test.QuickCheck.Monadic 14 | import Test.Framework (defaultMain, testGroup) 15 | import Test.Framework.Providers.QuickCheck2 (testProperty) 16 | 17 | import SDR.FilterInternal 18 | import SDR.Util 19 | import SDR.CPUID 20 | 21 | sameResultM :: Monad m => (a -> a -> Bool) -> [m a] -> m Bool 22 | sameResultM _ [] = return True 23 | sameResultM eq (x:xs) = do 24 | res <- x 25 | ress <- sequence xs 26 | return $ all (eq res) ress 27 | 28 | sameResult :: (a -> a -> Bool) -> [a] -> Bool 29 | sameResult _ [] = True 30 | sameResult eq (x:xs) = all (eq x) xs 31 | 32 | tests info = [ 33 | testGroup "filters" [ 34 | testProperty "real" propFiltersReal, 35 | testProperty "complex" propFiltersComplex 36 | ], 37 | testGroup "decimators" [ 38 | testProperty "real" propDecimationReal, 39 | testProperty "complex" propDecimationComplex 40 | ], 41 | testGroup "resamplers" [ 42 | testProperty "real" propResamplingReal, 43 | testProperty "complex" propResamplingComplex 44 | ], 45 | testGroup "conversion" [ 46 | testProperty "rtlsdr" propConversionRTLSDR, 47 | testProperty "BladeRF" propConversionBladeRF 48 | ], 49 | testProperty "scaling" propScaleReal 50 | ] 51 | where 52 | hasFeatures :: [(CPUInfo -> Bool, a)] -> [a] 53 | hasFeatures = map snd . filter (($ info) . fst) 54 | 55 | sizes = elements [1024, 2048, 4096, 8192, 16384, 32768, 65536] 56 | numCoeffs = elements [32, 64, 128, 256, 512] 57 | factors' = [1, 2, 3, 5, 7, 11, 13, 17, 23] 58 | factors = elements factors' 59 | 60 | propFiltersReal = 61 | forAll sizes $ \size -> 62 | forAll (vectorOf size (choose (-10, 10))) $ \inBuf -> 63 | forAll numCoeffs $ \numCoeffs -> 64 | forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs -> 65 | testFiltersReal size numCoeffs coeffs inBuf 66 | 67 | testFiltersReal :: Int -> Int -> [Float] -> [Float] -> Property 68 | testFiltersReal size numCoeffs coeffs inBuf = monadicIO $ do 69 | let vCoeffsHalf = VS.fromList coeffs 70 | vCoeffs = VS.fromList $ coeffs ++ reverse coeffs 71 | vInput = VS.fromList inBuf 72 | num = size - numCoeffs*2 + 1 73 | 74 | res <- run $ sameResultM eqDelta $ map (getResult num) $ hasFeatures [ 75 | (const True, filterHighLevel vCoeffs num vInput), 76 | (const True, filterImperative1 vCoeffs num vInput), 77 | (const True, filterImperative2 vCoeffs num vInput), 78 | (const True, filterCRR vCoeffs num vInput), 79 | (hasSSE42, filterCSSERR vCoeffs num vInput), 80 | (hasAVX, filterCAVXRR vCoeffs num vInput), 81 | (hasSSE42, filterCSSESymmetricRR vCoeffsHalf num vInput), 82 | (hasAVX, filterCAVXSymmetricRR vCoeffsHalf num vInput) 83 | ] 84 | assert res 85 | 86 | propFiltersComplex = 87 | forAll sizes $ \size -> 88 | forAll (vectorOf size (choose (-10, 10))) $ \inBufR -> 89 | forAll (vectorOf size (choose (-10, 10))) $ \inBufI -> 90 | forAll numCoeffs $ \numCoeffs -> 91 | forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs -> 92 | testFiltersComplex size numCoeffs coeffs $ zipWith (:+) inBufR inBufI 93 | 94 | testFiltersComplex :: Int -> Int -> [Float] -> [Complex Float] -> Property 95 | testFiltersComplex size numCoeffs coeffs inBuf = monadicIO $ do 96 | let vCoeffsHalf = VS.fromList coeffs 97 | vCoeffs = VS.fromList $ coeffs ++ reverse coeffs 98 | vInput = VS.fromList inBuf 99 | num = size - numCoeffs*2 + 1 100 | vCoeffs2 = VG.fromList $ duplicate $ coeffs ++ reverse coeffs 101 | 102 | res <- run $ sameResultM eqDeltaC $ map (getResult num) $ hasFeatures [ 103 | (const True, filterHighLevel vCoeffs num vInput), 104 | (const True, filterCRC vCoeffs num vInput), 105 | (hasSSE42, filterCSSERC vCoeffs2 num vInput), 106 | (hasSSE42, filterCSSERC2 vCoeffs num vInput), 107 | (hasAVX, filterCAVXRC vCoeffs2 num vInput), 108 | (hasSSE42, filterCSSESymmetricRC vCoeffsHalf num vInput), 109 | (hasAVX, filterCAVXSymmetricRC vCoeffsHalf num vInput) 110 | ] 111 | assert res 112 | 113 | propDecimationReal = 114 | forAll sizes $ \size -> 115 | forAll (vectorOf size (choose (-10, 10))) $ \inBuf -> 116 | forAll numCoeffs $ \numCoeffs -> 117 | forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs -> 118 | forAll factors $ \factor -> 119 | testDecimationReal size numCoeffs factor coeffs inBuf 120 | 121 | testDecimationReal :: Int -> Int -> Int -> [Float] -> [Float] -> Property 122 | testDecimationReal size numCoeffs factor coeffs inBuf = monadicIO $ do 123 | let vCoeffsHalf = VS.fromList coeffs 124 | vCoeffs = VS.fromList $ coeffs ++ reverse coeffs 125 | vInput = VS.fromList inBuf 126 | num = (size - numCoeffs*2 + 1) `quot` factor 127 | 128 | res <- run $ sameResultM eqDelta $ map (getResult num) $ hasFeatures [ 129 | (const True, decimateHighLevel factor vCoeffs num vInput), 130 | (const True, decimateCRR factor vCoeffs num vInput), 131 | (hasSSE42, decimateCSSERR factor vCoeffs num vInput), 132 | (hasAVX, decimateCAVXRR factor vCoeffs num vInput), 133 | (hasSSE42, decimateCSSESymmetricRR factor vCoeffsHalf num vInput), 134 | (hasAVX, decimateCAVXSymmetricRR factor vCoeffsHalf num vInput) 135 | ] 136 | assert res 137 | 138 | propDecimationComplex = 139 | forAll sizes $ \size -> 140 | forAll (vectorOf size (choose (-10, 10))) $ \inBufR -> 141 | forAll (vectorOf size (choose (-10, 10))) $ \inBufI -> 142 | forAll numCoeffs $ \numCoeffs -> 143 | forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs -> 144 | forAll factors $ \factor -> 145 | testDecimationComplex size numCoeffs factor coeffs $ zipWith (:+) inBufR inBufI 146 | 147 | testDecimationComplex :: Int -> Int -> Int -> [Float] -> [Complex Float] -> Property 148 | testDecimationComplex size numCoeffs factor coeffs inBuf = monadicIO $ do 149 | let vCoeffsHalf = VS.fromList coeffs 150 | vCoeffs = VS.fromList $ coeffs ++ reverse coeffs 151 | vInput = VS.fromList inBuf 152 | num = (size - numCoeffs*2 + 1) `quot` factor 153 | vCoeffs2 = VG.fromList $ duplicate $ coeffs ++ reverse coeffs 154 | 155 | res <- run $ sameResultM eqDeltaC $ map (getResult num) $ hasFeatures [ 156 | (const True, decimateHighLevel factor vCoeffs num vInput), 157 | (const True, decimateCRC factor vCoeffs num vInput), 158 | (hasSSE42, decimateCSSERC factor vCoeffs2 num vInput), 159 | (hasSSE42, decimateCSSERC2 factor vCoeffs num vInput), 160 | (hasAVX, decimateCAVXRC factor vCoeffs2 num vInput), 161 | (hasSSE42, decimateCSSESymmetricRC factor vCoeffsHalf num vInput), 162 | (hasAVX, decimateCAVXRC2 factor vCoeffs num vInput), 163 | (hasAVX, decimateCAVXSymmetricRC factor vCoeffsHalf num vInput) 164 | ] 165 | assert res 166 | 167 | propResamplingReal = 168 | forAll sizes $ \size -> 169 | forAll (vectorOf size (choose (-10, 10))) $ \inBuf -> 170 | forAll (elements [32 .. 512]) $ \numCoeffs -> 171 | forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs -> 172 | forAll (elements $ tail factors') $ \decimation -> 173 | forAll (elements $ filter (< decimation) factors') $ \interpolation -> 174 | forAll (elements [0..interpolation - 1]) $ \group -> 175 | testResamplingReal size group numCoeffs interpolation decimation coeffs inBuf 176 | 177 | testResamplingReal :: Int -> Int -> Int -> Int -> Int -> [Float] -> [Float] -> Property 178 | testResamplingReal size group numCoeffs interpolation decimation coeffs inBuf = monadicIO $ do 179 | let vCoeffsHalf = VS.fromList coeffs 180 | vCoeffs = VS.fromList $ coeffs ++ reverse coeffs 181 | vInput = VS.fromList inBuf 182 | num = (size - numCoeffs*2 + 1) `quot` decimation 183 | offset = interpolation - 1 - ((interpolation + group * decimation - 1) `mod` interpolation) 184 | 185 | resampler3 <- run $ resampleCRR2 interpolation decimation (coeffs ++ reverse coeffs) 186 | resampler4 <- run $ resampleCSSERR interpolation decimation (coeffs ++ reverse coeffs) 187 | resampler5 <- run $ resampleCAVXRR interpolation decimation (coeffs ++ reverse coeffs) 188 | 189 | res <- run $ sameResultM eqDelta $ map (getResult num) $ hasFeatures [ 190 | (const True, void . resampleHighLevel interpolation decimation vCoeffs offset num vInput), 191 | (const True, void . resampleCRR num interpolation decimation offset vCoeffs vInput), 192 | (const True, void . resampler3 group num vInput), 193 | (hasSSE42, void . resampler4 group num vInput), 194 | (hasAVX, void . resampler5 group num vInput) 195 | ] 196 | assert res 197 | 198 | propResamplingComplex = 199 | forAll sizes $ \size -> 200 | forAll (vectorOf size (choose (-10, 10))) $ \inBufR -> 201 | forAll (vectorOf size (choose (-10, 10))) $ \inBufI -> 202 | forAll (elements [32 .. 512]) $ \numCoeffs -> 203 | forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs -> 204 | forAll (elements $ tail factors') $ \decimation -> 205 | forAll (elements $ filter (< decimation) factors') $ \interpolation -> 206 | forAll (elements [0..interpolation - 1]) $ \group -> 207 | testResamplingComplex size group numCoeffs interpolation decimation coeffs $ zipWith (:+) inBufR inBufI 208 | 209 | testResamplingComplex :: Int -> Int -> Int -> Int -> Int -> [Float] -> [Complex Float] -> Property 210 | testResamplingComplex size group numCoeffs interpolation decimation coeffs inBuf = monadicIO $ do 211 | let vCoeffsHalf = VS.fromList coeffs 212 | vCoeffs = VS.fromList $ coeffs ++ reverse coeffs 213 | vInput = VS.fromList inBuf 214 | num = (size - numCoeffs*2 + 1) `quot` decimation 215 | offset = interpolation - 1 - ((interpolation + group * decimation - 1) `mod` interpolation) 216 | 217 | resampler3 <- run $ resampleCRC interpolation decimation (coeffs ++ reverse coeffs) 218 | resampler4 <- run $ resampleCSSERC interpolation decimation (coeffs ++ reverse coeffs) 219 | resampler5 <- run $ resampleCAVXRC interpolation decimation (coeffs ++ reverse coeffs) 220 | 221 | res <- run $ sameResultM eqDeltaC $ map (getResult num) $ hasFeatures [ 222 | (const True, void . resampleHighLevel interpolation decimation vCoeffs offset num vInput), 223 | (const True, void . resampler3 group num vInput), 224 | (hasSSE42, void . resampler4 group num vInput), 225 | (hasAVX, void . resampler5 group num vInput) 226 | ] 227 | assert res 228 | 229 | propConversionRTLSDR = 230 | forAll sizes $ \size -> 231 | forAll (vectorOf (2 * size) (choose (-10, 10))) $ \inBuf -> 232 | testConversionRTLSDR size inBuf 233 | testConversionRTLSDR :: Int -> [Int] -> Property 234 | testConversionRTLSDR size inBuf = monadicIO $ do 235 | let vInput = VS.fromList $ map fromIntegral inBuf 236 | 237 | let res = sameResult eqDeltaC $ map VG.toList $ hasFeatures [ 238 | (const True, (interleavedIQUnsigned256ToFloat vInput :: VS.Vector (Complex Float))), 239 | (const True, interleavedIQUnsignedByteToFloat vInput), 240 | (hasSSE42, interleavedIQUnsignedByteToFloatSSE vInput), 241 | (hasAVX2, interleavedIQUnsignedByteToFloatAVX vInput) 242 | ] 243 | assert res 244 | 245 | propConversionBladeRF = 246 | forAll sizes $ \size -> 247 | forAll (vectorOf (2 * size) (choose (-10, 10))) $ \inBuf -> 248 | testConversionBladeRF size inBuf 249 | testConversionBladeRF :: Int -> [Int] -> Property 250 | testConversionBladeRF size inBuf = monadicIO $ do 251 | let vInput = VS.fromList $ map fromIntegral inBuf 252 | 253 | let res = sameResult eqDeltaC $ map VG.toList $ hasFeatures [ 254 | (const True, (interleavedIQSigned2048ToFloat vInput :: VS.Vector (Complex Float))), 255 | (const True, interleavedIQSignedWordToFloat vInput), 256 | (hasSSE42, interleavedIQSignedWordToFloatSSE vInput), 257 | (hasAVX2, interleavedIQSignedWordToFloatAVX vInput) 258 | ] 259 | assert res 260 | 261 | scales = elements [0.1, 0.5, 1, 2, 10] 262 | propScaleReal = 263 | forAll sizes $ \size -> 264 | forAll (vectorOf size (choose (-10, 10))) $ \inBuf -> 265 | forAll scales $ \factor -> 266 | testScaleReal size inBuf factor 267 | testScaleReal :: Int -> [Float] -> Float -> Property 268 | testScaleReal size inBuf factor = monadicIO $ do 269 | let vInput = VS.fromList inBuf 270 | 271 | res <- run $ sameResultM eqDelta $ map (getResult size) $ hasFeatures [ 272 | (const True, scaleC factor vInput), 273 | (hasSSE42, scaleCSSE factor vInput), 274 | (hasAVX, scaleCAVX factor vInput) 275 | ] 276 | assert res 277 | 278 | getResult :: (VSM.Storable a) => Int -> (VS.MVector RealWorld a -> IO b) -> IO [a] 279 | getResult size func = do 280 | outBuf <- VGM.new size 281 | func outBuf 282 | out :: VS.Vector a <- VG.freeze outBuf 283 | return $ VG.toList out 284 | eqDelta x y = all (uncurry eqDelta') $ zip x y 285 | where 286 | eqDelta' x y = abs (x - y) < 0.01 287 | eqDeltaC x y = all (uncurry eqDelta') $ zip x y 288 | where 289 | eqDelta' x y = magnitude (x - y) < 0.01 290 | duplicate :: [a] -> [a] 291 | duplicate = concatMap func 292 | where func x = [x, x] 293 | 294 | main = do 295 | info <- getCPUInfo 296 | defaultMain $ tests info 297 | 298 | --------------------------------------------------------------------------------