diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright (c) 2016 Anders Persson, Anton Ekblad, Emil Axelsson, + Koen Claessen, Markus Aronsson, Máté Karácsony +Copyright (c) 2015 Emil Axelsson + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Emil Axelsson nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,179 @@ +[![Build Status](https://travis-ci.org/Feldspar/raw-feldspar.png?branch=master)](https://travis-ci.org/Feldspar/raw-feldspar) + +# Resource-AWare Feldspar + +This package is a complete reimplementation and partly a redesign of the Feldspar EDSL (formerly implemented in [feldspar-language](http://hackage.haskell.org/package/feldspar-language)). Feldspar aims to raise the abstraction level of numeric processing and DSP. Its compiler generates efficient C code suitable for running on embedded targets. + +## Installation + +RAW-Feldspar can be installed directly from [Hackage](http://hackage.haskell.org/package/raw-feldspar), preferably in a [sandbox](https://www.haskell.org/cabal/users-guide/installing-packages.html#developing-with-sandboxes): + + cabal install raw-feldspar + +The installation can be sped up a bit (and the size of the installation reduced) by adding a flag to `language-c-quote` (a dependency of RAW-Feldspar): + + cabal install --constraint="language-c-quote -full-haskell-antiquotes" + +However, this flag should normally only be used when installing in a sandbox that has no other packages depending `language-c-quote`. + +## Getting started + +The best way to learn how to use RAW-Feldspar at the moment is to look through the [examples](examples/). We suggest going through the files named "TutN_..." in ascending order. The files are well-documented. + +There is also some guidance in the [Haddock documentation](http://hackage.haskell.org/package/raw-feldspar). + +The vector library is central to programming in Feldspar. Its general operation is explained in the [Haddock documentation](http://hackage.haskell.org/package/raw-feldspar/docs/Feldspar-Data-Vector.html), and many [examples](examples/) are using vectors. + +### Hello world! + +Here is the obligatory "Hello world!" to get you going: + +```haskell +import qualified Prelude +import Feldspar.Run + +helloWorld :: Run () +helloWorld = printf "Hello world!\n" +``` + +The program can be run from GHCi: + + *Main> runCompiled helloWorld + cc -std=c99 /tmp/edsl_16816927771714636915.c -o /tmp/edsl_16816927771714636915 + + #### Running: + Hello world! + +Note the call to `cc` before the code is run. This requires you to have a C compiler installed. + +Many programs can also be run without a C compiler, using `runIO`: + + *Main> runIO helloWorld + Hello world! + +If you just want to look at the beauty of the generated C code, you can instead run: + + *Main> icompile helloWorld + #include + int main() + { + fprintf(stdout, "Hello world!\n"); + return 0; + } + +### Numeric computations + +OK, since Feldspar is mostly about *computation*, we need one more example: a function computing the sum of the squares of the numbers from 1 to `n` (commonly known as the "Hello world" of vector fusion): + +```haskell +import qualified Prelude +import Feldspar.Run +import Feldspar.Data.Vector + +sumSq :: Data Word32 -> Data Word32 +sumSq n = sum $ map (\x -> x*x) (1...n) +``` + +The meaning of the function can be understood by comparing it to the standard Haskell function + +```haskell +sumSq :: Word32 -> Word32 +sumSq n = sum $ map (\x -> x*x) [1..n] +``` + +(Note that `sum` and `map` have been redefined in Feldspar. However, they behave analogously to their counterparts for lists.) + +In order to turn a pure function such as `sumSq` into a runnable program, we can use the construction `connectStdIO $ return . sumSq`. This results in a program that gets its input from `stdin` and prints its output to `stdout`: + + *Demo> icompile $ connectStdIO $ return . sumSq + #include + #include + int main() + { + uint32_t v0; + uint32_t state1; + uint32_t v2; + + fscanf(stdin, "%u", &v0); + state1 = 0; + for (v2 = 0; v2 < (uint32_t) (1 < v0 + 1) * v0; v2++) { + uint32_t let3; + + let3 = v2 + 1; + state1 = let3 * let3 + state1; + } + fprintf(stdout, "%u", state1); + return 0; + } + +Note how the whole `sumSq` computation has been fused into a single loop without any array allocation. + +## External libraries + +### Zeldspar + +[Zeldspar](../../../../koengit/zeldspar) is an implementation of the [Ziria DSL](http://dx.doi.org/10.1145/2694344.2694368) for wireless programming on top of RAW-Feldspar. + +### raw-feldspar-mcs + +[raw-feldspar-mcs](../../../../kmate/raw-feldspar-mcs) extends RAW-Feldspar and Zeldspar with multicore and scratchpad support. + +The repository contains many [examples](../../../../kmate/raw-feldspar-mcs/tree/master/examples) written for the [Parallella](http://www.parallella.org) multicore architecture. + +### feldspar-synch + +[feldspar-synch](../../../../emilaxelsson/feldspar-synch) is a library that extends Feldspar with Yampa-style synchronous streams. + +It contains a simple polyphonic synthesizer as a demonstration. The synthesizer may serve as a simple example of a complete (toy) application written in RAW-Feldspar. It also demonstrates how to make bindings to an external C library (the ALSA sound library). + +## Why RAW-Feldspar? + +The previous Feldspar implementation was split over three packages: + + * [feldspar-language](http://hackage.haskell.org/package/feldspar-language) -- the language front end + * [feldspar-compiler](http://hackage.haskell.org/package/feldspar-compiler) -- the C-generating back end + * [feldspar-io](../../../../emilaxelsson/feldspar-io) -- a monadic "IO" layer + +(`feldspar-io`, which is still at an early stage of development, adds support for writing interactive programs calling external functions, etc.) + +RAW-Feldspar is essentially a replacement of all three packages. It emerged as an exploration of two new ideas: + + * A new design in which memory usage is explicitly managed by the user + - In the previous implementation, most array manipulation was done using pure functions, giving the user little chance to control memory usage and often leading to unwanted array copying. + * Express the compiler as a translator to a typed low-level imperative EDSL + - This makes the compiler both safer and more flexible + - Read about the technique: [Compilation as a Typed EDSL-to-EDSL Transformation](http://fun-discoveries.blogspot.se/2016/03/compilation-as-typed-edsl-to-edsl.html) + +RAW-Feldspar has since become a respectable replacement of the previous implementation. RAW-Feldspar typically generates slicker code based on native types and functions. Due to the new design, the user also has more control over array allocations, leading to lower memory usage and fewer array copies. + +However, RAW-Feldspar also has some [limitations and lacks some features](../../wiki/Limitations-and-Missing-Features) compared to the previous version. Some features are missing simply because they have not been ported yet; others are missing for more fundamental reasons. + +## Limitations and missing features + +See [limitations and missing features](../../wiki/Limitations-and-Missing-Features). + +There is also a [list of possible enhancements and fixes](../../wiki/TODOs). + +## Implementation + +The implementation of RAW-Feldspar builds heavily on three generic packages: + + * [syntactic](http://hackage.haskell.org/package/syntactic), providing: + - a generic deep embedding of pure expressions + - generic optimizations + - etc. + * [operational-alacarte](http://hackage.haskell.org/package/operational-alacarte), providing: + - a generic deep embedding of monadic programs (based on the "Operational monad") + * [imperative-edsl](http://hackage.haskell.org/package/imperative-edsl), providing: + - operational instructions for imperative programs + - C code generation + - etc. + +`imperative-edsl` is used both to represent monadic Feldspar programs and the low-level imperative code produced by the Feldspar compiler (following the idea in [Compilation as a Typed EDSL-to-EDSL Transformation](http://fun-discoveries.blogspot.se/2016/03/compilation-as-typed-edsl-to-edsl.html)). + +The implementation also makes heavy use of the philosophy described in [Combining Deep and Shallow Embedding of Domain-Specific Languages](http://dx.doi.org/10.1016/j.cl.2015.07.003). The basic idea is to have a low-level core language -- the deep embedding -- and to build the user interface as shallow extensions on top of the core language. + +A prime example of the technique is the [vector library](http://hackage.haskell.org/package/raw-feldspar/docs/Feldspar-Data-Vector.html), which provides high-level vector representations with a rich programming interface. These vectors only exist in the meta-language (i.e. Haskell), and by the time the Feldspar compiler is called, the vectors are already gone and what is left is imperative code with highly optimized loops. We saw an example of this when compiling the `sumSq` example above. + +Another example is [feldspar-synch](../../../../emilaxelsson/feldspar-synch), which extends Feldspar with synchronous streams. The whole package is implemented as a shallow extension on top of RAW-Feldspar. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Concurrent.hs b/examples/Concurrent.hs new file mode 100644 --- /dev/null +++ b/examples/Concurrent.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Concurrent where + + + +import qualified Prelude + +import Feldspar.Run +import Feldspar.Run.Concurrent +import Feldspar.Data.Vector + + +-- | Waiting for thread completion. +waiting :: Run () +waiting = do + t <- fork $ printf "Forked thread printing %d\n" (0 :: Data Int32) + waitThread t + printf "Main thread printing %d\n" (1 :: Data Int32) + +-- | A thread kills itself using its own thread ID. +suicide :: Run () +suicide = do + tid <- forkWithId $ \tid -> do + printf "This is printed. %d\n" (0 :: Data Int32) + killThread tid + printf "This is not. %d\n" (0 :: Data Int32) + waitThread tid + printf "The thread is dead, long live the thread! %d\n" (0 :: Data Int32) + + + + +primChan :: Run () +primChan = do + let n = 7 + c :: Chan Closeable (Data Word32) <- newCloseableChan (n + 1) + writer <- fork $ do + printf "Writer started\n" + writeChan c n + arr <- constArr [1..n] + writeChanBuf c 0 n arr + printf "Writer ended\n" + reader <- fork $ do + printf "Reader started\n" + v <- readChan c + arr <- newArr v + readChanBuf c 0 v arr + printf "Received:" + for (0, 1, Excl v) $ \i -> do + e <- getArr arr i + printf " %d" e + printf "\n" + waitThread reader + waitThread writer + closeChan c + +pairChan :: Run () +pairChan = do + c :: Chan Closeable (Data Int32, Data Word8) <- newCloseableChan 10 + writer <- fork $ do + printf "Writer started\n" + writeChan c (1337,42) + printf "Writer ended\n" + reader <- fork $ do + printf "Reader started\n" + (a,b) <- readChan c + printf "Received: (%d, %d)\n" a b + waitThread reader + waitThread writer + closeChan c + +vecChan :: Run () +vecChan = do + c :: Chan Closeable (Pull (Data Index)) <- newCloseableChan (3 `ofLength` 10) + writer <- fork $ do + printf "Writer started\n" + let v = fmap (+1) (0 ... 9) + writeChan c v + printf "Writer ended\n" + reader <- fork $ do + printf "Reader started\n" + v <- readChan c + for (0, 1, Excl 10) $ \i -> do + printf "Received: (%d => %d)\n" i (v ! i) + waitThread reader + waitThread writer + closeChan c + + +runStorableChanTest = mapM_ (runCompiled' def opts) prog + where + prog = [ primChan, pairChan, vecChan ] + opts = def + { externalFlagsPost = ["-lpthread"] + , externalFlagsPre = [ "-I../imperative-edsl/include" + , "../imperative-edsl/csrc/chan.c" ] } + + + +---------------------------------------- + +testAll = do + tag "waiting" >> compareCompiled' def opts waiting (runIO waiting) "" + tag "suicide" >> compareCompiled' def opts suicide (runIO suicide) "" + where + tag str = putStrLn $ "---------------- examples/Concurrent.hs/" Prelude.++ str Prelude.++ "\n" + opts = def {externalFlagsPost = ["-lpthread"]} diff --git a/examples/DFT.hs b/examples/DFT.hs new file mode 100644 --- /dev/null +++ b/examples/DFT.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Discrete Fourier Transform + +module DFT + ( dft + , idft + ) where + + + +import Prelude () + +import Feldspar +import Feldspar.Data.Vector + + + +-- | Discrete Fourier Transform +dft :: (RealFloat a, PrimType a, PrimType (Complex a)) => + DPull (Complex a) -> DPull (Complex a) +dft vec = fromColVec $ matMul (mat (length vec)) (toColVec vec) + where + mat n = Pull2 n n $ \k l -> + polar 1 (-(2*π * i2n k * i2n l) / i2n n) + +-- | Inverse Discrete Fourier Transform +idft :: (RealFloat a, PrimType a, PrimType (Complex a)) => + DPull (Complex a) -> DPull (Complex a) +idft = divLen . map conjugate . dft . map conjugate + where + divLen v = fmap (/ i2n (length v)) v + diff --git a/examples/FFT.hs b/examples/FFT.hs new file mode 100644 --- /dev/null +++ b/examples/FFT.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + +-- Copyright (c) 2013, Emil Axelsson, Peter Jonsson, Anders Persson and +-- Josef Svenningsson +-- Copyright (c) 2012, Emil Axelsson, Gergely Dévai, Anders Persson and +-- Josef Svenningsson +-- Copyright (c) 2009-2011, ERICSSON AB +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- * Neither the name of the ERICSSON AB nor the names of its contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +module FFT + ( fft + , ifft + ) where + + + +import Prelude () + +import Feldspar.Run +import Feldspar.Data.Vector +import Feldspar.Data.Buffered + + + +rotBit :: Data Index -> Data Index -> Data Index +rotBit k i = lefts .|. rights + where + k' = i2n k + ir = i .>>. 1 + rights = ir .&. oneBits k' + lefts = (((ir .>>. k') .<<. 1) .|. (i .&. 1)) .<<. k' + +riffle :: (Pully pull a, Syntax a) => Data Index -> pull -> Pull a +riffle = backPermute . const . rotBit + +bitRev :: (Manifestable Run vec a, Finite vec, Syntax a) + => Store a + -> Data Length + -> vec + -> Run (Manifest a) +bitRev st n = loopStore st (1,1,Incl n) $ \i -> return . riffle i + +testBit :: (Bits a, Num a, PrimType a) => Data a -> Data Index -> Data Bool +testBit a i = a .&. (1 .<<. i2n i) /= 0 + +fftCore + :: ( Manifestable Run vec (Data (Complex a)) + , Finite vec + , RealFloat a + , PrimType a + , PrimType (Complex a) + ) + => Store (Data (Complex a)) + -> Bool -- ^ Inverse? + -> Data Length + -> vec + -> Run (DManifest (Complex a)) +fftCore st inv n = loopStore st (n+1,-1,Incl 1) $ \i -> return . step (i-1) + -- Note: Cannot loop from n to 0 because 0-1 is `maxBound`, so the loop will + -- go on forever. + where + step k vec = Pull (length vec) ixf + where + ixf i = testBit i k ? (twid * (b - a)) $ (a+b) + where + k' = i2n k + a = vec ! i + b = vec ! (i `xor` k2) + twid = polar 1 ((if inv then π else -π) * i2n (lsbs k' i) / i2n k2) + k2 = 1 .<<. k' + +fft' + :: ( Manifestable Run vec (Data (Complex a)) + , Finite vec + , RealFloat a + , PrimType a + , PrimType (Complex a) + ) + => Store (Data (Complex a)) + -> Bool -- ^ Inverse? + -> vec + -> Run (DManifest (Complex a)) +fft' st inv v = do + n <- shareM (ilog2 (length v) - 1) + fftCore st inv n v >>= bitRev st n + +-- | Radix-2 Decimation-In-Frequency Fast Fourier Transformation of the given +-- complex vector. The given vector must be power-of-two sized, (for example 2, +-- 4, 8, 16, 32, etc.) The output is non-normalized. +fft + :: ( Manifestable Run vec (Data (Complex a)) + , Finite vec + , RealFloat a + , PrimType a + , PrimType (Complex a) + ) + => Store (Data (Complex a)) + -> vec + -> Run (DManifest (Complex a)) +fft st = fft' st False + +-- | Radix-2 Decimation-In-Frequency Inverse Fast Fourier Transformation of the +-- given complex vector. The given vector must be power-of-two sized, (for +-- example 2, 4, 8, 16, 32, etc.) The output is divided with the input size, +-- thus giving 'ifft . fft == id'. +ifft + :: ( Manifestable Run vec (Data (Complex a)) + , Finite vec + , RealFloat a + , PrimType a + , PrimType (Complex a) + ) + => Store (Data (Complex a)) + -> vec + -> Run (DPull (Complex a)) +ifft st v = normalize <$> fft' st True v + where + normalize = map (/ (i2n $ length v)) + diff --git a/examples/Tut1_HelloWorld.hs b/examples/Tut1_HelloWorld.hs new file mode 100644 --- /dev/null +++ b/examples/Tut1_HelloWorld.hs @@ -0,0 +1,51 @@ +module Tut1_HelloWorld where + +-- This file demonstrates: +-- +-- * How to write a very simple program +-- * How to run the program +-- * How to generate C code + +import Prelude () + +import Feldspar.Run + + + +-- Interactive programs run in the `Run` monad. + +helloWorld :: Run () +helloWorld = printf "Hello world!\n" + +-- `runCompiled` generates C code behind the scene, calls the C compiler and +-- then runs the resulting executable. + +test1 = runCompiled helloWorld + +-- Many programs can also be run directly in Haskell, without generating C code: + +test2 = runIO helloWorld + +-- If you want to see the generated code: + +test3 = putStrLn $ compile helloWorld + +-- Or shorter: + +test4 = icompile helloWorld + +-- For testing: +testAll = do + test1 + test2 + test3 + test4 + compareCompiled helloWorld (putStrLn "Hello world!") "" + -- `compareCompiled` is used to compare the output written to `stdout` + -- from a Feldspar program with that from a reference Haskell `IO` + -- program. The last argument will be fed to `stdin` to both the Feldspar + -- program and the reference. + compareCompiled helloWorld (runIO helloWorld) "" + -- The reference can also be obtained using `runIO`, which gives a way to + -- test that the Feldspar compiler preserves the semantics of `runIO`. + diff --git a/examples/Tut2_ExpressionsAndTypes.hs b/examples/Tut2_ExpressionsAndTypes.hs new file mode 100644 --- /dev/null +++ b/examples/Tut2_ExpressionsAndTypes.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE PartialTypeSignatures #-} + +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Tut2_ExpressionsAndTypes where + +-- This file demonstrates: +-- +-- * How to write pure functions in Feldspar +-- * Basic types and the `Syntax` class +-- * How to tell the compiler to link in necessary C libraries + +import Prelude () + +import Feldspar.Run + + + +-------------------------------------------------------------------------------- + +-- A function that doubles its argument: + +double :: (PrimType a, Num a) => Data a -> Data a +double a = a*2 + +-- The type constructor `Data` is for pure Feldspar expressions. `Data a` is an +-- expression that will yield a value of type `a` when evaluated. + +-- In order to compile `double`, we first need to monomorphize it. This can be +-- conveniently done using a partial type signature. Then we also need to get +-- the input from somewhere and do something with the output. A convenient way +-- to do this is to use `connectStdIO`, which gets the input from `stdin` and +-- writes the output to `stdout`. + +doubleRun :: Run () +doubleRun = connectStdIO $ return . (double :: _ Int32 -> _) + +comp_double = icompile doubleRun + +run_double = runCompiled doubleRun + + + +-------------------------------------------------------------------------------- + +type Point a = (a,a) + +-- This function computes the distance between two points in the plane: + +dist :: (PrimType a, Floating a) => Point (Data a) -> Point (Data a) -> Data a +dist (x1,y1) (x2,y2) = sqrt (dx**2 + dy**2) + where + dx = x1-x2 + dy = y1-y2 + +-- We need to uncurry `dist` before we can use `connectStdIO`: + +distRun = connectStdIO $ return . uncurry (dist :: (_ Double, _) -> _) + +comp_dist = icompile distRun + +-- Note that there are no tuples in the generated code. The coordinates simply +-- become four separate variables. The variables are assigned by reading four +-- numbers in sequence from `stdin`. + +-- In order to run compiled code that uses floating-point operations such as +-- `sqrt`, we must tell the C compiler to link in the C math library. We do that +-- as follows: + +mathOpts = def {externalFlagsPost = ["-lm"]} + +run_dist = runCompiled' def mathOpts distRun + +-- The first argument to `runCompiled'` is the options to the Feldspar compiler +-- and the second argument is options to the external compiler. The overloaded +-- value `def` gives the default options for the given type. + + + +-------------------------------------------------------------------------------- + +-- A function computing the nth Fibonacci number can be written using `forLoop`: + +fib :: Data Word32 -> Data Word32 +fib n = fst $ forLoop n (0,1) $ \i (a,b) -> (b,a+b) + +-- The arguments to `forLoop` are as follows, in order: +-- +-- * The number of iterations +-- * The initial state +-- * A step function computing the next state from the loop index and the +-- current state + +-- Note the use of ordinary Haskell tuples for constructing and matching on the +-- state. This is made possible by the `Syntax` class by which `forLoop` (and +-- many other functions) is overloaded. + +fibRun = connectStdIO $ return . fib + +comp_fib = icompile fibRun + +-- Note that the pair in the state doesn't appear in the generated code; the +-- state simply consists of two separate variables. + + + +-------------------------------------------------------------------------------- + +-- You'll see that many polymorphic Feldspar functions are overloaded by the +-- `Syntax` class; e.g.: +-- +-- forLoop :: Syntax st => Data Length -> st -> (Data Index -> st -> st) -> st +-- +-- Intuitively, `Syntax a` can be understood as any type that can be translated +-- to/from Feldspar expressions. Conversion is done using the following +-- functions: +-- +-- desugar :: Syntax a => a -> Data (Internal a) +-- sugar :: Syntax a => Data (Internal a) -> a +-- +-- However, there is rarely a need to use these conversions explicitly since +-- functions such as `forLoop` do them internally. + +-- For example, the two types +-- +-- Data (Int32, Double) +-- (Data Int32, Data Double) +-- +-- are isomorphic, and `desugar`/`sugar` convert between the two. However, the +-- latter type is almost always preferred, since it can be constructed and +-- destructed by the normal Haskell constructor `(,)`, as we saw in the `fib` +-- example. + + + +-------------------------------------------------------------------------------- + +testAll = do + comp_double + compareCompiled doubleRun (putStr "12") "6\n" + compareCompiled doubleRun (runIO doubleRun) "8\n" + comp_dist + compareCompiled' def mathOpts distRun' (runIO distRun') "11 12 13 14\n" + comp_fib + compareCompiled fibRun (putStr "8") "6\n" + compareCompiled fibRun (runIO fibRun) "7\n" + where + -- A version of `runDist` that returns an integer to avoid rounding errors + -- in `compareCompiled` + distRun' = connectStdIO $ return . conv . uncurry dist + where + conv :: Data Double -> Data Word32 + conv = round . (*100000) + diff --git a/examples/Tut3_Vectors.hs b/examples/Tut3_Vectors.hs new file mode 100644 --- /dev/null +++ b/examples/Tut3_Vectors.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE PartialTypeSignatures #-} + +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Tut3_Vectors where + +-- This file demonstrates: +-- +-- * Basic usage of the vector library +-- * Safety assertions in the generated code + +import Prelude () + +import Feldspar.Run +import Feldspar.Data.Vector + + + +-- The vector library will be used by most Feldspar programs that process data +-- in vector or matrix form. It provides a high-level interface, largely +-- by Haskell's list library. + +-- The vector library consists of three different vector types, each one in a +-- 1-dimensional and a 2-dimensional form: +-- +-- * `Manifest` / `Manifest2` +-- * `Pull` / `Pull2` +-- * `Push` / `Push2` +-- +-- In the common case when the element type is `Data`, we can use the following +-- shorthands: +-- +-- * `DManifest` / `DManifest2` +-- * `DPull` / `DPull2` +-- * `DPush` / `DPush2` +-- +-- I.e. we can write `DPull Word32` instead of `Pull (Data Word32)`. +-- +-- Each vector type has a different set of operations defined, and the +-- operations are chosen so that each type only supports those which can be +-- carried out rather efficiently for that type. +-- +-- Conversion from `Manifest` to `Pull` and from `Pull` to `Push` is always +-- cheap. However, conversion from `Pull`/`Push` to `Manifest` involves writing +-- the whole vector to memory. +-- +-- In most cases, the types will guide which type to use when, and conversions +-- are done automatically. For example, `++` is only supported by `Push`, but +-- the operator accepts any two vectors that can be converted to `Push` and it +-- will do the conversion automatically. +-- +-- The `Pull` and `Push` types enjoy *guaranteed* fusion. That is, all +-- intermediate vectors of type `Pull` or `Push` are guaranteed not to appear in +-- the generated code. Only `Manifest` vectors will. However, there are cases +-- when fusion leads to duplicated computations, which means that the user may +-- sometimes want to convert to `Manifest` even though this is not demanded by +-- the types. + +-- This file gives an introduction to vectors and some illustrating examples. +-- For more detailed information see the documentation: +-- + + + +-------------------------------------------------------------------------------- + +-- Pull vectors support many list-like operations. Here is a function that sums +-- the last 5 elements in a vector: + +sumLast5 :: (Num a, Syntax a) => Pull a -> a +sumLast5 = sum . take 5 . reverse + +comp_sumLast5 = icompile $ connectStdIO $ return . (sumLast5 :: _ -> Data Int32) + +-- Note that all intermediate pull vectors in `sumLast5` have been fused away. +-- The only array in the generated code is the one that holds the input. + +sumLast5Run = connectStdIO $ return . (sumLast5 :: _ -> Data Int32) + +run_sumLast5 = runCompiled sumLast5Run + +-- When running the program, the vector is entered by first giving its length +-- and then as many elements as the given length. For example, this is a valid +-- vector: "4 1 2 3 4\n". + +-- If we want the function to work also for `Manifest` vectors, we just change +-- the type: + +sumLast5' :: (Pully vec a, Num a, Syntax a) => vec -> a +sumLast5' = sum . take 5 . reverse + + + +-------------------------------------------------------------------------------- + +-- Compute the sum of the square of the numbers from 1 to n: + +sumSq :: Data Word32 -> Data Word32 +sumSq n = sum $ map (\x -> x*x) (1...n) + +sumSqRun = connectStdIO $ return . sumSq + +comp_sumSq = icompile sumSqRun + +-- Note that there is not a single array declared in the generated code, only +-- scalars. + +-- The type `Word32` is used a lot in the vector library. However, since it +-- usually represents either an index or a length, it goes under the aliases: +-- `Index` and `Length`. + + + +-------------------------------------------------------------------------------- + +-- Dot product of two vectors: + +dotProd :: (Num a, Syntax a) => Pull a -> Pull a -> a +dotProd a b = sum $ zipWith (*) a b + +dotProdRun = connectStdIO $ return . uncurry (dotProd :: _ -> _ -> Data Int32) + +comp_dotProd = icompile dotProdRun + +-- Again, if we want the function to work also for `Manifest` vectors, we just +-- change the type: + +dotProd' :: (Pully vec1 a, Pully vec2 a, Num a, Syntax a) => vec1 -> vec2 -> a +dotProd' a b = sum $ zipWith (*) a b + +-- This function is available under the name `scProd` in the vector library. + + + +-------------------------------------------------------------------------------- + +-- Pull vectors support arbitrary reading patterns. For example, `sumLast5` +-- demonstrated how to read a part from the end of a vector. + +-- Push vectors, on the other hand, support arbitrary write patterns. For +-- example `++` creates a vector that writes its content using two separate +-- loops -- one for the left operand and one for the right operand. + +-- The following function appends two modified compies of a vector to each +-- other: + +quirk :: (Pully vec a, Num a, MonadComp m) => vec -> Push m a +quirk vec = reverse vec ++ map (*2) vec + +-- `MonadComp` is any monad to which the monad `Comp` can be lifted. `Comp` can +-- be seen as a restricted version of `Run`, supporting only mutable data +-- structures (similarly to `ST` in normal Haskell). Both `Comp` and `Run` are +-- instances of `MonadComp`. + +-- The reason why `Push` is parameterized on the monad `m` is that it is +-- possible to embed side-effects into push vectors using the function +-- `sequens`. For more information, see the Haddock documentation for `sequens`. + +quirkRun = connectStdIO $ return . (quirk :: DPull Int32 -> Push Run _) + +comp_quirk = icompile quirkRun + + + +-------------------------------------------------------------------------------- + +-- Manifest vectors have a direct representation in memory; i.e. they correspond +-- to an array in the generated code. Manifest vectors can be created in +-- different ways; e.g.: +-- +-- * By reading from a file using `readStd` or `fread` +-- * By freezing a mutable vector using `unsafeFreezeSlice` +-- * By writing another vector to memory using `manifest` or `manifestFresh` + +-- Writing a vector to memory is often forced by the types. For example, if we +-- want to compose `sumLast5` with `quirk` we find that the types don't match +-- (even if `sumLast5` were overloaded using `Pully`, since there is no instance +-- `Pully Push`). + +demandedManifest :: (Num a, Syntax a, MonadComp m) => Pull a -> m a +demandedManifest vec = do + vec2 <- manifestFresh $ quirk vec + return $ sumLast5' vec2 + +-- Here, `vec2` is a manifest vector. One problem with this example is the use +-- of `manifestFresh` which silently allocates a fresh array to hold the +-- manifest vector. This array will be allocated on the stack and not freed +-- until the end of the current block in the generated code. + +-- An alternative to `manifestFresh` is `manifest` which takes the location to +-- which the vector should be written as an argument. This allows reusing the +-- same array for different manifest vectors. However, such reuse is dangerous +-- since each call to `manifest` with a given location will invalidate earlier +-- manifest vectors using that location. +-- +-- So the user has a choice: Either play safe and use `manifestFresh` or have +-- control over memory usage using `manifest`. Future plans involve +-- incorporating static analyses to rule out unsafe uses of `manifest` allowing +-- users to have both safety and control at the same time. + +demandedManifestRun = connectStdIO (demandedManifest :: _ -> Run (Data Int32)) + +comp_demandedManifest = icompile demandedManifestRun + + + +-------------------------------------------------------------------------------- + +-- The vector library contains many partial functions. In contrast to normal +-- Haskell, partial functions may not necessarily crash but may silently go on +-- producing bogus results. + +-- For example, in this program, we take the head of an empty vector and +-- multiply it by 2: + +bottom :: Data Word32 -> Data Word32 +bottom n = a*2 + where + a = head $ take 0 (1...n) + +bottomRun = connectStdIO $ return . bottom + +comp_bottom = icompile bottomRun + +-- Looking at the generated code, we see that it always returns the number 2 +-- without complaining. + +run_bottom = runCompiled bottomRun + +-- However, if we run the code, we'll find that it actually does crash, even +-- giving an informative message: "indexing outside of Pull vector". + +-- The reason is that `icompile` and `runCompiled` actually pass different +-- options to the Feldspar compiler. In order to see the assertions in the +-- generated code, we can use `icompile'`: + +comp_bottom_withAsserts = + icompile' def {compilerAssertions = allExcept []} bottomRun + +-- And in order to run the program without assertions, we can use +-- `runCompiled'`: + +run_bottom_withoutAsserts = + runCompiled' def {compilerAssertions = select []} def bottomRun + +-- Unfortunately, compiling with assertions will usually prevent simplification +-- of the generated code. The compiler also does a poor job of sharing +-- assertions which is why the same assertion may appear many times in the +-- generated code. +-- +-- For this reason, assertions are mostly intended to be used during testing. +-- When generating code for deployment, assertions will typically be turned off, +-- given that the code has been thoroughly tested. + + + +-------------------------------------------------------------------------------- + +testAll = do + comp_sumLast5 + compareCompiled sumLast5Run (putStr "80") "7 12 13 14 15 16 17 18\n" + compareCompiled sumLast5Run (runIO sumLast5Run) "7 22 23 24 25 26 27 28\n" + comp_sumSq + compareCompiled sumSqRun (putStr "385") "10\n" + compareCompiled sumSqRun (runIO sumSqRun) "20\n" + comp_dotProd + compareCompiled dotProdRun (putStr "794") "3 11 12 13 4 21 22 23 24\n" + compareCompiled dotProdRun (runIO dotProdRun) "3 11 12 13 4 31 32 33 34\n" + comp_quirk + compareCompiled quirkRun (putStr "6 4 3 2 4 6 8 ") "3 2 3 4\n" + compareCompiled quirkRun (runIO quirkRun) "3 12 13 14\n" + comp_demandedManifest + compareCompiled demandedManifestRun (putStr "23") "3 2 3 4\n" + compareCompiled demandedManifestRun (runIO demandedManifestRun) "3 12 13 14\n" + icompile bottomRun + comp_bottom_withAsserts + diff --git a/examples/Tut4_MemoryManagement.hs b/examples/Tut4_MemoryManagement.hs new file mode 100644 --- /dev/null +++ b/examples/Tut4_MemoryManagement.hs @@ -0,0 +1,146 @@ +module Tut4_MemoryManagement where + +-- This file demonstrates how to control memory usage when writing vector code. + +-- For a more realistic example of managed storage, see the example file +-- examples/FFT.hs. + +-- For more detailed information on double-buffered storage, see the +-- documentation: +-- + +-- Some of the examples show unsafe uses of functions, where the user is +-- expected to ensure proper usage. Future plans involve incorporating static +-- analyses to detect unsafe uses of memory. + +import Prelude () + +import Feldspar.Run +import Feldspar.Data.Vector +import Feldspar.Data.Buffered + +import Tut3_Vectors (quirk) + + + +-------------------------------------------------------------------------------- + +-- A previous example showed the use of `manifestFresh` to store the content of +-- a vector in memory and get a manifest vector back as result. The problem with +-- this function is that it allocates an array under the hood. Often times, +-- vector operations are done in a "pipeline" consisting of many stages. In such +-- cases, one typically wants to allocate a small number of arrays and use +-- throughout the pipeline. + +-- As an example, consider using the previously defined function `quirk` to +-- build up a vector in several steps, starting from the singleton vector `[n]`: + +buildQuirk_safe :: Data Word32 -> Run (DManifest Word32) +buildQuirk_safe n = do + vec <- listManifest [n] + vec <- manifestFresh $ quirk vec + vec <- manifestFresh $ quirk vec + vec <- manifestFresh $ quirk vec + vec <- manifestFresh $ quirk vec + vec <- manifestFresh $ quirk vec + return vec + +-- (Note the use of shadowing to avoid coming up with unique variable names.) + +comp_buildQuirk_safe = icompile $ connectStdIO buildQuirk_safe + +-- Although this function is completely safe, allocating a fresh array for each +-- intermediate vector puts high pressure on the stack. + + + +-------------------------------------------------------------------------------- + +-- Another alternative is to allocate *one* storage, and use the function +-- `store` to store the intermediate vectors: + +buildQuirk_managed :: Data Word32 -> Run (DManifest Word32) +buildQuirk_managed n = do + st <- newStore 32 + vec <- store st $ listPush [n] + vec <- store st $ quirk vec + vec <- store st $ quirk vec + vec <- store st $ quirk vec + vec <- store st $ quirk vec + vec <- store st $ quirk vec + return vec + +-- Note that it is now up to the user to make sure that the store is large +-- enough to fit each of the intermediate vectors. + +-- Note also that we're using the same store throughout the code. Indeed, it +-- looks as though we're reading from and writing to the store at the same time. +-- The reason why this works is that a store actually consists of *two* arrays, +-- and the two buffers are automatically flipped (by pointer swapping) after +-- each `store`. + +comp_buildQuirk_managed = icompile $ connectStdIO buildQuirk_managed + + + +-------------------------------------------------------------------------------- + +-- For completeness, we also give an even more explicit version of the previous +-- functions: + +buildQuirk_managed2 :: Data Word32 -> Run (DManifest Word32) +buildQuirk_managed2 n = do + arr1 <- newArr 32 + arr2 <- newArr 32 + vec <- manifest arr1 $ listPush [n] + vec <- manifest arr2 $ quirk vec + vec <- manifest arr1 $ quirk vec + vec <- manifest arr2 $ quirk vec + vec <- manifest arr1 $ quirk vec + vec <- manifest arr2 $ quirk vec + return vec + +comp_buildQuirk_managed2 = icompile $ connectStdIO buildQuirk_managed2 + +-- The difference to the previous version is that we now allocate the two +-- buffers explicitly, and manually make sure to use the buffers in alternating +-- order. + +-- Essentially, the only time the above style is preferred is when we need to +-- take unsafe shortcuts. For example, if we replace `quirk` with a function +-- that can be performed in-place, we can get away with using a single buffer: + +build_inplace :: Data Word32 -> Run (DManifest Word32) +build_inplace n = do + arr <- newArr n + vec <- manifest arr (1...n) + vec <- manifest arr $ map (*2) vec + vec <- manifest arr $ map (*3) vec + vec <- manifest arr $ map (*4) vec + vec <- manifest arr $ map (*5) vec + vec <- manifest arr $ map (*6) vec + return vec + +comp_build_inplace = icompile $ connectStdIO build_inplace + + + +-------------------------------------------------------------------------------- + +testAll = do + comp_buildQuirk_safe + compareCompiled (connectStdIO buildQuirk_safe) (putStr "32 80 40 20 40 20 10 20 40 20 10 5 10 20 10 20 40 80 40 20 40 20 10 20 40 80 40 20 40 80 40 80 160 ") "5\n" + -- compareCompiled (connectStdIO buildQuirk_safe) (runIO $ connectStdIO buildQuirk_safe) "5\n" + -- TODO Code generation too slow... + comp_buildQuirk_managed + compareCompiled (connectStdIO buildQuirk_managed) (putStr "32 80 40 20 40 20 10 20 40 20 10 5 10 20 10 20 40 80 40 20 40 20 10 20 40 80 40 20 40 80 40 80 160 ") "5\n" + -- compareCompiled (connectStdIO buildQuirk_managed) (runIO $ connectStdIO buildQuirk_managed) "5\n" + -- TODO Code generation too slow... + comp_buildQuirk_managed2 + compareCompiled (connectStdIO buildQuirk_managed2) (putStr "32 80 40 20 40 20 10 20 40 20 10 5 10 20 10 20 40 80 40 20 40 20 10 20 40 80 40 20 40 80 40 80 160 ") "5\n" + -- compareCompiled (connectStdIO buildQuirk_managed2) (runIO $ connectStdIO buildQuirk_managed2) "5\n" + -- TODO Code generation too slow... + comp_build_inplace + compareCompiled (connectStdIO build_inplace) (putStr "5 720 1440 2160 2880 3600 ") "5\n" + compareCompiled (connectStdIO build_inplace) (runIO $ connectStdIO build_inplace) "5\n" + diff --git a/examples/Tut5_Matrices.hs b/examples/Tut5_Matrices.hs new file mode 100644 --- /dev/null +++ b/examples/Tut5_Matrices.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE PartialTypeSignatures #-} + +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Tut5_Matrices where + +-- This file demonstrates programming with matrices. + +-- Please get acquainted with the examples covering vectors and memory +-- management before trying out these examples. + +import Prelude () + +import Feldspar.Run +import Feldspar.Data.Vector +import Feldspar.Data.Buffered + +import Tut2_ExpressionsAndTypes (mathOpts) +import DFT +import FFT + + + +-------------------------------------------------------------------------------- + +-- The following function defines matrix multiplication (available as `matMul` +-- in the vector library): + +mmul :: (Pully2 vec1 a, Pully2 vec2 a, Num a, Syntax a) => + vec1 -> vec2 -> Pull2 a +mmul veca vecb = Pull2 (numRows va) (numCols vb) $ \i j -> + scProd (va!i) (transpose vb ! j) + where + va = toPull2 veca + vb = toPull2 vecb + +-- The constructor `Pull2` constructs a matrix given +-- +-- * The number of rows +-- * The number of columns +-- * A function mapping row index and column index to element + +mmulRun = connectStdIO $ + return . uncurry (mmul :: DPull2 Int32 -> DPull2 _ -> _) + + + +-------------------------------------------------------------------------------- + +-- The file examples/DFT.hs provides an interesting example of matrix programming. The +-- DFT function is expressed as a multiplication of a transformation matrix with +-- the input vector. The matrix is never manifested, and the resulting code is +-- a doubly-nested loop where the matrix elements appear in the innermost +-- calculation. + +dftRun = connectStdIO $ return . (dft :: DPull (Complex Double) -> _) + + + +-------------------------------------------------------------------------------- + +-- We are often interested in doing something for each row or column (or some +-- other partitioning) of a matrix. This can be done using a combination of +-- `exposeRows` and `hideRows` (and `transpose` in case one is interested in the +-- columns). + +-- The following function reverses each row in a matrix: + +revRows :: (Pully2 vec a, Finite2 vec, MonadComp m) => vec -> Push2 m a +revRows vec + = hideRows (numCols vec) + $ map reverse + $ exposeRows + $ vec + +revRowsRun = connectStdIO $ return . (revRows :: DPull2 Int32 -> Push2 Run _) + +run_revRows = runCompiled revRowsRun + +-- When running the program, the matrix is entered by first giving its number of +-- rows (r), then the number of columns (c), then the product r*c, and finally +-- the elements in order row by row. For example, this is a valid matrix: +-- "2 2 4 1 2 3 4\n". + + + +-------------------------------------------------------------------------------- + +-- What if we want to do an effectful operation, such as FFT (see +-- examples/FFT.hs), on the rows of a matrix? This is possible using the +-- function `sequens`, which lets a push vector "eat" up the effects on its +-- elements (read the Haddock documentation for `Push` and `sequens` to see the +-- potential pitfalls of effectful push vectors). + +-- The following function applies FFT to each column of a matrix: + +fftCols :: DManifest2 (Complex Double) -> Run (DManifest2 (Complex Double)) +fftCols vec = do + st <- newStore (numRows vec) + manifestFresh2 + $ transposePush + $ hideRows (numRows vec) + $ sequens + $ map (fft st) + $ exposeRows + $ transpose + $ vec + +fftColsRun = connectStdIO fftCols + + + +-------------------------------------------------------------------------------- + +testAll = do + icompile mmulRun + compareCompiled mmulRun (putStr "2 2 4 19 22 43 50 ") "2 2 4 1 2 3 4 2 2 4 5 6 7 8\n" + compareCompiled mmulRun (runIO mmulRun) "2 2 4 1 2 3 4 2 2 4 5 6 7 8\n" + icompile dftRun + captureCompiled' def mathOpts dftRun "4 11 12 13 14\n" + icompile revRowsRun + compareCompiled revRowsRun (putStr "2 2 4 6 5 8 7 ") "2 2 4 5 6 7 8\n" + compareCompiled revRowsRun (runIO revRowsRun) "2 2 4 5 6 7 8\n" + icompile fftColsRun + captureCompiled' def mathOpts fftColsRun "2 3 6 11 12 13 14 15 16\n" + return () + diff --git a/examples/Tut6_Testing.hs b/examples/Tut6_Testing.hs new file mode 100644 --- /dev/null +++ b/examples/Tut6_Testing.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE PartialTypeSignatures #-} + +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Tut6_Testing where + +-- This file demonstrates programming testing Feldspar functions with +-- QuickCheck. + +import qualified Prelude + +import Feldspar.Run +import Feldspar.Data.Vector + +import Test.QuickCheck +import Test.QuickCheck.Monadic as QC + + + +-- The function `marshalled` can be used to turn a Feldspar function +-- `a -> Run b` into a corresponding Haskell function `a' -> IO b'`. The type +-- family `HaskellRep` is used to relate `a` and `a'` resp. `b` and `b'`: +-- `a' ~ HaskellRep a` and `b' ~ HaskellRep b`. + +-- Since `marshalled` is defined in continuation passing style (in order to be +-- able to share generated files and clean up afterwards), it is convenient to +-- make our properties parameterized on the function under test. + +-- The following property tests that a given function indeed computes the scalar +-- product: + +prop_scProd :: (([Int32],[Int32]) -> IO Int32) -> Property +prop_scProd f = monadicIO $ do + as <- pick arbitrary + bs <- pick arbitrary + x <- run $ f (as,bs) + QC.assert (x Prelude.== scProdList as bs) + where + scProdList as bs = Prelude.sum $ Prelude.zipWith (*) as bs + +-- Note that we have to use QuickCheck's monadic API because the function under +-- test is in `IO`. + + + +-------------------------------------------------------------------------------- + +scProdRun = return . uncurry (scProd :: DPull Int32 -> DPull _ -> _) + +testAll = + marshalled scProdRun $ \scProd' -> + quickCheck $ prop_scProd scProd' + +-- Due to the sharing provided by `marshalled`, the function `scProdRun` is only +-- compiled once and then `quickCheck` calls the resulting program 100 times. + diff --git a/examples/Tut7_ImperativeProgramming.hs b/examples/Tut7_ImperativeProgramming.hs new file mode 100644 --- /dev/null +++ b/examples/Tut7_ImperativeProgramming.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Tut7_ImperativeProgramming where + +-- This file demonstrates +-- +-- * Imperative programming using loops, references and mutable arrays +-- * FFI: Binding to external C libraries +-- * Including C definitions + +-- TODO Add example with mutable arrays. + +import qualified Prelude + +import Feldspar.Run + +import Tut2_ExpressionsAndTypes (fib) + + + +-------------------------------------------------------------------------------- + +printFib :: Run () +printFib = do + printf "Enter a positive number: " + n <- readStd + printf "The %dth Fibonacci number is %d.\n" n (fib n) + +-- Note that `printf` accepts a variable number of arguments (like the `printf` +-- in normal Haskell). + + + +-------------------------------------------------------------------------------- + +-- Demonstration of mutable references and while-loops. + +sumInput :: Run () +sumInput = do + done <- initRef false + sum <- initRef (0 :: Data Word32) + while (not <$> getRef done) $ do + printf "Enter a number (0 means done): " + n <- readStd + iff (n == 0) + (setRef done true) + (modifyRef sum (+n)) + s <- getRef sum + printf "The sum of your numbers is %d.\n" s + + + +-------------------------------------------------------------------------------- + +-- Binding to external C libraries: + +abort :: Run () +abort = do + addInclude "" + callProc "abort" [] + +-- It possible to add C functions to the generated code and use `callProc` to +-- call them: + +printRef :: DRef Word32 -> Run () +printRef s = do + addInclude "" + addDefinition printRef_def + callProc "printRef" [refArg s] + where + printRef_def = [cedecl| + void printRef (typename uint32_t * s) { + printf ("The value of the reference is %d.\n", *s); + } + |] + +test_printRef = do + r <- initRef (22 :: Data Word32) + printRef r + +-- Note that code using `addDefinition`, `callProc` etc. cannot be run using +-- `runIO`. + + + +-------------------------------------------------------------------------------- + +testAll = do + compareCompiled printFib (runIO printFib) "7\n" + compareCompiled sumInput (runIO sumInput) (Prelude.unlines $ Prelude.map show $ Prelude.reverse [0..20]) + icompile abort + icompile test_printRef + compareCompiled test_printRef (putStrLn "The value of the reference is 22.") "" + diff --git a/raw-feldspar.cabal b/raw-feldspar.cabal new file mode 100644 --- /dev/null +++ b/raw-feldspar.cabal @@ -0,0 +1,181 @@ +name: raw-feldspar +version: 0.1 +synopsis: Resource-Aware Feldspar +description: An implementation of the Feldspar EDSL with focus on + resource-awareness. + . + Examples can be found in the @examples/@ directory. The + files named "TutN_..." can be studied as a tutorial (to be + read in ascending order). + . + For more information, see the README: + + . + To see which GHC versions RAW-Feldspar can be built with, + consult the Travis status page: + +license: BSD3 +license-file: LICENSE +author: Emil Axelsson +maintainer: emax@chalmers.se +copyright: Copyright (c) 2016 Anders Persson, Anton Ekblad, Emil Axelsson, + Koen Claessen, Markus Aronsson, Máté Karácsony + Copyright (c) 2015 Emil Axelsson +homepage: https://github.com/Feldspar/raw-feldspar +bug-reports: https://github.com/Feldspar/raw-feldspar/issues +category: Language +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: + README.md + examples/*.hs + tests/*.hs + +source-repository head + type: git + location: https://github.com/Feldspar/raw-feldspar.git + +library + exposed-modules: + Data.Inhabited + Data.TypedStruct + Data.Selection + Feldspar.Primitive.Representation + Feldspar.Primitive.Backend.C + Feldspar.Representation + Feldspar.Sugar + Feldspar.Frontend + Feldspar.Optimize + Feldspar + Feldspar.Run.Representation + Feldspar.Run.Concurrent + Feldspar.Run.Compile + Feldspar.Run.Frontend + Feldspar.Run.Marshal + Feldspar.Run + Feldspar.Data.Array + Feldspar.Data.Vector + Feldspar.Data.Buffered + Feldspar.Data.Option + Feldspar.Data.Validated + Feldspar.Data.Storable + + other-modules: + Data.Inhabited.TH + + default-language: Haskell2010 + + default-extensions: + ConstraintKinds + DefaultSignatures + DeriveFunctor + DeriveFoldable + DeriveTraversable + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + MultiParamTypeClasses + PatternSynonyms + Rank2Types + RecordWildCards + PartialTypeSignatures + ScopedTypeVariables + StandaloneDeriving + TypeFamilies + TypeOperators + ViewPatterns + + build-depends: + array, + base < 5, + constraints, + containers, + data-default-class, + data-hash, + imperative-edsl >= 0.7, + -- hardware-edsl >= 0.1.0.2, + language-c-quote, + mtl, + operational-alacarte, + prelude-edsl >= 0.4, + syntactic >= 3.6.1, + -- Smallest version that has `instD` + template-haskell + + hs-source-dirs: src + + ghc-options: + -fno-warn-partial-type-signatures + +test-suite NumSimpl + type: exitcode-stdio-1.0 + + hs-source-dirs: tests + + main-is: NumSimpl.hs + + default-language: Haskell2010 + + build-depends: + base, + mtl, + raw-feldspar, + syntactic, + tasty-quickcheck, + tasty-th + +test-suite Compilation + type: exitcode-stdio-1.0 + + hs-source-dirs: tests + + main-is: Compilation.hs + + default-language: Haskell2010 + + build-depends: + base, + mtl, + raw-feldspar + +test-suite Semantics + type: exitcode-stdio-1.0 + + hs-source-dirs: tests + + main-is: Semantics.hs + + default-language: Haskell2010 + + default-extensions: + FlexibleContexts + ScopedTypeVariables + + build-depends: + base, + QuickCheck, + raw-feldspar, + tasty, + tasty-quickcheck, + tasty-th + +test-suite Examples + type: exitcode-stdio-1.0 + + hs-source-dirs: tests examples + + main-is: Examples.hs + + default-language: Haskell2010 + + build-depends: + base, + QuickCheck, + raw-feldspar, + tasty, + tasty-hunit, + tasty-quickcheck + diff --git a/src/Data/Inhabited.hs b/src/Data/Inhabited.hs new file mode 100644 --- /dev/null +++ b/src/Data/Inhabited.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Inhabited types + +module Data.Inhabited where + + + +import Data.Complex +import Data.Int +import Data.Word + +import Data.Inhabited.TH + + + +-- | Inhabited types +class Inhabited a + where + -- | Example value. An example value does not have to be an agreed-upon + -- default value. It can really be any value whatsoever. + example :: a + +instance Inhabited Bool where example = False +instance Inhabited Int8 where example = 0 +instance Inhabited Int16 where example = 0 +instance Inhabited Int32 where example = 0 +instance Inhabited Int64 where example = 0 +instance Inhabited Word8 where example = 0 +instance Inhabited Word16 where example = 0 +instance Inhabited Word32 where example = 0 +instance Inhabited Word64 where example = 0 +instance Inhabited Float where example = 0 +instance Inhabited Double where example = 0 +instance Inhabited (Complex Float) where example = 0 +instance Inhabited (Complex Double) where example = 0 + +inhabitedTupleInstances 15 + diff --git a/src/Data/Inhabited/TH.hs b/src/Data/Inhabited/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Inhabited/TH.hs @@ -0,0 +1,29 @@ +module Data.Inhabited.TH where + + + +import Language.Haskell.TH + +import Language.Syntactic.TH + + + +inhabitedTupleInstances :: Int -> DecsQ +inhabitedTupleInstances n = return + [ instD + [AppT (ConT (mkName "Inhabited")) (VarT a) | a <- take w varSupply] + ( AppT + (ConT (mkName "Inhabited")) + (foldl AppT (TupleT w) (map VarT $ take w varSupply)) + ) + [ FunD + (mkName "example") + [ Clause + [] + (NormalB $ TupE $ map VarE $ replicate w (mkName "example")) + [] + ] + ] + | w <- [2..n] + ] + diff --git a/src/Data/Selection.hs b/src/Data/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Selection.hs @@ -0,0 +1,66 @@ +-- | Data structure for describing selections of values + +module Data.Selection + ( Selection + , includes + , selectBy + , empty + , universal + , select + , union + , intersection + , difference + , allExcept + ) where + + + +-- | Selection: description of a set of values +data Selection a = Selection (a -> Bool) + +-- | +-- @ +-- `mempty` = `empty` +-- `mappend` = `union` +-- @ +instance Monoid (Selection a) + where + mempty = empty + mappend = union + +-- | Check whether a value is included in a selection +includes :: Selection a -> a -> Bool +includes (Selection p) = p + +-- | Select the values that fulfill a predicate +selectBy :: (a -> Bool) -> Selection a +selectBy = Selection + +-- | Empty selection +empty :: Selection a +empty = Selection $ \_ -> False + +-- | Select all values +universal :: Selection a +universal = Selection $ \_ -> True + +-- | Union of selections +union :: Selection a -> Selection a -> Selection a +union s t = Selection $ \a -> includes s a || includes t a + +-- | Intersection of selections +intersection :: Selection a -> Selection a -> Selection a +intersection s t = Selection $ \a -> includes s a && includes t a + +-- | Difference of selections +difference :: Selection a -> Selection a -> Selection a +difference s t = Selection $ \a -> includes s a && not (includes t a) + +-- | Create a classification from a list of elements +select :: Eq a => [a] -> Selection a +select as = selectBy (`elem` as) + +-- | Select all values except those in the given list +allExcept :: Eq a => [a] -> Selection a +allExcept = difference universal . select + diff --git a/src/Data/TypedStruct.hs b/src/Data/TypedStruct.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedStruct.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | Typed binary tree structures + +module Data.TypedStruct where + + + +import Control.Monad.Identity + + + +-------------------------------------------------------------------------------- +-- * Representation +-------------------------------------------------------------------------------- + +-- | Typed binary tree structure +-- +-- The predicate @pred@ is assumed to rule out pairs. Functions like +-- 'extractSingle' and 'zipStruct' rely on this assumption. +data Struct pred con a + where + Single :: pred a => con a -> Struct pred con a + Two :: Struct pred con a -> Struct pred con b -> Struct pred con (a,b) + +-- It would have been nice to add a constraint `IsPair a ~ False` to `Single`, +-- so that one wouldn't have to rely on @pred@ to rule out pairs. However, +-- attempting to do so lead to very strange problems in the rest of the Feldspar +-- implementation, so in the end I abandoned this extra safety. +-- +-- The problems were strange enough that it seems likely they may be due to a +-- bug in GHC (7.10.2). So it might be worthwhile to try this again in a later +-- version. +-- +-- Note however, that `IsPair a ~ False` on `Single` is not enough to please the +-- completeness checker for functions like `extractSingle` in GHC 7.10. Maybe +-- the new completeness checker in GHC 8 will be satisfied? + +-- | Create a 'Struct' from a 'Struct' of any container @c@ and a structured +-- value @a@ +-- +-- For example: +-- +-- @ +-- `toStruct` (`Two` (`Single` `Proxy`) (`Single` `Proxy`)) (False,'a') +-- == +-- Two (Single (Identity False)) (Single (Identity 'a')) +-- @ +toStruct :: Struct p c a -> a -> Struct p Identity a +toStruct rep = go rep . Identity + where + go :: Struct p c a -> Identity a -> Struct p Identity a + go (Single _) i = Single i + go (Two ra rb) (Identity (a,b)) = + Two (go ra (Identity a)) (go rb (Identity b)) + + + +-------------------------------------------------------------------------------- +-- * Operations +-------------------------------------------------------------------------------- + +-- | Extract the value of a 'Single' +extractSingle :: pred a => Struct pred c a -> c a +extractSingle (Single a) = a + +-- | Map over a 'Struct' +mapStruct :: forall pred c1 c2 b + . (forall a . pred a => c1 a -> c2 a) + -> Struct pred c1 b + -> Struct pred c2 b +mapStruct f = go + where + go :: Struct pred c1 a -> Struct pred c2 a + go (Single a) = Single (f a) + go (Two a b) = Two (go a) (go b) + +-- | Monadic map over a 'Struct' +mapStructA :: forall m pred c1 c2 b . Applicative m + => (forall a . pred a => c1 a -> m (c2 a)) + -> Struct pred c1 b -> m (Struct pred c2 b) +mapStructA f = go + where + go :: Struct pred c1 a -> m (Struct pred c2 a) + go (Single a) = Single <$> (f a) + go (Two a b) = Two <$> go a <*> go b + +-- | Map over a 'Struct' +mapStructA_ :: forall m pred cont b . Applicative m => + (forall a . pred a => cont a -> m ()) -> Struct pred cont b -> m () +mapStructA_ f = go + where + go :: Struct pred cont a -> m () + go (Single a) = f a + go (Two a b) = go a *> go b + +-- mapStructM_ :: forall m pred cont b . Monad m => +-- (forall a . pred a => cont a -> m ()) -> Struct pred cont b -> m () +-- mapStructM_ f = sequence_ . listStruct f + -- This doesn't work for some reason, only if `pred` is constrained to a + -- concrete type. (On the other hand, using `listStruct` is probably less + -- efficient due to the use of `++`.) + +-- | Fold a 'Struct' to a list +listStruct :: forall pred cont b c . + (forall y . pred y => cont y -> c) -> Struct pred cont b -> [c] +listStruct f = go + where + go :: Struct pred cont a -> [c] + go (Single a) = [f a] + go (Two a b) = go a ++ go b + +-- | Zip two 'Struct's +zipStruct :: forall pred c1 c2 c3 b + . (forall a . pred a => c1 a -> c2 a -> c3 a) + -> Struct pred c1 b + -> Struct pred c2 b + -> Struct pred c3 b +zipStruct f = go + where + go :: Struct pred c1 a -> Struct pred c2 a -> Struct pred c3 a + go (Single a) (Single b) = Single (f a b) + go (Two a b) (Two c d) = Two (go a c) (go b d) + +-- | Zip two 'Struct's to a list +zipListStruct :: forall pred c1 c2 b r + . (forall a . pred a => c1 a -> c2 a -> r) + -> Struct pred c1 b + -> Struct pred c2 b + -> [r] +zipListStruct f = go + where + go :: Struct pred c1 a -> Struct pred c2 a -> [r] + go (Single a) (Single b) = [f a b] + go (Two a b) (Two c d) = go a c ++ go b d + +-- | Compare two 'Struct's using a function that compares the 'Single' elements. +-- If the structures don't match, 'False' is returned. +compareStruct :: forall pred c1 c2 c d + . (forall a b . (pred a, pred b) => c1 a -> c2 b -> Bool) + -> Struct pred c1 c + -> Struct pred c2 d + -> Bool +compareStruct f = go + where + go :: Struct pred c1 a -> Struct pred c2 b -> Bool + go (Single a) (Single b) = f a b + go (Two a b) (Two c d) = go a c && go b d + +-- | Lift a function operating on containers @con@ to a function operating on +-- 'Struct's. +liftStruct :: (pred a, pred b) => + (con a -> con b) -> Struct pred con a -> Struct pred con b +liftStruct f (Single a) = Single (f a) + +-- | Lift a function operating on containers @con@ to a function operating on +-- 'Struct's. +liftStruct2 :: (pred a, pred b, pred c) + => (con a -> con b -> con c) + -> Struct pred con a -> Struct pred con b -> Struct pred con c +liftStruct2 f (Single a) (Single b) = Single (f a b) + diff --git a/src/Feldspar.hs b/src/Feldspar.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar.hs @@ -0,0 +1,74 @@ +module Feldspar + ( module Prelude.EDSL + , module Control.Monad + -- * Types + -- ** Syntax + , Data + , Syntax + , Comp + -- ** Object-language types + , module Data.Int + , module Data.Word + , Complex (..) + , PrimType' + , PrimType + , Type + , Length + , Index + , Ref, DRef + , Arr, DArr + , IArr, DIArr + , Inhabited + , Syntactic + , Domain + , Internal + -- * Front end + , eval + , showAST + , drawAST + , module Feldspar.Frontend + , Bits + , FiniteBits + , Integral + , Ord + , RealFloat + , RealFrac + , Border (..) + , IxRange + , AssertionLabel (..) + ) where + +import Prelude.EDSL + +import Control.Monad hiding (foldM) + +import Data.Bits (Bits, FiniteBits) +import Data.Complex (Complex (..)) +import Data.Int +import Data.Word + +import Language.Syntactic (Syntactic, Domain, Internal) +import qualified Language.Syntactic as Syntactic + +import Language.Embedded.Imperative (Border (..), IxRange) + +import Data.Inhabited +import Feldspar.Primitive.Representation +import Feldspar.Representation +import Feldspar.Frontend +import Feldspar.Optimize + + + +-- | Show the syntax tree using Unicode art +-- +-- Only user assertions will be included. +showAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> String +showAST = Syntactic.showAST . optimize onlyUserAssertions . Syntactic.desugar + +-- | Draw the syntax tree on the terminal using Unicode art +-- +-- Only user assertions will be included. +drawAST :: (Syntactic a, Domain a ~ FeldDomain) => a -> IO () +drawAST = Syntactic.drawAST . optimize onlyUserAssertions . Syntactic.desugar + diff --git a/src/Feldspar/Data/Array.hs b/src/Feldspar/Data/Array.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Data/Array.hs @@ -0,0 +1,254 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +-- | Data structures for working with arrays +module Feldspar.Data.Array + ( Nest (nestNumSegs, nestSegLength) + , nest + , nestEvery + , unnest + , Dim, Dim1, Dim2, Dim3, Dim4 + , InnerExtent (..) + , listExtent + , MultiNest + , multiNest + , InnerExtent' (..) + , listExtent' + , tailExtent' + , convInnerExtent + -- * 2-dimensional arrays + , Finite2 (..) + , numRows + , numCols + ) where + + +import Prelude (Functor, Foldable, Traversable, error, product, reverse) + +import Feldspar.Run + + + +-- | Nested data structure (see explanation of 'nest') +data Nest a = Nest + { nestNumSegs :: Data Length + , nestSegLength :: Data Length + , _nestInner :: a + } + deriving (Functor, Foldable, Traversable) + +instance Slicable a => Indexed (Nest a) + where + type IndexedElem (Nest a) = a + Nest l w a ! i = slice (w*i') w a + where + i' = guardValLabel InternalAssertion (i Slicable (Nest a) + where + slice from n (Nest l w a) = Nest n' w $ slice (from'*w) (n'*w) a + where + guard = guardValLabel InternalAssertion (from+n<=l) "invalid Nest slice" + from' = guard from + n' = guard n + +-- | Note that @`HaskellRep` (`Nest` a) = (`Length`, `Length`, `HaskellRep` a)@ +-- rather than @[HaskellRep a]@. This means that e.g. +-- @`Nest` (`Nest` (`Fin` (`IArr` a)))@ is represented as +-- @(Length,Length,(Length,Length,(Length,[...])))@ instead of the more +-- convenient @[[...]]@. +instance MarshalFeld a => MarshalFeld (Nest a) + where + type HaskellRep (Nest a) = (Length, Length, HaskellRep a) + fwrite hdl (Nest h w a) = fwrite hdl (h,w,a) + fread hdl = do + (h,w,a) <- fread hdl + return $ Nest h w a + -- The reason for not using `HaskellRep (Nest a) = [HaskellRep a]` is that + -- this representation makes it impossible to implement `fread`. + +-- | Add a layer of nesting to a linear data structure by virtually chopping it +-- up into segments. The nesting is virtual in the sense that +-- @`unnest` (`nest` h w a)@ is syntactically identical to @a@. +-- +-- In an expression @`nest` l w a@, it must be the case that +-- @l*w == `length` a@. +-- +-- 'multiNest' may be a more convenient alternative to 'nest', expecially for +-- adding several levels of nesting. +nest :: Finite a + => Data Length -- ^ Number of segments + -> Data Length -- ^ Segment length + -> a + -> Nest a +nest l w a = Nest (guard l) (guard w) a + where + guard = guardValLabel + InternalAssertion + (l*w == length a) + "nest: unbalanced nesting" + +-- | A version of 'nest' that only takes the segment length as argument. The +-- total number of segments is computed by division. +-- +-- In an expression @`nestEvery` n a@, it must be the case that +-- @div (`length` a) n * n == `length` a@. +-- +-- This assumption permits removing the division in many cases when the nested +-- structure is later flattened in some way. +nestEvery :: Finite a + => Data Length -- ^ Segment length + -> a + -> Nest a +nestEvery n a = Nest (length a `unsafeBalancedDiv` n) n a + +-- | Remove a layer of nesting +unnest :: Slicable a => Nest a -> a +unnest (Nest l w a) = slice 0 (l*w) a + +-- | Increase dimensionality +-- +-- This type is used to represent the number of dimensions of a +-- multi-dimensional structure. For example, @`Dim` (`Dim` ())@ means two +-- dimensions (see the aliases 'Dim1', 'Dim2', etc.). +data Dim d + +-- | One dimension +type Dim1 = Dim () + +-- | Two dimensions +type Dim2 = Dim Dim1 + +-- | Three dimensions +type Dim3 = Dim Dim2 + +-- | Four dimensions +type Dim4 = Dim Dim3 + +-- | A description of the inner extent of a rectangular multi-dimensional +-- structure. \"Inner extent\" means the extent of all but the outermost +-- dimension. +-- +-- For example, this value +-- +-- @ +-- `Outer` `:>` 10 `:>` 20 :: `InnerExtent` (`Dim` (`Dim` (`Dim` ()))) +-- @ +-- +-- describes a three-dimensional structure where each inner structure has 10 +-- rows and 20 columns. +data InnerExtent d + where + NoExt :: InnerExtent () + Outer :: InnerExtent (Dim ()) + (:>) :: InnerExtent (Dim d) -> Data Length -> InnerExtent (Dim (Dim d)) + +infixl 5 :> + +-- | Return the inner extent as a list of lengths +listExtent :: InnerExtent d -> [Data Length] +listExtent = reverse . go + where + go :: InnerExtent d -> [Data Length] + go NoExt = [] + go Outer = [] + go (e :> l) = l : go e + +-- | Add as much nesting to a one-dimensional structure as needed to reach the +-- given dimensionality +type family MultiNest d a + where + MultiNest (Dim ()) a = a + MultiNest (Dim (Dim d)) a = Nest (MultiNest (Dim d) a) + +-- | Turn a one-dimensional structure into a multi-dimensional one by adding +-- nesting as described by the given 'InnerExtent' +multiNest :: forall a d . Finite a => + InnerExtent (Dim d) -> a -> MultiNest (Dim d) a +multiNest e a = go e lsAll + where + lsInner = listExtent e + lsAll = unsafeBalancedDiv (length a) (product lsInner) : lsInner + -- Extent of *all* dimensions (including the outermost) + + go :: InnerExtent (Dim d') -> [Data Length] -> MultiNest (Dim d') a + go Outer _ = a + go (e :> _) (l1:l2:ls) = Nest l1 l2 $ go e (l1*l2 : ls) + go (e :> _) _ = error "impossible" + -- Note: The `InnerExtent` argument is just there for the type checker. We + -- cannot take the lengths from that value, because they come in the wrong + -- order. + +-- | A version of 'InnerExtent' for internal use +data InnerExtent' d + where + ZE :: InnerExtent' () + OE :: InnerExtent' (Dim ()) + SE :: Data Length -> InnerExtent' d -> InnerExtent' (Dim d) + -- `InnerExtent'` is more convenient to work with than `InnerExtent`, because + -- it recurses over the dimensions outside-in. However, `InnerExtent` is more + -- convenient for the user. Consider these two values describing the inner + -- extent of a three-dimensional structure: + -- + -- Outer :> 10 :> 20 + -- 10 `SE` (20 `SE` ZE) + -- + -- In the first case it's clear that the extent of the outermost dimension is + -- omitted. + +listExtent' :: InnerExtent' d -> [Data Length] +listExtent' ZE = [] +listExtent' OE = [] +listExtent' (SE l e) = l : listExtent' e + +tailExtent' :: InnerExtent' (Dim d) -> InnerExtent' d +tailExtent' OE = ZE +tailExtent' (SE _ ls) = ls + +convInnerExtent :: InnerExtent d -> InnerExtent' d +convInnerExtent e = go e (listExtent e) + where + go :: InnerExtent d -> [Data Length] -> InnerExtent' d + go NoExt _ = ZE + go Outer _ = OE + go (e :> _) (l:ls) = SE l $ go e ls + go (_ :> _) _ = error "convInnerExtent: impossible" + + + +-------------------------------------------------------------------------------- +-- * 2-dimensional arrays +-------------------------------------------------------------------------------- + +class Finite2 a + where + -- | Get the extent of a 2-dimensional vector + -- + -- It must hold that: + -- + -- @ + -- `numRows` == `length` + -- @ + extent2 + :: a + -> (Data Length, Data Length) -- ^ @(rows,columns)@ + +-- | Get the number of rows of a two-dimensional structure +-- +-- @ +-- `numRows` == `length` +-- @ +numRows :: Finite2 a => a -> Data Length +numRows = fst . extent2 + +-- | Get the number of columns of a two-dimensional structure +numCols :: Finite2 a => a -> Data Length +numCols = snd . extent2 + +instance Finite2 (Nest a) + where + extent2 n = (nestNumSegs n, nestSegLength n) + diff --git a/src/Feldspar/Data/Buffered.hs b/src/Feldspar/Data/Buffered.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Data/Buffered.hs @@ -0,0 +1,203 @@ +-- | Double-buffered storage +-- +-- This module provides a safer alternative to the methods of the classes +-- 'Manifestable' and 'Manifestable2': +-- +-- * 'store' instead of 'manifest' +-- * 'store2' instead of 'manifest2' +-- * 'setStore' instead of 'manifestStore' +-- * 'setStore2' instead of 'manifestStore2' +-- +-- Consider the following example: +-- +-- > bad = do +-- > arr <- newArr 20 +-- > vec1 <- manifest arr (1...20) +-- > vec2 <- manifest arr $ map (*10) $ reverse vec1 +-- > printf "%d\n" $ sum vec2 +-- +-- First the vector @(1...20)@ is stored into @arr@. Then the result is used to +-- compute a new vector which is also stored into @arr@. So the storage is +-- updated while it is being read from, leading to unexpected results. +-- +-- Using this module, we can make a small change to the program: +-- +-- > good = do +-- > st <- newStore 20 +-- > vec1 <- store st (1...20) +-- > vec2 <- store st $ map (*10) $ reverse vec1 +-- > printf "%d\n" $ sum vec2 +-- +-- Now the program works as expected; i.e. gives the same result as the normal +-- Haskell expression +-- +-- > sum $ map (*10) $ reverse [1..20] +-- +-- The price we have to pay for safe storage is that @`newStore` l@ allocates +-- twice as much memory as @`newArr` l@. However, none of the other functions in +-- this module allocate any memory. +-- +-- Note that this module does not protect against improper use of +-- 'unsafeFreezeStore'. A vector from a frozen 'Store' is only valid as long as +-- the 'Store' is not updated. + +module Feldspar.Data.Buffered + ( Store + , newStore + , unsafeFreezeStore + , unsafeFreezeStore2 + , setStore + , setStore2 + , store + , store2 + , loopStore + , loopStore2 + ) where + +-- By only allowing `Store` to be created using `newStore`, we ensure that +-- `unsafeSwapArr` is only used in a safe way (on two arrays allocated in the +-- same scope). + + + +import Prelude () + +import Control.Monad.State + +import Feldspar.Representation +import Feldspar.Run +import Feldspar.Data.Vector + + + +-- | Double-buffered storage +data Store a = Store + { activeBuf :: Arr a + , freeBuf :: Arr a + } + +-- | Create a new double-buffered 'Store', initialized to a 0x0 matrix +-- +-- This operation allocates two arrays of the given length. +newStore :: (Syntax a, MonadComp m) => Data Length -> m (Store a) +newStore l = Store <$> newNamedArr "store" l <*> newNamedArr "store" l + +-- | Read the contents of a 'Store' without making a copy. This is generally +-- only safe if the the 'Store' is not updated as long as the resulting vector +-- is alive. +unsafeFreezeStore :: (Syntax a, MonadComp m) => + Data Length -> Store a -> m (Manifest a) +unsafeFreezeStore l = unsafeFreezeSlice l . activeBuf + +-- | Read the contents of a 'Store' without making a copy (2-dimensional +-- version). This is generally only safe if the the 'Store' is not updated as +-- long as the resulting vector is alive. +unsafeFreezeStore2 :: (Syntax a, MonadComp m) + => Data Length -- ^ Number of rows + -> Data Length -- ^ Number of columns + -> Store a + -> m (Manifest2 a) +unsafeFreezeStore2 r c Store {..} = + nest r c <$> unsafeFreezeSlice (r*c) activeBuf + +-- | Cheap swapping of the two buffers in a 'Store' +swapStore :: Syntax a => Store a -> Run () +swapStore Store {..} = unsafeSwapArr activeBuf freeBuf + +-- | Write a 1-dimensional vector to a 'Store'. The operation may become a no-op +-- if the vector is already in the 'Store'. +setStore :: (Manifestable Run vec a, Finite vec, Syntax a) => + Store a -> vec -> Run () +setStore st@Store {..} vec = case viewManifest vec of + Just iarr + | unsafeEqArrIArr activeBuf iarr -> + iff (iarrOffset iarr == arrOffset activeBuf) + (return ()) + saveAndSwap + -- We don't check if `iarr` is equal to the free buffer, because that + -- would mean that we're trying to overwrite a frozen buffer while + -- reading it, which should lead to undefined behavior. + _ -> saveAndSwap + where + saveAndSwap = manifestStore freeBuf vec >> swapStore st + +-- | Write a 2-dimensional vector to a 'Store'. The operation may become a no-op +-- if the vector is already in the 'Store'. +setStore2 :: (Manifestable2 Run vec a, Finite2 vec, Syntax a) => + Store a -> vec -> Run () +setStore2 st@Store {..} vec = case viewManifest2 vec of + Just arr + | let iarr = unnest arr + , unsafeEqArrIArr activeBuf iarr -> + iff (iarrOffset iarr == arrOffset activeBuf) + (return ()) + saveAndSwap + -- See comment to `setStore` + _ -> saveAndSwap + where + saveAndSwap = manifestStore2 freeBuf vec >> swapStore st + +-- | Write the contents of a vector to a 'Store' and get it back as a +-- 'Manifest' vector +store :: (Manifestable Run vec a, Finite vec, Syntax a) => + Store a -> vec -> Run (Manifest a) +store st vec = setStore st vec >> unsafeFreezeStore (length vec) st + +-- | Write the contents of a vector to a 'Store' and get it back as a +-- 'Manifest2' vector +store2 :: (Manifestable2 Run vec a, Finite2 vec, Syntax a) => + Store a -> vec -> Run (Manifest2 a) +store2 st vec = setStore2 st vec >> unsafeFreezeStore2 r c st + where + (r,c) = extent2 vec + +loopStore + :: ( Syntax a + , Manifestable Run vec1 a + , Finite vec1 + , Manifestable Run vec2 a + , Finite vec2 + ) + => Store a + -> IxRange (Data Length) + -> (Data Index -> Manifest a -> Run vec1) + -> vec2 + -> Run (Manifest a) +loopStore st rng body init = do + setStore st init + lr <- initRef $ length init + for rng $ \i -> do + l <- unsafeFreezeRef lr + next <- body i =<< unsafeFreezeStore l st + setStore st next + setRef lr $ length next + l <- unsafeFreezeRef lr + unsafeFreezeStore l st + +loopStore2 + :: ( Syntax a + , Manifestable2 Run vec1 a + , Finite2 vec1 + , Manifestable2 Run vec2 a + , Finite2 vec2 + ) + => Store a + -> IxRange (Data Length) + -> (Data Index -> Manifest2 a -> Run vec1) + -> vec2 + -> Run (Manifest2 a) +loopStore2 st rng body init = do + setStore2 st init + rr <- initRef $ numRows init + cr <- initRef $ numCols init + for rng $ \i -> do + r <- unsafeFreezeRef rr + c <- unsafeFreezeRef cr + next <- body i =<< unsafeFreezeStore2 r c st + setStore2 st next + setRef rr $ numRows next + setRef cr $ numCols next + r <- unsafeFreezeRef rr + c <- unsafeFreezeRef cr + unsafeFreezeStore2 r c st + diff --git a/src/Feldspar/Data/Option.hs b/src/Feldspar/Data/Option.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Data/Option.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE PolyKinds #-} + +-- | Optional values + +module Feldspar.Data.Option + ( OptionT + , Option + , none + , some + , guardO + , guarded + , rebuildOption + , option + , caseOption + , fromSome + , optionM + , caseOptionM + , fromSomeM + , optionT + , caseOptionT + , fromSomeT + ) where + + + +import Prelude () + +import Control.Monad.Operational.Higher +import Control.Monad.Identity +import Control.Monad.Trans + +import Language.Syntactic + +import Feldspar +import Feldspar.Representation + + + +data Opt fs a + where + None :: String -> Opt (Param1 prog) a + Guard :: String -> Data Bool -> Opt (Param1 prog) () + +instance HFunctor Opt + where + hfmap f (None msg) = None msg + hfmap f (Guard msg c) = Guard msg c + +-- | Transformer version of 'Option' +newtype OptionT m a = Option { unOption :: ProgramT Opt Param0 m a } + deriving (Functor, Applicative, Monad, MonadTrans) + +-- | Optional value, analogous to @`Either` `String` a@ in normal Haskell +type Option = OptionT Identity + +instance MonadComp m => MonadComp (OptionT m) + where + liftComp = lift . liftComp + iff c t f = do + okr <- initRef true + lift $ iff c + (optionT (\_ -> setRef okr false) return t) + (optionT (\_ -> setRef okr false) return f) + ok <- unsafeFreezeRef okr + guardO "iff: none" ok + for rng body = do + okr <- initRef true + lift $ for rng $ \i -> + optionT (\_ -> setRef okr false >> break) return (body i) + ok <- unsafeFreezeRef okr + guardO "for: none" ok + while cont body = do + okr <- initRef true + lift $ while + (cont' okr) + (optionT (\_ -> setRef okr false >> break) return body) + ok <- unsafeFreezeRef okr + guardO "while: none" ok + where + cont' okr = do + cr <- newRef + caseOptionT (cont >>= setRef cr) (\_ -> setRef okr false >> setRef cr false) return + unsafeFreezeRef cr + +instance Syntax a => Syntactic (Option a) + where + type Domain (Option a) = FeldDomain + type Internal (Option a) = (Bool, Internal a) + + desugar = unData . option + (\_ -> Feldspar.desugar (false,example :: (Data (Internal a)))) + (\a -> Feldspar.desugar (true,a)) + + sugar o = guarded "sugar: none" valid a + where + (valid,a) = Feldspar.sugar $ Data o + +-- | Construct a missing 'Option' value (analogous to 'Left' in normal Haskell) +none :: String -> OptionT m a +none = Option . singleton . None + +-- | Construct a present 'Option' value (analogous to 'Right' in normal Haskell) +some :: Monad m => a -> OptionT m a +some = return + +-- | Construct an 'Option' that is either 'none' or @`some` ()@ depending on +-- the Boolean guard +-- +-- In the expression @`guardO` c `>>` rest@, the action @rest@ will not be +-- executed unless @c@ is true. +guardO :: String -> Data Bool -> OptionT m () +guardO msg c = Option $ singleton $ Guard msg c + +-- | Construct an 'Option' from a guard and a value. The value will not be +-- evaluated if the guard is false. +guarded :: Monad m => String -> Data Bool -> a -> OptionT m a +guarded msg c a = guardO msg c >> return a + +rebuildOption :: Monad m => Option a -> OptionT m a +rebuildOption = interpretWithMonad go . unOption + where + go :: Opt (Param1 (OptionT m)) a -> OptionT m a + go (None msg) = none msg + go (Guard msg c) = guardO msg c + +-- | Deconstruct an 'Option' value (analogous to 'either' in normal Haskell) +option :: Syntax b + => (String -> b) -- ^ 'none' case + -> (a -> b) -- ^ 'some' case + -> Option a + -> b +option noneCase someCase (Option opt) = go (view opt) + where + go (Return a) = someCase a + go (None msg :>>= k) = noneCase msg + go (Guard msg c :>>= k) = cond c (go $ view $ k ()) (noneCase msg) + +-- | Deconstruct an 'Option' value +caseOption :: Syntax b + => Option a + -> (String -> b) -- ^ 'none' case + -> (a -> b) -- ^ 'some' case + -> b +caseOption o n s = option n s o + +-- | Extract the value of an 'Option' that is assumed to be present +fromSome :: Syntax a => Option a -> a +fromSome = option (const example) id + +-- | Deconstruct an 'Option' value (analogous to 'maybe' in normal Haskell) +optionM :: MonadComp m + => (String -> m ()) -- ^ 'none' case + -> (a -> m ()) -- ^ 'some' case + -> Option a + -> m () +optionM noneCase someCase (Option opt) = go $ view opt + where + go (Return a) = someCase a + go (None msg :>>= k) = noneCase msg + go (Guard msg c :>>= k) = iff c (go $ view $ k ()) (noneCase msg) + +-- | Deconstruct an 'Option' value +caseOptionM :: MonadComp m + => Option a + -> (String -> m ()) -- ^ 'none' case + -> (a -> m ()) -- ^ 'some' case + -> m () +caseOptionM o n s = optionM n s o + +-- | Extract the value of an 'Option' that is assumed to be present +fromSomeM :: (Syntax a, MonadComp m) => Option a -> m a +fromSomeM opt = do + r <- newRef + caseOptionM opt + (const $ return ()) + (setRef r) + unsafeFreezeRef r + +-- | Deconstruct an 'OptionT' value +optionT :: MonadComp m + => (String -> m ()) -- ^ 'none' case + -> (a -> m ()) -- ^ 'some' case + -> OptionT m a + -> m () +optionT noneCase someCase (Option opt) = go =<< viewT opt + where + go (Return a) = someCase a + go (None msg :>>= k) = noneCase msg + go (Guard msg c :>>= k) = iff c (go =<< viewT (k ())) (noneCase msg) + +-- | Deconstruct an 'OptionT' value +caseOptionT :: MonadComp m + => OptionT m a + -> (String -> m ()) -- ^ 'none' case + -> (a -> m ()) -- ^ 'some' case + -> m () +caseOptionT o n s = optionT n s o + +-- | Extract the value of an 'OptionT' that is assumed to be present +fromSomeT :: (Syntax a, MonadComp m) => OptionT m a -> m a +fromSomeT opt = do + r <- newRef + caseOptionT opt + (const $ return ()) + (setRef r) + unsafeFreezeRef r + diff --git a/src/Feldspar/Data/Storable.hs b/src/Feldspar/Data/Storable.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Data/Storable.hs @@ -0,0 +1,401 @@ +-- | Storable types +-- +-- Note that the 'Storable' interface is currently not ideal for vectors: +-- +-- * The 'Store' representation only allows a vector to be read back as the same +-- type as it was written. But it is usually desired to read a vector as +-- 'Manifest' regardless of what type it was written as. +-- +-- - But this is solved by using functions that operated on 'StoreRep' +-- instead (such as 'readStoreRep'). +-- +-- * There is no support for double-buffered storage, as provided by +-- "Feldspar.Data.Buffered" which means that memory management can become more +-- tedious. + +module Feldspar.Data.Storable where + + + +import qualified Prelude + +import Control.Monad +import Data.Proxy + +import Feldspar +import Feldspar.Data.Vector +import Feldspar.Data.Option +import Feldspar.Data.Validated + + + +-------------------------------------------------------------------------------- +-- * 'Forcible' class +-------------------------------------------------------------------------------- + +-- | Expression types that can be \"forced\" to values +class Forcible a + where + -- | Representation of a forced value + type ValueRep a + + -- | Force an expression to a value. The resulting value can be used + -- multiple times without risking re-computation. + -- + -- 'toValue' will allocate memory to hold the value. + toValue :: MonadComp m => a -> m (ValueRep a) + + -- | Convert a forced value back to an expression + fromValue :: ValueRep a -> a + +-- To some extent `Forcible` is subsumed by `Storable`. However, `ValueRep` is +-- more convenient to deal with for the user than `StoreRep`, since the latter +-- consists of mutable data structures (e.g. `Ref a` instead of `Data a`). + +-- `Forcible` also resembles the `Syntactic` class, with the difference that the +-- former has a monadic interface and a more free internal representation +-- (`Syntactic` only allows `Data (Internal a)` as the internal representation). +-- +-- This difference has two main benefits: +-- +-- * We can guarantee that `toValue` returns a "cheep" value. There is no such +-- guarantee for `desugar` of the `Syntactic` class. +-- * We can use data structures such as `IArr` as the representation of values + +instance Type a => Forcible (Data a) + where + type ValueRep (Data a) = Data a + toValue = unsafeFreezeRef <=< initRef + fromValue = sugar + +instance (Forcible a, Forcible b) => Forcible (a,b) + where + type ValueRep (a,b) = (ValueRep a, ValueRep b) + toValue (a,b) = (,) <$> toValue a <*> toValue b + fromValue (a,b) = (fromValue a, fromValue b) + +instance (Forcible a, Forcible b, Forcible c) => Forcible (a,b,c) + where + type ValueRep (a,b,c) = (ValueRep a, ValueRep b, ValueRep c) + toValue (a,b,c) = (,,) <$> toValue a <*> toValue b <*> toValue c + fromValue (a,b,c) = (fromValue a, fromValue b, fromValue c) + +instance (Forcible a, Forcible b, Forcible c, Forcible d) => Forcible (a,b,c,d) + where + type ValueRep (a,b,c,d) = (ValueRep a, ValueRep b, ValueRep c, ValueRep d) + toValue (a,b,c,d) = (,,,) <$> toValue a <*> toValue b <*> toValue c <*> toValue d + fromValue (a,b,c,d) = (fromValue a, fromValue b, fromValue c, fromValue d) + +instance Forcible a => Forcible [a] + where + type ValueRep [a] = [ValueRep a] + toValue = Prelude.mapM toValue + fromValue = Prelude.map fromValue + +-- | 'toValue' will force the value even if it's invalid +instance Forcible a => Forcible (Validated a) + where + type ValueRep (Validated a) = (Data Bool, ValueRep a) + toValue (Validated valid a) = toValue (valid,a) + fromValue = uncurry Validated . fromValue + +instance Syntax a => Forcible (Option a) + where + type ValueRep (Option a) = (Data Bool, a) + toValue o = do + valid <- initRef false + r <- initRef (example :: a) + caseOptionM o + (\_ -> return ()) + (\b -> setRef valid true >> setRef r b) + (,) <$> unsafeFreezeRef valid <*> unsafeFreezeRef r + fromValue (valid,a) = guarded "fromIStore: none" valid a + -- Ideally, one should use `Storable` instead of the `Syntax` constraint, and + -- make `r` a `Store` instead of a reference. But the problem is that one + -- would have to make use of `newStore` which needs a size argument. This is + -- problematic because the size of the value is not known until inside + -- `caseOptionM`. + +-- Note: There are no instances for vector types, because that would require +-- allocating a new array inside `toValue`. + +-- | Cast between 'Forcible' types that have the same value representation +forceCast :: (Forcible a, Forcible b, ValueRep a ~ ValueRep b, MonadComp m) => + a -> m b +forceCast = fmap fromValue . toValue + +-- | Force the computation of an expression. The resulting value can be used +-- multiple times without risking re-computation. +force :: (Forcible a, MonadComp m) => a -> m a +force = forceCast + + + +-------------------------------------------------------------------------------- +-- * 'Storable' class +-------------------------------------------------------------------------------- + +-- | Storable types +class Storable a + where + -- | Memory representation + type StoreRep a + -- | Size of memory representation + type StoreSize a + + -- | Creat a fresh memory store. It is usually better to use 'newStore' + -- instead of this function as it improves type inference. + newStoreRep :: MonadComp m => proxy a -> StoreSize a -> m (StoreRep a) + + -- | Store a value to a fresh memory store. It is usually better to use + -- 'initStore' instead of this function as it improves type inference. + initStoreRep :: MonadComp m => a -> m (StoreRep a) + + -- | Read from a memory store. It is usually better to use 'readStore' + -- instead of this function as it improves type inference. + readStoreRep :: MonadComp m => StoreRep a -> m a + + -- | Unsafe freezing of a memory store. It is usually better to use + -- 'unsafeFreezeStore' instead of this function as it improves type + -- inference. + unsafeFreezeStoreRep :: MonadComp m => StoreRep a -> m a + + -- | Write to a memory store. It is usually better to use 'writeStore' + -- instead of this function as it improves type inference. + writeStoreRep :: MonadComp m => StoreRep a -> a -> m () + +instance Storable () + where + type StoreRep () = () + type StoreSize () = () + newStoreRep _ _ = return () + initStoreRep _ = return () + readStoreRep _ = return () + unsafeFreezeStoreRep _ = return () + writeStoreRep _ _ = return () + +instance Type a => Storable (Data a) + where + type StoreRep (Data a) = DRef a + type StoreSize (Data a) = () + newStoreRep _ _ = newRef + initStoreRep = initRef + readStoreRep = getRef + unsafeFreezeStoreRep = unsafeFreezeRef + writeStoreRep = setRef + +instance (Storable a, Storable b) => Storable (a,b) + where + type StoreRep (a,b) = (StoreRep a, StoreRep b) + type StoreSize (a,b) = (StoreSize a, StoreSize b) + newStoreRep _ (a,b) = (,) <$> newStoreRep (Proxy :: Proxy a) a <*> newStoreRep (Proxy :: Proxy b) b + initStoreRep (a,b) = (,) <$> initStoreRep a <*> initStoreRep b + readStoreRep (la,lb) = (,) <$> readStoreRep la <*> readStoreRep lb + unsafeFreezeStoreRep (la,lb) = (,) <$> unsafeFreezeStoreRep la <*> unsafeFreezeStoreRep lb + writeStoreRep (la,lb) (a,b) = writeStoreRep la a >> writeStoreRep lb b + +instance (Storable a, Storable b, Storable c) => Storable (a,b,c) + where + type StoreRep (a,b,c) = (StoreRep a, StoreRep b, StoreRep c) + type StoreSize (a,b,c) = (StoreSize a, StoreSize b, StoreSize c) + newStoreRep _ (a,b,c) = (,,) <$> newStoreRep (Proxy :: Proxy a) a <*> newStoreRep (Proxy :: Proxy b) b <*> newStoreRep (Proxy :: Proxy c) c + initStoreRep (a,b,c) = (,,) <$> initStoreRep a <*> initStoreRep b <*> initStoreRep c + readStoreRep (la,lb,lc) = (,,) <$> readStoreRep la <*> readStoreRep lb <*> readStoreRep lc + unsafeFreezeStoreRep (la,lb,lc) = (,,) <$> unsafeFreezeStoreRep la <*> unsafeFreezeStoreRep lb <*> unsafeFreezeStoreRep lc + writeStoreRep (la,lb,lc) (a,b,c) = writeStoreRep la a >> writeStoreRep lb b >> writeStoreRep lc c + +instance (Storable a, Storable b, Storable c, Storable d) => Storable (a,b,c,d) + where + type StoreRep (a,b,c,d) = (StoreRep a, StoreRep b, StoreRep c, StoreRep d) + type StoreSize (a,b,c,d) = (StoreSize a, StoreSize b, StoreSize c, StoreSize d) + newStoreRep _ (a,b,c,d) = (,,,) <$> newStoreRep (Proxy :: Proxy a) a <*> newStoreRep (Proxy :: Proxy b) b <*> newStoreRep (Proxy :: Proxy c) c <*> newStoreRep (Proxy :: Proxy d) d + initStoreRep (a,b,c,d) = (,,,) <$> initStoreRep a <*> initStoreRep b <*> initStoreRep c <*> initStoreRep d + readStoreRep (la,lb,lc,ld) = (,,,) <$> readStoreRep la <*> readStoreRep lb <*> readStoreRep lc <*> readStoreRep ld + unsafeFreezeStoreRep (la,lb,lc,ld) = (,,,) <$> unsafeFreezeStoreRep la <*> unsafeFreezeStoreRep lb <*> unsafeFreezeStoreRep lc <*> unsafeFreezeStoreRep ld + writeStoreRep (la,lb,lc,ld) (a,b,c,d) = writeStoreRep la a >> writeStoreRep lb b >> writeStoreRep lc c >> writeStoreRep ld d + +initStoreRepVec :: forall m vec + . ( Storable vec + , StoreSize vec ~ Data Length + , Finite vec + , MonadComp m + ) + => vec -> m (StoreRep vec) +initStoreRepVec vec = do + st <- newStoreRep (Proxy :: Proxy vec) $ length vec + writeStoreRep st vec + return st + +initStoreRepVec2 :: forall m vec + . ( Storable vec + , StoreSize vec ~ (Data Length, Data Length) + , Finite2 vec + , MonadComp m + ) + => vec -> m (StoreRep vec) +initStoreRepVec2 vec = do + st <- newStoreRep (Proxy :: Proxy vec) $ extent2 vec + writeStoreRep st vec + return st + +writeStoreRepVec + :: ( Manifestable m vec a + , StoreRep vec ~ (DRef Length, Arr a) + , Finite vec + , Syntax a + , MonadComp m + ) + => StoreRep vec -> vec -> m () +writeStoreRepVec (lr,arr) vec = do + setRef lr $ length vec + manifestStore arr vec + +writeStoreRepVec2 + :: ( Manifestable2 m vec a + , StoreRep vec ~ (DRef Length, DRef Length, Arr a) + , Finite2 vec + , Syntax a + , MonadComp m + ) + => StoreRep vec -> vec -> m () +writeStoreRepVec2 (rr,cr,arr) vec = do + setRef rr $ numRows vec + setRef cr $ numCols vec + manifestStore2 arr vec + +instance Syntax a => Storable (Manifest a) + where + type StoreRep (Manifest a) = (DRef Length, Arr a) + type StoreSize (Manifest a) = Data Length + + newStoreRep _ l = (,) <$> initRef l <*> newArr l + + initStoreRep = initStoreRepVec + + readStoreRep (lr,arr) = do + l <- getRef lr + freezeSlice l arr + + unsafeFreezeStoreRep (lr,arr) = do + l <- unsafeFreezeRef lr + unsafeFreezeSlice l arr + + writeStoreRep = writeStoreRepVec + +instance Syntax a => Storable (Manifest2 a) + where + type StoreRep (Manifest2 a) = (DRef Length, DRef Length, Arr a) + type StoreSize (Manifest2 a) = (Data Length, Data Length) + + newStoreRep _ (r,c) = (,,) <$> initRef r <*> initRef c <*> newArr (r*c) + + initStoreRep = initStoreRepVec2 + + readStoreRep (rr,cr,arr) = do + r <- getRef rr + c <- getRef cr + nest r c <$> freezeSlice (r*c) arr + + unsafeFreezeStoreRep (rr,cr,arr) = do + r <- unsafeFreezeRef rr + c <- unsafeFreezeRef cr + nest r c <$> unsafeFreezeSlice (r*c) arr + + writeStoreRep = writeStoreRepVec2 + +instance Syntax a => Storable (Pull a) + where + type StoreRep (Pull a) = (DRef Length, Arr a) + type StoreSize (Pull a) = Data Length + + newStoreRep _ = newStoreRep (Proxy :: Proxy (Manifest a)) + initStoreRep = initStoreRepVec + + readStoreRep = fmap (toPull . (id :: Manifest a -> _)) . readStoreRep + + unsafeFreezeStoreRep = + fmap (toPull . (id :: Manifest a -> _)) . unsafeFreezeStoreRep + + writeStoreRep = writeStoreRepVec + +instance Syntax a => Storable (Push Comp a) + -- Generalizing this instance to any monad would require making the monad a + -- parameter of the class (like for Manifestable) + where + type StoreRep (Push Comp a) = (DRef Length, Arr a) + type StoreSize (Push Comp a) = Data Length + + newStoreRep _ = newStoreRep (Proxy :: Proxy (Manifest a)) + initStoreRep = initStoreRepVec + + readStoreRep = fmap (toPush . (id :: Manifest a -> _)) . readStoreRep + + unsafeFreezeStoreRep = + fmap (toPush . (id :: Manifest a -> _)) . unsafeFreezeStoreRep + + writeStoreRep (lr,arr) vec = liftComp $ do + setRef lr $ length vec + manifestStore arr vec + +instance (Storable a, Syntax a, StoreSize a ~ ()) => Storable (Option a) + where + type StoreRep (Option a) = (DRef Bool, StoreRep a) + type StoreSize (Option a) = () + newStoreRep _ _ = do + valid <- initRef false + r <- newStoreRep (Nothing :: Maybe a) () + return (valid,r) + initStoreRep o = do + valid <- initRef false + r <- newStoreRep (Proxy :: Proxy a) () + caseOptionM o + (\_ -> return ()) + (\b -> writeStoreRep (valid,r) (true,b)) + return (valid,r) + readStoreRep oRep = do + (valid,a) <- readStoreRep oRep + return $ guarded "readStoreRep: none" valid a + unsafeFreezeStoreRep oRep = do + (valid,a) <- unsafeFreezeStoreRep oRep + return $ guarded "unsafeFreezeStoreRep: none" valid a + writeStoreRep oRep@(valid,r) o = caseOptionM o + (\_ -> setRef valid false) + (\a -> writeStoreRep oRep (true,a)) + + + +---------------------------------------- +-- ** User interface +---------------------------------------- + +-- | Memory for storing values +newtype Store a = Store { unStore :: StoreRep a } + -- The reason for this type and its associated interface is to improve type + -- inference over the methods in the `Storable` class. The problem with those + -- methods is that they involve type families. + +-- | Create a fresh 'Store' +newStore :: forall a m . (Storable a, MonadComp m) => StoreSize a -> m (Store a) +newStore = fmap Store . newStoreRep (Proxy :: Proxy a) + +-- | Store a value to a fresh 'Store' +initStore :: (Storable a, MonadComp m) => a -> m (Store a) +initStore = fmap Store . initStoreRep + +-- | Read from a 'Store' +readStore :: (Storable a, MonadComp m) => Store a -> m a +readStore = readStoreRep . unStore + +-- | Unsafe freezeing of a 'Store'. This operation is only safe if the 'Store' +-- is not updated as long as the resulting value is alive. +unsafeFreezeStore :: (Storable a, MonadComp m) => Store a -> m a +unsafeFreezeStore = unsafeFreezeStoreRep . unStore + +-- | Write to a 'Store' +writeStore :: (Storable a, MonadComp m) => Store a -> a -> m () +writeStore = writeStoreRep . unStore + +-- | Update a 'Store' in-place +inplace :: (Storable a, MonadComp m) => Store a -> (a -> a) -> m () +inplace store f = writeStore store . f =<< unsafeFreezeStore store + diff --git a/src/Feldspar/Data/Validated.hs b/src/Feldspar/Data/Validated.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Data/Validated.hs @@ -0,0 +1,103 @@ +-- | Validated values +-- +-- 'Validated' is similar to 'Feldspar.Option.Option', with the difference that +-- 'Validated' does not guarantee that invalid values are not evaluated. +-- Therefore, 'Validated' should not be used to guard operations from illegal +-- use (e.g. array bounds checking). +-- +-- Still, the operations try to defer evaluation of invalid values as much as +-- possible. + +module Feldspar.Data.Validated where + + + +-- Since there's no guarantee that invalid values are not evaluated, there is +-- no point in hiding the implementation. Having access to the implementation +-- means that it's possible to take shortcuts. For example, `fmap` could not +-- have been implemented without opening up the representation. + + + +import Prelude () + +import Language.Syntactic + +import Feldspar hiding (desugar, sugar) +import Feldspar.Representation + + + +-- | A value that can be valid or invalid +data Validated a = Validated (Data Bool) a + +instance Functor Validated + where + fmap f (Validated valid a) = Validated valid (f a) + +instance Applicative Validated + where + pure = return + (<*>) = ap + +instance Monad Validated + where + return = Validated true + Validated valid a >>= k = Validated (valid && valid') b + where + Validated valid' b = k a + +instance Syntax a => Syntactic (Validated a) + where + type Domain (Validated a) = FeldDomain + type Internal (Validated a) = (Bool, Internal a) + desugar (Validated valid a) = desugar (valid,a) + sugar = uncurry Validated . sugar + +-- | Create a validated value. Note that the value may get evaluated even if the +-- condition is false. +validWhen :: Data Bool -> a -> Validated a +validWhen = Validated + +-- | Invalid value +invalid :: Syntax a => Validated a +invalid = Validated false example + +-- | Deconstruct an 'Validated' value +validated :: Syntax b + => b -- ^ Invalid case + -> (a -> b) -- ^ Valid case + -> Validated a + -> b +validated no yes (Validated valid a) = valid ? yes a $ no + +-- | Deconstruct an 'Validated' value +caseValidated :: Syntax b + => Validated a + -> b -- ^ Invalid case + -> (a -> b) -- ^ Valid case + -> b +caseValidated v no yes = validated no yes v + +fromValidated :: Syntax a + => Validated a + -> a -- ^ Value to return in case the first arg. is invalid + -> a +fromValidated v def = caseValidated v def id + +-- | Deconstruct an 'Validated' value +validatedM :: MonadComp m + => m () -- ^ Invalid case + -> (a -> m ()) -- ^ Valid case + -> Validated a + -> m () +validatedM no yes (Validated valid a) = iff valid (yes a) no + +-- | Deconstruct an 'Validated' value +caseValidatedM :: MonadComp m + => Validated a + -> m () -- ^ Invalid case + -> (a -> m ()) -- ^ Valid case + -> m () +caseValidatedM v no yes = validatedM no yes v + diff --git a/src/Feldspar/Data/Vector.hs b/src/Feldspar/Data/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Data/Vector.hs @@ -0,0 +1,1003 @@ +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +-- | This module gives a library of different vector types. +-- +-- = Basic use +-- +-- A typical 1-dimensional vector computation goes as follows: +-- +-- 1. Start with a 'Manifest' vector (one that is refers directly to an array in +-- memory). +-- +-- 2. Apply operations overloaded by 'Pully' (e.g. 'take', 'drop', 'map', +-- 'reverse'). The result is one or more 'Pull' vectors. +-- +-- 3. If the previous step resulted in several parts, assemble them using +-- operations overloaded by 'Pushy' (e.g. '++'). The result is a 'Push' +-- vector. +-- +-- 4. Write the vector to memory using 'manifest' or 'manifestFresh'. +-- +-- (Of course, there are many variations on this general scheme.) +-- +-- Note that it's possible to skip step \#2 or \#3 above. For example, it's +-- possible to directly concatenate two 'Manifest' vectors using '++', and +-- 'manifest' can be applied directly to a 'Pull' vector (or even to a +-- 'Manifest', in which case it becomes a no-op). +-- +-- +-- +-- = Efficiency and fusion +-- +-- The library has been designed so that all operations fuse together without +-- creating any intermediate structures in memory. The only exception is the +-- operations that produce 'Manifest' or 'Manifest2' vectors ('manifest', +-- 'manifest2', etc.). +-- +-- For example, the following function only creates a single structure in memory +-- even though it seemingly generates several intermediate vectors: +-- +-- @ +-- f :: (`Num` a, `Syntax` a, `MonadComp` m) => `Pull` a -> m (`Manifest` a) +-- f = `manifestFresh` . `reverse` . `map` (*2) . `take` 10 +-- @ +-- +-- Furthermore, the operations associated with each type of vector are +-- restricted to operations that can be carried out efficiently for that type. +-- For example, although it would be possible to implement append for 'Pull' +-- vectors, doing so results in unnecessary conditionals in the generated code. +-- Therefore, the '++' operator returns a 'Push' vector, which ensures efficient +-- generated code. +-- +-- In many cases, the cycle 'Manifest' -> 'Pull' -> 'Push' -> 'Manifest' is +-- guided by the types of the operations involved. However, there are cases when +-- it's preferable to shortcut the cycle even when it's not demanded by the +-- types. The reason is that fusion can lead to duplicated computations. +-- +-- Here is an example where fusion leads to redundant computations: +-- +-- @ +-- bad = do +-- v :: `DManifest` `Int32` <- `readStd` -- Read from stdin +-- let v' = `map` heavy v +-- v'' = v' `++` `reverse` v' +-- `writeStd` v'' -- Write to stdout +-- @ +-- +-- Since @v'@ is used twice in defining @v''@, the mapping of the @heavy@ +-- computation will be done twice when writing @v''@ to the output. One way to +-- prevent this is to perform the heavy mapping once, store the result in +-- memory, and define @v''@ from the stored vector: +-- +-- @ +-- good = do +-- v :: `DManifest` `Int32` <- `readStd` -- Read from stdin +-- v' <- `manifestFresh` $ `map` heavy v +-- let v'' = v' `++` `reverse` v' +-- `writeStd` v'' -- Write to stdout +-- @ +-- +-- Even though the examples are called @bad@ and @good@, there's not a clear-cut +-- answer to which version is best. It could depend on whether time or +-- memory is the most scarce resource. This library leaves the decision in the +-- hands of the programmer. +-- +-- +-- +-- = Working with matrices +-- +-- 2-dimensional matrix computations can follow a scheme similar to the above by +-- using the types 'Manifest2', 'Pull2' and 'Push2' and the corresponding +-- operations. +-- +-- A quite common situation is the need to apply an operation on each row or +-- column of a matrix. Operating on the rows can be done by a combination of +-- 'exposeRows' and 'hideRows'. For example, this function reverses each row in +-- a matrix: +-- +-- @ +-- revEachRow :: `MonadComp` m => `Pull2` a -> `Push2` m a +-- revEachRow mat = `hideRows` (`numCols` mat) $ `map` `reverse` $ `exposeRows` mat +-- @ +-- +-- 'exposeRows' takes a 'Pully2' matrix and turns it into @`Pull` (`Pull` a)@ +-- i.e. a vector of row vectors. 'map' is used to apply 'reverse' to each row. +-- Finally, 'hideRows' turns the nested vector it back into a matrix, of type +-- 'Push2'. +-- +-- Note that 'hideRows' generally cannot know the length of the rows, so this +-- number has to be provided as its first argument. When compiling with +-- assertions, it will be checked at runtime that the length of each row is +-- equal to the given length. +-- +-- In order to operate on the columns instead of the rows, just apply +-- 'transpose' on the original matrix. This operation will fuse with the rest of +-- the computation. +-- +-- It gets a bit more complicated when the operation applied to each row is +-- effectful. For example, the operation may have to use 'manifest' internally +-- giving it a monadic result type. In such situations, the function 'sequens' +-- is helpful. It is a bit similar to the standard function @sequence@ for +-- lists, execept that it converts @`Push` m (m a)@ into @`Push` m a@; i.e. it +-- embeds the effect into the resulting 'Push' vector. +-- +-- Here is a version of the previous example where the row operation is +-- effectful (due to 'manifestFresh') and 'sequens' is inserted to embed the +-- effects: +-- +-- @ +-- revEachRowM :: (`Syntax` a, `MonadComp` m) => `Pull2` a -> `Push2` m a +-- revEachRowM mat = `hideRows` (`numCols` mat) $ `sequens` +-- $ `map` (`manifestFresh` . `reverse`) $ `exposeRows` mat +-- +-- @ +-- +-- Note that 'sequens' is generally a dangerous function due to the hiding of +-- effects inside the resulting vector. These effects may be (seemingly) +-- randomly interleaved with other effects when the vector is used. However, the +-- above example is fine, since 'manifestFresh' allocates a fresh array for the +-- storage, so its effects cannot be observed from the outside. +-- +-- The comments to 'Push' elaborate more on the semantics of push vectors with +-- interleaved effects. + +module Feldspar.Data.Vector + ( module Feldspar.Data.Array + , module Feldspar.Data.Vector + ) where + + + +import qualified Prelude + +import Data.List (genericLength) +import Data.Proxy + +import Feldspar +import Feldspar.Data.Array +import Feldspar.Run +import Feldspar.Run.Concurrent +import qualified Language.Embedded.Concurrent as Imp + + + +-- This library has been inspired by the vector library in feldspar-language: +-- +-- +-- The general idea of pull and push vectors is described in +-- "Combining deep and shallow embedding of domain-specific languages" +-- . +-- +-- Push arrays were originally introduced in +-- "Expressive array constructs in an embedded GPU kernel programming language" +-- . + + + +-------------------------------------------------------------------------------- +-- * 1-dimensional manifest vectors +-------------------------------------------------------------------------------- + +-- | A 1-dimensional vector with a concrete representation in memory +-- +-- There are two main reasons to use 'Manifest' when possible instead of `Pull`: +-- +-- * The operations of the 'Manifestable' class are more efficient for +-- 'Manifest'. They either result in a no-op or an efficient memory-copy +-- (instead of a copying loop). +-- +-- * 'Manifest' can be freely converted to/from a 2-dimensional structure using +-- 'nest' and 'unnest'. Note that the representation of 'Manifest2' is +-- @`Nest` (`Manifest` a)@. +type Manifest = IArr + +-- | 'Manifest' vector specialized to 'Data' elements +type DManifest a = DIArr a + +-- | Treated as a row vector +instance Finite2 (Manifest a) where extent2 v = (1, length v) + +-- | Make a 'Manifest' vector from a list of values +listManifest :: (Syntax a, MonadComp m) => [a] -> m (Manifest a) +listManifest = manifestFresh . listPush + + + +-------------------------------------------------------------------------------- +-- * 2-dimensional manifest vectors +-------------------------------------------------------------------------------- + +-- | A 2-dimensional vector with a concrete representation in memory +type Manifest2 a = Nest (Manifest a) + +-- | 'Manifest2' vector specialized to 'Data' elements +type DManifest2 a = Manifest2 (Data a) + + + +-------------------------------------------------------------------------------- +-- * 1-dimensional pull vectors +-------------------------------------------------------------------------------- + +-- | 1-dimensional pull vector: a vector representation that supports random +-- access and fusion of operations +data Pull a where + Pull + :: Data Length -- Length of vector + -> (Data Index -> a) -- Index function + -> Pull a + +-- | 'Pull' vector specialized to 'Data' elements +type DPull a = Pull (Data a) + +instance Functor Pull + where + fmap f (Pull len ixf) = Pull len (f . ixf) + +-- It would be possible to have the instance: +-- +-- instance Applicative Pull +-- where +-- pure a = Pull 1 (const a) +-- Pull len1 ixf1 <*> Pull len2 ixf2 = Pull (len1*len2) $ \i -> +-- let k = i `div` len2 +-- l = i `mod` len2 +-- in ixf1 k $ ixf2 l +-- +-- However, it has been omitted due to the use of `div` and `mod`. + +instance Indexed (Pull a) + where + type IndexedElem (Pull a) = a + Pull len ixf ! i = ixf $ guardValLabel + InternalAssertion + (i < len) + "indexing outside of Pull vector" + i + +instance Finite (Pull a) + where + length (Pull len _) = len + +-- | Treated as a row vector +instance Finite2 (Pull a) where extent2 v = (1, length v) + +instance Slicable (Pull a) + where + slice from n = take n . drop from + +instance + ( Syntax a + , MarshalHaskell (Internal a) + , MarshalFeld a + ) => + MarshalFeld (Pull a) + where + type HaskellRep (Pull a) = HaskellRep (Manifest a) + fwrite hdl = fwrite hdl . toPush + fread hdl = (toPull :: Manifest a -> _) <$> fread hdl + +data VecChanSizeSpec lenSpec = VecChanSizeSpec (Data Length) lenSpec + +ofLength :: Data Length -> lenSpec -> VecChanSizeSpec lenSpec +ofLength = VecChanSizeSpec + +instance ( Syntax a, BulkTransferable a + , ContainerType a ~ Arr a + ) => Transferable (Pull a) + where + type SizeSpec (Pull a) = VecChanSizeSpec (SizeSpec a) + calcChanSize _ (VecChanSizeSpec n m) = + let hsz = n `Imp.timesSizeOf` (Proxy :: Proxy Length) + bsz = calcChanSize (Proxy :: Proxy a) m + in hsz `Imp.plusSize` (n `Imp.timesSize` bsz) + untypedReadChan c = do + len :: Data Length <- untypedReadChan c + arr <- newArr len + untypedReadChanBuf (Proxy :: Proxy a) c 0 len arr + toPull <$> unsafeFreezeArr arr + untypedWriteChan c v = do + arr <- newArr len + untypedWriteChan c len + untypedWriteChanBuf (Proxy :: Proxy a) c 0 len arr + where + len = length v + -- TODO Make instances for other vector types + +-- | Data structures that are 'Pull'-like (i.e. support '!' and 'length') +class (Indexed vec, Finite vec, IndexedElem vec ~ a) => Pully vec a +instance (Indexed vec, Finite vec, IndexedElem vec ~ a) => Pully vec a + +-- | Convert a vector to 'Pull' +toPull :: Pully vec a => vec -> Pull a +toPull vec = Pull (length vec) (vec!) + + + +---------------------------------------- +-- ** Operations +---------------------------------------- + +-- | Take the head of a non-empty vector +head :: Pully vec a => vec -> a +head = (!0) + +tail :: Pully vec a => vec -> Pull a +tail = drop 1 + +take :: Pully vec a => Data Length -> vec -> Pull a +take l vec = Pull (min (length vec) l) (vec!) + +drop :: Pully vec a => Data Length -> vec -> Pull a +drop l vec = Pull (b2i (l<=m) * (m-l)) ((vec!) . (+l)) + where + m = length vec + +tails :: Pully vec a => vec -> Pull (Pull a) +tails vec = Pull (length vec + 1) (`drop` vec) + +inits :: Pully vec a => vec -> Pull (Pull a) +inits vec = Pull (length vec + 1) (`take` vec) + +inits1 :: Pully vec a => vec -> Pull (Pull a) +inits1 = tail . inits + +replicate :: Data Length -> a -> Pull a +replicate l = Pull l . const + +map :: Pully vec a => (a -> b) -> vec -> Pull b +map f vec = Pull (length vec) (f . (vec!)) + +zip :: (Pully vec1 a, Pully vec2 b) => vec1 -> vec2 -> Pull (a,b) +zip a b = Pull (length a `min` length b) (\i -> (a!i, b!i)) + +-- | Back-permute a 'Pull' vector using an index mapping. The supplied mapping +-- must be a bijection when restricted to the domain of the vector. This +-- property is not checked, so use with care. +backPermute :: Pully vec a => + (Data Length -> Data Index -> Data Index) -> (vec -> Pull a) +backPermute perm vec = Pull len ((vec!) . perm len) + where + len = length vec + +reverse :: Pully vec a => vec -> Pull a +reverse = backPermute $ \len i -> len-i-1 + +(...) :: Data Index -> Data Index -> Pull (Data Index) +l ... h = Pull (b2i (l + (a -> b -> c) -> vec1 -> vec2 -> Pull c +zipWith f a b = fmap (uncurry f) $ zip a b + +-- | Left fold of a vector +fold :: (Syntax a, Pully vec a) => (a -> a -> a) -> a -> vec -> a +fold f init vec = forLoop (length vec) init $ \i st -> f (vec!i) st + +-- | Left fold of a non-empty vector +fold1 :: (Syntax a, Pully vec a) => (a -> a -> a) -> vec -> a +fold1 f vec = forLoop (length vec) (vec!0) $ \i st -> f (vec!(i+1)) st + +sum :: (Pully vec a, Syntax a, Num a) => vec -> a +sum = fold (+) 0 + +-- | Scalar product +scProd :: (Num a, Syntax a, Pully vec1 a, Pully vec2 a) => vec1 -> vec2 -> a +scProd a b = sum (zipWith (*) a b) + + + +-------------------------------------------------------------------------------- +-- * 2-dimensional pull vectors +-------------------------------------------------------------------------------- + +-- | 2-dimensional pull vector: a vector representation that supports random +-- access and fusion of operations +data Pull2 a where + Pull2 + :: Data Length -- Number of rows + -> Data Length -- Number of columns + -> (Data Index -> Data Index -> a) -- (row,col) -> element + -> Pull2 a + +-- | 'Pull2' vector specialized to 'Data' elements +type DPull2 a = Pull2 (Data a) + +instance Functor Pull2 + where + fmap f (Pull2 r c ixf) = Pull2 r c (\i j -> f $ ixf i j) + +-- | Indexing the rows +instance Indexed (Pull2 a) + where + type IndexedElem (Pull2 a) = Pull a + Pull2 r c ixf ! i = Pull c (ixf i') + where + i' = guardValLabel + InternalAssertion + (i < r) + "indexing outside of Pull2 vector" + i + +-- | 'length' gives number of rows +instance Finite (Pull2 a) where length = numRows + +instance Finite2 (Pull2 a) + where + extent2 (Pull2 r c _) = (r,c) + +-- | Take a slice of the rows +instance Slicable (Pull2 a) + where + slice from n vec + = hideRowsPull (numCols vec) + $ take n + $ drop from + $ exposeRows + $ vec + +instance + ( Syntax a + , MarshalHaskell (Internal a) + , MarshalFeld a + ) => + MarshalFeld (Pull2 a) + where + type HaskellRep (Pull2 a) = HaskellRep (Manifest2 a) + fwrite hdl = fwrite hdl . toPush2 + fread hdl = (toPull2 :: Manifest2 a -> _) <$> fread hdl + +-- | Vectors that can be converted to 'Pull2' +class Pully2 vec a | vec -> a + where + -- | Convert a vector to 'Pull2' + toPull2 :: vec -> Pull2 a + +-- | Convert to a 'Pull2' with a single row +instance Syntax a => Pully2 (Manifest a) a + where + toPull2 = toPull2 . toPull + +instance (Indexed vec, Slicable vec, IndexedElem vec ~ a, Syntax a) => + Pully2 (Nest vec) a + where + toPull2 arr = Pull2 r c $ \i j -> arr!i!j + where + (r,c) = extent2 arr + +-- | Convert to a 'Pull2' with a single row +instance Pully2 (Pull a) a + where + toPull2 (Pull l ixf) = Pull2 1 l $ \_ j -> ixf j + +instance Pully2 (Pull2 a) a where toPull2 = id + + + +---------------------------------------- +-- ** Operations +---------------------------------------- + +-- | Transposed version of 'toPull'. Can be used to e.g. turn a 'Pull' into a +-- column of a matrix +toPull2' :: Pully2 vec a => vec -> Pull2 a +toPull2' = transpose . toPull2 + +-- | Turn a vector of rows into a 2-dimensional vector. All inner vectors are +-- assumed to have the given length, and this assumption is not checked by +-- assertions. If types permit, it is preferable to use 'hideRows', which does +-- check the lengths. +hideRowsPull :: (Pully vec1 vec2, Pully vec2 a) + => Data Length -- ^ Length of inner vectors + -> vec1 + -> Pull2 a +hideRowsPull c vec = Pull2 (length vec) c $ \i j -> vec!i!j + +-- | Expose the rows in a 'Pull2' by turning it into a vector of rows +exposeRows :: Pully2 vec a => vec -> Pull (Pull a) +exposeRows vec = Pull (numRows v) $ \i -> Pull (numCols v) $ \j -> v!i!j + where + v = toPull2 vec + +-- | Transpose of a matrix +transpose :: Pully2 vec a => vec -> Pull2 a +transpose vec = Pull2 (numCols v) (numRows v) $ \i j -> v!j!i + where + v = toPull2 vec + +toRowVec :: Pully vec a => vec -> Pull2 a +toRowVec vec = hideRowsPull (length vec) $ replicate 1 vec + +fromRowVec :: Pully2 vec a => vec -> Pull a +fromRowVec = head . exposeRows + +toColVec :: Pully vec a => vec -> Pull2 a +toColVec = transpose . toRowVec + +fromColVec :: Pully2 vec a => vec -> Pull a +fromColVec = fromRowVec . transpose + +-- | Matrix multiplication +matMul :: (Pully2 vec1 a, Pully2 vec2 a, Num a, Syntax a) => + vec1 -> vec2 -> Pull2 a +matMul veca vecb = Pull2 (numRows va) (numCols vb) $ \i j -> + scProd (va!i) (transpose vb ! j) + where + va = toPull2 veca + vb = toPull2 vecb + + + +-------------------------------------------------------------------------------- +-- * 1-dimensional push vectors +-------------------------------------------------------------------------------- + +-- | 1-dimensional push vector: a vector representation that supports nested +-- write patterns (e.g. resulting from concatenation) and fusion of operations +-- +-- If it is the case that @`dumpPush` v (\\_ _ -> `return` ())@ has the same +-- behavior as @`return` ()@, i.e., the vector does not have any embedded side +-- effects, we can regard 'Push' as a pure data structure with the denotation of +-- a finite list. +-- +-- However, 'Push' is commonly used to assemble data after splitting it up and +-- performing some operations on the parts. We want to be able to use 'Push' +-- even if the operation involved has side effects. The function 'sequens' can +-- be used to embed effects into a 'Push' vector. +-- +-- 'Push' vectors with embedded effects can often be considered to be denoted by +-- @M [a]@, where @M@ is some suitable monad. That is, the vector performs some +-- effects and produces a finite list of values as a result. This denotation is +-- enough to explain e.g. why +-- +-- @ +-- `return` (v `++` v) +-- @ +-- +-- is different from +-- +-- @ +-- do v' <- `manifestFresh` v +-- `return` (v' `++` v') +-- @ +-- +-- (The former duplicates the embedded effects while the latter only performs +-- the effects once.) +-- +-- However, this denotation is not enough to model 'dumpPush', which allows a +-- write method to be interleaved with the embedded effects. Even a function +-- such as 'manifest' can to some extent be used observe the order of effects +-- (if the array argument to 'manifest' is also updated by the internal +-- effects). +-- +-- Conclusion: +-- +-- * You can normally think of @`Push` a@ as denoting @M [a]@ (finite list) +-- +-- * Make sure to pass a free array as argument to 'manifest' +-- +-- * Avoid using 'dumpPush' unless you know that it's safe +data Push m a + where + Push + :: Data Length + -> ((Data Index -> a -> m ()) -> m ()) + -> Push m a + +-- | 'Push' vector specialized to 'Data' elements +type DPush m a = Push m (Data a) + +instance Functor (Push m) + where + fmap f (Push len dump) = Push len $ \write -> + dump $ \i -> write i . f + +-- | This instance behaves like the list instance: +-- +-- > pure x = [x] +-- > fs <*> xs = [f x | f <- fs, x <- xs] +instance Applicative (Push m) + where + pure a = Push 1 $ \write -> write 0 a + vec1 <*> vec2 = Push (len1*len2) $ \write -> do + dumpPush vec2 $ \i2 a -> + dumpPush vec1 $ \i1 f -> + write (i1*len2 + i2) (f a) + where + (len1,len2) = (length vec1, length vec2) + +-- No instance `Monad Push`, because it's not possible to determine the length +-- of the result of `>>=`. + +instance Finite (Push m a) + where + length (Push len _) = len + +-- | Treated as a row vector +instance Finite2 (Push m a) where extent2 v = (1, length v) + +instance + ( Syntax a + , MarshalHaskell (Internal a) + , MarshalFeld a + , m ~ Run + ) => + MarshalFeld (Push m a) + where + type HaskellRep (Push m a) = HaskellRep (Manifest a) + fwrite hdl = fwrite hdl <=< manifestFresh + fread hdl = toPush . (id :: Manifest _ -> _) <$> fread hdl + +-- | Vectors that can be converted to 'Push' +class Pushy m vec a | vec -> a + where + -- | Convert a vector to 'Push' + toPush :: vec -> Push m a + +-- | A version of 'toPush' that constrains the @m@ argument of 'Push' to that of +-- the monad in which the result is returned. This can be a convenient way to +-- avoid unresolved overloading. +toPushM :: (Pushy m vec a, Monad m) => vec -> m (Push m a) +toPushM = return . toPush + +instance (Syntax a, MonadComp m) => Pushy m (Manifest a) a where toPush = toPush . toPull +instance (m1 ~ m2) => Pushy m1 (Push m2 a) a where toPush = id + +instance MonadComp m => Pushy m (Pull a) a + where + toPush vec = Push len $ \write -> + for (0,1,Excl len) $ \i -> + write i (vec!i) + where + len = length vec + +-- | Dump the contents of a 'Push' vector +dumpPush + :: Push m a -- ^ Vector to dump + -> (Data Index -> a -> m ()) -- ^ Function that writes one element + -> m () +dumpPush (Push _ dump) = dump + + + +---------------------------------------- +-- ** Operations +---------------------------------------- + +-- | Create a 'Push' vector from a list of elements +listPush :: Monad m => [a] -> Push m a +listPush as = Push (value $ genericLength as) $ \write -> + sequence_ [write (value i) a | (i,a) <- Prelude.zip [0..] as] + +-- | Append two vectors to make a 'Push' vector +(++) :: (Pushy m vec1 a, Pushy m vec2 a, Monad m) => vec1 -> vec2 -> Push m a +vec1 ++ vec2 = Push (len1 + length v2) $ \write -> + dumpPush v1 write >> dumpPush v2 (write . (+len1)) + where + v1 = toPush vec1 + v2 = toPush vec2 + len1 = length v1 + +-- Concatenate nested vectors to a 'Push' vector +concat :: (Pushy m vec1 vec2, Pushy m vec2 a, MonadComp m) + => Data Length -- ^ Length of inner vectors + -> vec1 + -> Push m a +concat c vec = Push (len*c) $ \write -> + dumpPush v $ \i row -> + dumpPush row $ \j a -> do + assertLabel + InternalAssertion + (length row == c) + "concat: inner length differs" + write (i * length row + j) a + where + v = fmap toPush $ toPush vec + len = length v + +-- Flatten a 2-dimensional vector to a 'Push' vector +flatten :: Pushy2 m vec a => vec -> Push m a +flatten vec = Push (r*c) $ \write -> + dumpPush2 v $ \i j -> write (i*c + j) + where + v = toPush2 vec + (r,c) = extent2 v + +-- | Embed the effects in the elements into the internal effects of a 'Push' +-- vector +-- +-- __WARNING:__ This function should be used with care, since it allows hiding +-- effects inside a vector. These effects may be (seemingly) randomly +-- interleaved with other effects when the vector is used. +-- +-- The name 'sequens' has to do with the similarity to the standard function +-- 'sequence'. +sequens :: (Pushy m vec (m a), Monad m) => vec -> Push m a +sequens vec = Push (length v) $ \write -> + dumpPush v $ \i m -> + m >>= write i + where + v = toPush vec + +-- | Forward-permute a 'Push' vector using an index mapping. The supplied +-- mapping must be a bijection when restricted to the domain of the vector. This +-- property is not checked, so use with care. +forwardPermute :: Pushy m vec a => + (Data Length -> Data Index -> Data Index) -> vec -> Push m a +forwardPermute p vec = Push len $ \write -> + dumpPush v $ \i a -> + write (p len i) a + where + v = toPush vec + len = length v + + + +-------------------------------------------------------------------------------- +-- * 2-dimensional push vectors +-------------------------------------------------------------------------------- + +-- | 2-dimensional push vector: a vector representation that supports nested +-- write patterns (e.g. resulting from concatenation) and fusion of operations +-- +-- See the comments to 'Push' regarding the semantics of push vectors with +-- interleaved effects. +data Push2 m a + where + Push2 + :: Data Length -- Number of rows + -> Data Length -- Number of columns + -> ((Data Index -> Data Index -> a -> m ()) -> m ()) + -> Push2 m a + +-- | 'Push2' vector specialized to 'Data' elements +type DPush2 m a = Push2 m (Data a) + +instance Functor (Push2 m) + where + fmap f (Push2 r c dump) = Push2 r c $ \write -> + dump $ \i j -> write i j . f + +-- | 'length' gives number of rows +instance Finite (Push2 m a) + where + length (Push2 r _ _) = r + +instance Finite2 (Push2 m a) + where + extent2 (Push2 r c _) = (r,c) + +instance + ( Syntax a + , MarshalHaskell (Internal a) + , MarshalFeld a + , m ~ Run + ) => + MarshalFeld (Push2 m a) + where + type HaskellRep (Push2 m a) = HaskellRep (Manifest2 a) + fwrite hdl = fwrite hdl <=< manifestFresh2 + fread hdl = toPush2 . (id :: Manifest2 _ -> _) <$> fread hdl + +-- | Vectors that can be converted to 'Push2' +class Pushy2 m vec a | vec -> a + where + -- | Convert a vector to 'Push2' + toPush2 :: vec -> Push2 m a + +-- | A version of 'toPush2' that constrains the @m@ argument of 'Push2' to that +-- of the monad in which the result is returned. This can be a convenient way to +-- avoid unresolved overloading. +toPushM2 :: (Pushy2 m vec a, Monad m) => vec -> m (Push2 m a) +toPushM2 = return . toPush2 + +-- | Convert to a 'Push2' with a single row +instance (Syntax a, MonadComp m) => Pushy2 m (Manifest a) a where toPush2 = toPush2 . toPull +instance (Syntax a, MonadComp m) => Pushy2 m (Manifest2 a) a where toPush2 = toPush2 . toPull2 +instance MonadComp m => Pushy2 m (Pull a) a where toPush2 = toPush2 . toPull2 +instance (m1 ~ m2) => Pushy2 m1 (Push2 m2 a) a where toPush2 = id + +instance MonadComp m => Pushy2 m (Pull2 a) a + where + toPush2 vec = Push2 r c $ \write -> + for (0,1,Excl r) $ \i -> + for (0,1,Excl c) $ \j -> + write i j (vec!i!j) + where + (r,c) = extent2 vec + +-- | Dump the contents of a 'Push2' vector +dumpPush2 + :: Push2 m a -- ^ Vector to dump + -> (Data Index -> Data Index -> a -> m ()) -- ^ Function that writes one element + -> m () +dumpPush2 (Push2 _ _ dump) = dump + + + +---------------------------------------- +-- ** Operations +---------------------------------------- + +-- | Turn a vector of rows into a 2-dimensional vector. All inner vectors are +-- assumed to have the given length. +hideRows :: (Pushy m vec1 vec2, Pushy m vec2 a, MonadComp m) + => Data Length -- ^ Length of inner vectors + -> vec1 + -> Push2 m a +hideRows c vec = Push2 (length v) c $ \write -> + dumpPush v $ \i row -> + dumpPush row $ \j a -> do + assertLabel + InternalAssertion + (length row == c) + "hideRows: inner length differs" + write i j a + where + v = fmap toPush $ toPush vec + +-- | Convert a 2-dimensional vector with effectful elements to 'Push2' +-- +-- __WARNING:__ This function should be used with care, since is allows hiding +-- effects inside a vector. These effects may be (seemingly) randomly +-- interleaved with other effects when the vector is used. +-- +-- The name 'sequens2' has to do with the similarity to the standard function +-- 'sequence'. +sequens2 :: (Pushy2 m vec (m a), Monad m) => vec -> Push2 m a +sequens2 vec = Push2 (numRows v) (numCols v) $ \write -> + dumpPush2 v $ \i j m -> + m >>= write i j + where + v = toPush2 vec + +-- | Forward-permute a 'Push' vector using an index mapping. The supplied +-- mapping must be a bijection when restricted to the domain of the vector. This +-- property is not checked, so use with care. +forwardPermute2 :: Pushy2 m vec a + => (Data Length -> Data Length -> (Data Index, Data Index) -> (Data Index, Data Index)) + -> vec -> Push2 m a +forwardPermute2 p vec = Push2 r c $ \write -> + dumpPush2 v $ \i j a -> do + let (i',j') = p r c (i,j) + write i' j' a + where + v = toPush2 vec + (r,c) = extent2 v + +transposePush :: Pushy2 m vec a => vec -> Push2 m a +transposePush vec = Push2 c r $ \write -> + dumpPush2 v $ \i j a -> + write j i a + where + v = toPush2 vec + (r,c) = extent2 v + + + +-------------------------------------------------------------------------------- +-- * Writing to memory +-------------------------------------------------------------------------------- + +-- It would be possible to make the `vec` parameter to `ViewManifest` and +-- `Manifestable` have kind `* -> *` and avoid the `a` parameter. But the +-- current design was chosen for consistency with `ViewManifest2` and +-- `Manifestable2`. + +class ViewManifest vec a | vec -> a + where + -- | Try to cast a vector to 'Manifest' directly + viewManifest :: vec -> Maybe (Manifest a) + viewManifest _ = Nothing + +instance ViewManifest (Manifest a) a where viewManifest = Just +instance ViewManifest (Pull a) a +instance ViewManifest (Push m a) a + +class ViewManifest vec a => Manifestable m vec a | vec -> a + where + -- | Write the contents of a vector to memory and get it back as a + -- 'Manifest' vector. The supplied array may or may not be used for storage. + manifest :: Syntax a + => Arr a -- ^ Where to store the vector + -> vec -- ^ Vector to store + -> m (Manifest a) + + default manifest :: (Pushy m vec a, Finite vec, Syntax a, MonadComp m) => + Arr a -> vec -> m (Manifest a) + manifest loc vec = do + dumpPush v $ \i a -> setArr loc i a + unsafeFreezeSlice (length vec) loc + where + v = toPush vec + + -- | A version of 'manifest' that allocates a fresh array for the result + manifestFresh :: Syntax a => vec -> m (Manifest a) + + default manifestFresh :: (Pushy m vec a, Syntax a, MonadComp m) => + vec -> m (Manifest a) + manifestFresh vec = do + v <- toPushM vec + loc <- newArr $ length v + manifest loc v + + -- | A version of 'manifest' that only stores the vector to the given array + -- ('manifest' is not guaranteed to use the array) + manifestStore :: Syntax a => Arr a -> vec -> m () + + default manifestStore :: (Pushy m vec a, Syntax a, MonadComp m) => + Arr a -> vec -> m () + manifestStore loc = void . manifest loc . toPush + +-- | 'manifest' and 'manifestFresh' are no-ops. 'manifestStore' does a proper +-- 'arrCopy'. +instance MonadComp m => Manifestable m (Manifest a) a + where + manifest _ = return + manifestFresh = return + manifestStore loc = copyArr loc <=< unsafeThawArr + +instance MonadComp m => Manifestable m (Pull a) a +instance (MonadComp m1, m1 ~ m2) => Manifestable m1 (Push m2 a) a + +class ViewManifest2 vec a | vec -> a + where + -- | Try to cast a vector to 'Manifest2' directly + viewManifest2 :: vec -> Maybe (Manifest2 a) + viewManifest2 _ = Nothing + +instance ViewManifest2 (Manifest2 a) a where viewManifest2 = Just +instance ViewManifest2 (Pull2 a) a +instance ViewManifest2 (Push2 m a) a + +class ViewManifest2 vec a => Manifestable2 m vec a | vec -> a + where + -- | Write the contents of a vector to memory and get it back as a + -- 'Manifest2' vector + manifest2 :: Syntax a + => Arr a -- ^ Where to store the result + -> vec -- ^ Vector to store + -> m (Manifest2 a) + + default manifest2 :: (Pushy2 m vec a, Syntax a, MonadComp m) => + Arr a -> vec -> m (Manifest2 a) + manifest2 loc vec = do + dumpPush2 v $ \i j a -> setArr loc (i*c + j) a + nest r c <$> unsafeFreezeSlice (r*c) loc + where + v = toPush2 vec + (r,c) = extent2 v + + -- | A version of 'manifest2' that allocates a fresh array for the result + manifestFresh2 :: Syntax a => vec -> m (Manifest2 a) + + default manifestFresh2 :: (Pushy2 m vec a, Syntax a, MonadComp m) => + vec -> m (Manifest2 a) + manifestFresh2 vec = do + v <- toPushM2 vec + loc <- newArr (numRows v * numCols v) + manifest2 loc vec + + -- | A version of 'manifest2' that only stores the vector to the given array + -- ('manifest2' is not guaranteed to use the array) + manifestStore2 :: Syntax a => Arr a -> vec -> m () + + default manifestStore2 :: (Pushy2 m vec a, Syntax a, MonadComp m) => + Arr a -> vec -> m () + manifestStore2 loc = void . manifest2 loc . toPush2 + +-- | 'manifest2' and 'manifestFresh2' are no-ops. 'manifestStore2' does a proper +-- 'arrCopy'. +instance MonadComp m => Manifestable2 m (Manifest2 a) a + where + manifest2 _ = return + manifestFresh2 = return + manifestStore2 loc = copyArr loc <=< unsafeThawArr . unnest + +instance MonadComp m => Manifestable2 m (Pull2 a) a +instance (MonadComp m1, m1 ~ m2) => Manifestable2 m1 (Push2 m2 a) a + diff --git a/src/Feldspar/Frontend.hs b/src/Feldspar/Frontend.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Frontend.hs @@ -0,0 +1,836 @@ +module Feldspar.Frontend where + + + +import Prelude (Integral, Ord, RealFloat, RealFrac) +import qualified Prelude as P +import Prelude.EDSL + +import Control.Monad.Identity +import Data.Bits (Bits, FiniteBits) +import qualified Data.Bits as Bits +import Data.Complex (Complex) +import Data.Int +import Data.List (genericLength) + +import Language.Syntactic (Internal) +import Language.Syntactic.Functional +import qualified Language.Syntactic as Syntactic + +import qualified Control.Monad.Operational.Higher as Oper +import Language.Embedded.Imperative (IxRange) +import qualified Language.Embedded.Imperative as Imp + +import qualified Data.Inhabited as Inhabited +import Data.TypedStruct +import Feldspar.Primitive.Representation +import Feldspar.Representation +import Feldspar.Sugar () + + + +-------------------------------------------------------------------------------- +-- * Pure expressions +-------------------------------------------------------------------------------- + +---------------------------------------- +-- ** General constructs +---------------------------------------- + +-- | Force evaluation of a value and share the result. Note that due to common +-- sub-expression elimination, this function is rarely needed in practice. +share :: (Syntax a, Syntax b) + => a -- ^ Value to share + -> (a -> b) -- ^ Body in which to share the value + -> b +share = shareTag "" + -- Explicit sharing can be useful e.g. when the value to share contains a + -- function or when the code motion algorithm for some reason doesn't work + -- find opportunities for sharing. + +-- | Explicit tagged sharing +shareTag :: (Syntax a, Syntax b) + => String -- ^ A tag (that may be empty). May be used by a back end to + -- generate a sensible variable name. + -> a -- ^ Value to share + -> (a -> b) -- ^ Body in which to share the value + -> b +shareTag tag = sugarSymFeld (Let tag) + +-- | For loop +forLoop :: Syntax st => Data Length -> st -> (Data Index -> st -> st) -> st +forLoop = sugarSymFeld ForLoop + +-- | Conditional expression +cond :: Syntax a + => Data Bool -- ^ Condition + -> a -- ^ True branch + -> a -- ^ False branch + -> a +cond = sugarSymFeld Cond + +-- | Condition operator; use as follows: +-- +-- @ +-- cond1 `?` a $ +-- cond2 `?` b $ +-- cond3 `?` c $ +-- default +-- @ +(?) :: Syntax a + => Data Bool -- ^ Condition + -> a -- ^ True branch + -> a -- ^ False branch + -> a +(?) = cond + +infixl 1 ? + +-- | Multi-way conditional expression +-- +-- The first association @(a,b)@ in the list of cases for which @a@ is equal to +-- the scrutinee is selected, and the associated @b@ is returned as the result. +-- If no case matches, the default value is returned. +switch :: (Syntax a, Syntax b, PrimType (Internal a)) + => b -- ^ Default result + -> [(a,b)] -- ^ Cases (match, result) + -> a -- ^ Scrutinee + -> b -- ^ Result +switch def [] _ = def +switch def cs s = P.foldr + (\(c,a) b -> desugar c == desugar s ? a $ b) + def + cs + + + +---------------------------------------- +-- ** Literals +---------------------------------------- + +-- | Literal +value :: Syntax a => Internal a -> a +value = sugarSymFeld . Lit + +false :: Data Bool +false = value False + +true :: Data Bool +true = value True + +instance Syntactic.Syntactic () + where + type Domain () = FeldDomain + type Internal () = Int32 + desugar () = unData 0 + sugar _ = () + +-- | Example value +-- +-- 'example' can be used similarly to 'undefined' in normal Haskell, i.e. to +-- create an expression whose value is irrelevant. +-- +-- Note that it is generally not possible to use 'undefined' in Feldspar +-- expressions, as this will crash the compiler. +example :: Syntax a => a +example = value Inhabited.example + + + +---------------------------------------- +-- ** Primitive functions +---------------------------------------- + +instance (Bounded a, Type a) => Bounded (Data a) + where + minBound = value minBound + maxBound = value maxBound + +instance (Num a, PrimType a) => Num (Data a) + where + fromInteger = value . fromInteger + (+) = sugarSymFeld Add + (-) = sugarSymFeld Sub + (*) = sugarSymFeld Mul + negate = sugarSymFeld Neg + abs = sugarSymFeld Abs + signum = sugarSymFeld Sign + +instance (Fractional a, PrimType a) => Fractional (Data a) + where + fromRational = value . fromRational + (/) = sugarSymFeld FDiv + +instance (Floating a, PrimType a) => Floating (Data a) + where + pi = sugarSymFeld Pi + exp = sugarSymFeld Exp + log = sugarSymFeld Log + sqrt = sugarSymFeld Sqrt + (**) = sugarSymFeld Pow + sin = sugarSymFeld Sin + cos = sugarSymFeld Cos + tan = sugarSymFeld Tan + asin = sugarSymFeld Asin + acos = sugarSymFeld Acos + atan = sugarSymFeld Atan + sinh = sugarSymFeld Sinh + cosh = sugarSymFeld Cosh + tanh = sugarSymFeld Tanh + asinh = sugarSymFeld Asinh + acosh = sugarSymFeld Acosh + atanh = sugarSymFeld Atanh + +-- | Alias for 'pi' +π :: (Floating a, PrimType a) => Data a +π = pi + +-- | Integer division truncated toward zero +quot :: (Integral a, PrimType a) => Data a -> Data a -> Data a +quot = sugarSymFeld Quot + +-- | Integer remainder satisfying +-- +-- > (x `quot` y)*y + (x `rem` y) == x +rem :: (Integral a, PrimType a) => Data a -> Data a -> Data a +rem = sugarSymFeld Rem + +-- | Simultaneous @quot@ and @rem@ +quotRem :: (Integral a, PrimType a) => Data a -> Data a -> (Data a, Data a) +quotRem a b = (q,r) + where + q = quot a b + r = a - b * q + +-- | Integer division truncated toward negative infinity +div :: (Integral a, PrimType a) => Data a -> Data a -> Data a +div = sugarSymFeld Div + +-- | Integer modulus, satisfying +-- +-- > (x `div` y)*y + (x `mod` y) == x +mod :: (Integral a, PrimType a) => Data a -> Data a -> Data a +mod = sugarSymFeld Mod + +-- | Integer division assuming `unsafeBalancedDiv x y * y == x` (i.e. no +-- remainder) +-- +-- The advantage of using 'unsafeBalancedDiv' over 'quot' or 'div' is that the +-- above assumption can be used for simplifying the expression. +unsafeBalancedDiv :: (Integral a, PrimType a) => Data a -> Data a -> Data a +unsafeBalancedDiv a b = guardValLabel + InternalAssertion + (rem a b == 0) + "unsafeBalancedDiv: division not balanced" + (sugarSymFeld DivBalanced a b) + -- Note: We can't check that `result * b == a`, because `result * b` gets + -- simplified to `a`. + +-- | Construct a complex number +complex :: (Num a, PrimType a, PrimType (Complex a)) + => Data a -- ^ Real part + -> Data a -- ^ Imaginary part + -> Data (Complex a) +complex = sugarSymFeld Complex + +-- | Construct a complex number +polar :: (Floating a, PrimType a, PrimType (Complex a)) + => Data a -- ^ Magnitude + -> Data a -- ^ Phase + -> Data (Complex a) +polar = sugarSymFeld Polar + +-- | Extract the real part of a complex number +realPart :: (PrimType a, PrimType (Complex a)) => Data (Complex a) -> Data a +realPart = sugarSymFeld Real + +-- | Extract the imaginary part of a complex number +imagPart :: (PrimType a, PrimType (Complex a)) => Data (Complex a) -> Data a +imagPart = sugarSymFeld Imag + +-- | Extract the magnitude of a complex number's polar form +magnitude :: (RealFloat a, PrimType a, PrimType (Complex a)) => + Data (Complex a) -> Data a +magnitude = sugarSymFeld Magnitude + +-- | Extract the phase of a complex number's polar form +phase :: (RealFloat a, PrimType a, PrimType (Complex a)) => + Data (Complex a) -> Data a +phase = sugarSymFeld Phase + +-- | Complex conjugate +conjugate :: (RealFloat a, PrimType (Complex a)) => + Data (Complex a) -> Data (Complex a) +conjugate = sugarSymFeld Conjugate + -- `RealFloat` could be replaced by `Num` here, but it seems more consistent + -- to use `RealFloat` for all functions. + +-- | Integral type casting +i2n :: (Integral i, Num n, PrimType i, PrimType n) => Data i -> Data n +i2n = sugarSymFeld I2N + +-- | Cast integer to 'Bool' +i2b :: (Integral a, PrimType a) => Data a -> Data Bool +i2b = sugarSymFeld I2B + +-- | Cast 'Bool' to integer +b2i :: (Integral a, PrimType a) => Data Bool -> Data a +b2i = sugarSymFeld B2I + +-- | Round a floating-point number to an integer +round :: (RealFrac a, Num b, PrimType a, PrimType b) => Data a -> Data b +round = sugarSymFeld Round + +-- | Boolean negation +not :: Data Bool -> Data Bool +not = sugarSymFeld Not + +-- | Boolean conjunction +(&&) :: Data Bool -> Data Bool -> Data Bool +(&&) = sugarSymFeld And + +infixr 3 && + +-- | Boolean disjunction +(||) :: Data Bool -> Data Bool -> Data Bool +(||) = sugarSymFeld Or + +infixr 2 || + + +-- | Equality +(==) :: PrimType a => Data a -> Data a -> Data Bool +(==) = sugarSymFeld Eq + +-- | Inequality +(/=) :: PrimType a => Data a -> Data a -> Data Bool +a /= b = not (a==b) + +-- | Less than +(<) :: (Ord a, PrimType a) => Data a -> Data a -> Data Bool +(<) = sugarSymFeld Lt + +-- | Greater than +(>) :: (Ord a, PrimType a) => Data a -> Data a -> Data Bool +(>) = sugarSymFeld Gt + +-- | Less than or equal +(<=) :: (Ord a, PrimType a) => Data a -> Data a -> Data Bool +(<=) = sugarSymFeld Le + +-- | Greater than or equal +(>=) :: (Ord a, PrimType a) => Data a -> Data a -> Data Bool +(>=) = sugarSymFeld Ge + +infix 4 ==, /=, <, >, <=, >= + +-- | Return the smallest of two values +min :: (Ord a, PrimType a) => Data a -> Data a -> Data a +min a b = a<=b ? a $ b + -- There's no standard definition of min/max in C: + -- + -- + -- There is `fmin`/`fminf` for floating-point numbers, but these are + -- implemented essentially as above (except that they handle `NaN` + -- specifically: + -- + +-- | Return the greatest of two values +max :: (Ord a, PrimType a) => Data a -> Data a -> Data a +max a b = a>=b ? a $ b + + + +---------------------------------------- +-- ** Bit manipulation +---------------------------------------- + +-- | Bit-wise \"and\" +(.&.) :: (Bits a, PrimType a) => Data a -> Data a -> Data a +(.&.) = sugarSymFeld BitAnd + +-- | Bit-wise \"or\" +(.|.) :: (Bits a, PrimType a) => Data a -> Data a -> Data a +(.|.) = sugarSymFeld BitOr + +-- | Bit-wise \"xor\" +xor :: (Bits a, PrimType a) => Data a -> Data a -> Data a +xor = sugarSymFeld BitXor + +-- | Bit-wise \"xor\" +(⊕) :: (Bits a, PrimType a) => Data a -> Data a -> Data a +(⊕) = xor + +-- | Bit-wise complement +complement :: (Bits a, PrimType a) => Data a -> Data a +complement = sugarSymFeld BitCompl + +-- | Left shift +shiftL :: (Bits a, PrimType a) + => Data a -- ^ Value to shift + -> Data Int32 -- ^ Shift amount (negative value gives right shift) + -> Data a +shiftL = sugarSymFeld ShiftL + +-- | Right shift +shiftR :: (Bits a, PrimType a) + => Data a -- ^ Value to shift + -> Data Int32 -- ^ Shift amount (negative value gives left shift) + -> Data a +shiftR = sugarSymFeld ShiftR + +-- | Left shift +(.<<.) :: (Bits a, PrimType a) + => Data a -- ^ Value to shift + -> Data Int32 -- ^ Shift amount (negative value gives right shift) + -> Data a +(.<<.) = shiftL + +-- | Right shift +(.>>.) :: (Bits a, PrimType a) + => Data a -- ^ Value to shift + -> Data Int32 -- ^ Shift amount (negative value gives left shift) + -> Data a +(.>>.) = shiftR + +infixl 8 `shiftL`, `shiftR`, .<<., .>>. +infixl 7 .&. +infixl 6 `xor` +infixl 5 .|. + +bitSize :: forall a . FiniteBits a => Data a -> Length +bitSize _ = P.fromIntegral $ Bits.finiteBitSize (a :: a) + where + a = P.error "finiteBitSize evaluates its argument" + +-- | Set all bits to one +allOnes :: (Bits a, Num a, PrimType a) => Data a +allOnes = complement 0 + +-- | Set the @n@ lowest bits to one +oneBits :: (Bits a, Num a, PrimType a) => Data Int32 -> Data a +oneBits n = complement (allOnes .<<. n) + +-- | Extract the @k@ lowest bits +lsbs :: (Bits a, Num a, PrimType a) => Data Int32 -> Data a -> Data a +lsbs k i = i .&. oneBits k + +-- | Integer logarithm in base 2. Returns \(\lfloor log_2(x) \rfloor\). +-- Assumes \(x>0\). +ilog2 :: (FiniteBits a, Integral a, PrimType a) => Data a -> Data a +ilog2 a = guardValLabel InternalAssertion (a >= 1) "ilog2: argument < 1" $ + snd $ P.foldr (\ffi vr -> share vr (step ffi)) (a,0) ffis + where + step (ff,i) (v,r) = + share (b2i (v > fromInteger ff) .<<. value i) $ \shift -> + (v .>>. i2n shift, r .|. shift) + + -- [(0x1, 0), (0x3, 1), (0xF, 2), (0xFF, 3), (0xFFFF, 4), ...] + ffis + = (`P.zip` [0..]) + $ P.takeWhile (P.<= (2 P.^ (bitSize a `P.div` 2) - 1 :: Integer)) + $ P.map ((subtract 1) . (2 P.^) . (2 P.^)) + $ [(0::Integer)..] + -- Based on this algorithm: + -- + + + +---------------------------------------- +-- ** Arrays +---------------------------------------- + +-- | Index into an array +arrIx :: Syntax a => IArr a -> Data Index -> a +arrIx arr i = resugar $ mapStruct ix $ unIArr arr + where + ix :: forall b . PrimType' b => Imp.IArr Index b -> Data b + ix arr' = sugarSymFeldPrim + (GuardVal InternalAssertion "arrIx: index out of bounds") + (i < length arr) + (sugarSymFeldPrim (ArrIx arr') (i + iarrOffset arr) :: Data b) + +class Indexed a + where + type IndexedElem a + + -- | Indexing operator. If @a@ is 'Finite', it is assumed that + -- @i < `length` a@ in any expression @a `!` i@. + (!) :: a -> Data Index -> IndexedElem a + +infixl 9 ! + +-- | Linear structures with a length. If the type is also 'Indexed', the length +-- is the successor of the maximal allowed index. +class Finite a + where + -- | The length of a finite structure + length :: a -> Data Length + +instance Finite (Arr a) where length = arrLength +instance Finite (IArr a) where length = iarrLength + +-- | Linear structures that can be sliced +class Slicable a + where + -- | Take a slice of a structure + slice + :: Data Index -- ^ Start index + -> Data Length -- ^ Slice length + -> a -- ^ Structure to slice + -> a + +instance Syntax a => Indexed (IArr a) + where + type IndexedElem (IArr a) = a + (!) = arrIx + +instance Slicable (Arr a) + where + slice from len (Arr o l arr) = Arr o' l' arr + where + o' = guardValLabel InternalAssertion (from<=l) "invalid Arr slice" (o+from) + l' = guardValLabel InternalAssertion (from+len<=l) "invalid Arr slice" len + +instance Slicable (IArr a) + where + slice from len (IArr o l arr) = IArr o' l' arr + where + o' = guardValLabel InternalAssertion (from<=l) "invalid IArr slice" (o+from) + l' = guardValLabel InternalAssertion (from+len<=l) "invalid IArr slice" len + + + +---------------------------------------- +-- ** Syntactic conversion +---------------------------------------- + +desugar :: Syntax a => a -> Data (Internal a) +desugar = Data . Syntactic.desugar + +sugar :: Syntax a => Data (Internal a) -> a +sugar = Syntactic.sugar . unData + +-- | Cast between two values that have the same syntactic representation +resugar :: (Syntax a, Syntax b, Internal a ~ Internal b) => a -> b +resugar = Syntactic.resugar + + + +---------------------------------------- +-- ** Assertions +---------------------------------------- + +-- | Guard a value by an assertion (with implicit label @`UserAssertion` ""@) +guardVal :: Syntax a + => Data Bool -- ^ Condition that is expected to be true + -> String -- ^ Error message + -> a -- ^ Value to attach the assertion to + -> a +guardVal = guardValLabel $ UserAssertion "" + +-- | Like 'guardVal' but with an explicit assertion label +guardValLabel :: Syntax a + => AssertionLabel -- ^ Assertion label + -> Data Bool -- ^ Condition that is expected to be true + -> String -- ^ Error message + -> a -- ^ Value to attach the assertion to + -> a +guardValLabel c cond msg = sugarSymFeld (GuardVal c msg) cond + + + +---------------------------------------- +-- ** Unsafe operations +---------------------------------------- + +-- | Turn a 'Comp' computation into a pure value. For this to be safe, the +-- computation should be free of side effects and independent of its +-- environment. +unsafePerform :: Syntax a => Comp a -> a +unsafePerform = sugarSymFeld . UnsafePerform . fmap desugar + + + +-------------------------------------------------------------------------------- +-- * Programs with computational effects +-------------------------------------------------------------------------------- + +-- | Monads that support computational effects: mutable data structures and +-- control flow +class Monad m => MonadComp m + where + -- | Lift a 'Comp' computation + liftComp :: Comp a -> m a + -- | Conditional statement + iff :: Data Bool -> m () -> m () -> m () + -- | For loop + for :: (Integral n, PrimType n) => + IxRange (Data n) -> (Data n -> m ()) -> m () + -- | While loop + while :: m (Data Bool) -> m () -> m () + +instance MonadComp Comp + where + liftComp = id + iff c t f = Comp $ Imp.iff c (unComp t) (unComp f) + for range body = Comp $ Imp.for range (unComp . body) + while cont body = Comp $ Imp.while (unComp cont) (unComp body) + + + +---------------------------------------- +-- ** References +---------------------------------------- + +-- | Create an uninitialized reference +newRef :: (Syntax a, MonadComp m) => m (Ref a) +newRef = newNamedRef "r" + +-- | Create an uninitialized named reference +-- +-- The provided base name may be appended with a unique identifier to avoid name +-- collisions. +newNamedRef :: (Syntax a, MonadComp m) + => String -- ^ Base name + -> m (Ref a) +newNamedRef base = liftComp $ fmap Ref $ + mapStructA (const $ Comp $ Imp.newNamedRef base) typeRep + +-- | Create an initialized named reference +initRef :: (Syntax a, MonadComp m) => a -> m (Ref a) +initRef = initNamedRef "r" + +-- | Create an initialized reference +-- +-- The provided base name may be appended with a unique identifier to avoid name +-- collisions. +initNamedRef :: (Syntax a, MonadComp m) + => String -- ^ Base name + -> a -- ^ Initial value + -> m (Ref a) +initNamedRef base = + liftComp . fmap Ref . mapStructA (Comp . Imp.initNamedRef base) . resugar + +-- | Get the contents of a reference. +getRef :: (Syntax a, MonadComp m) => Ref a -> m a +getRef = liftComp . fmap resugar . mapStructA (Comp . Imp.getRef) . unRef + +-- | Set the contents of a reference. +setRef :: (Syntax a, MonadComp m) => Ref a -> a -> m () +setRef r + = liftComp + . sequence_ + . zipListStruct (\r' a' -> Comp $ Imp.setRef r' a') (unRef r) + . resugar + +-- | Modify the contents of reference. +modifyRef :: (Syntax a, MonadComp m) => Ref a -> (a -> a) -> m () +modifyRef r f = setRef r . f =<< unsafeFreezeRef r + +-- | Freeze the contents of reference (only safe if the reference is not updated +-- as long as the resulting value is alive). +unsafeFreezeRef :: (Syntax a, MonadComp m) => Ref a -> m a +unsafeFreezeRef + = liftComp + . fmap resugar + . mapStructA (Comp . Imp.unsafeFreezeRef) + . unRef + + + +---------------------------------------- +-- ** Arrays +---------------------------------------- + +-- | Create an uninitialized array +newArr :: (Type (Internal a), MonadComp m) => Data Length -> m (Arr a) +newArr = newNamedArr "a" + +-- | Create an uninitialized named array +-- +-- The provided base name may be appended with a unique identifier to avoid name +-- collisions. +newNamedArr :: (Type (Internal a), MonadComp m) + => String -- ^ Base name + -> Data Length + -> m (Arr a) +newNamedArr base l = liftComp $ fmap (Arr 0 l) $ + mapStructA (const (Comp $ Imp.newNamedArr base l)) typeRep + +-- | Create an array and initialize it with a constant list +constArr :: (PrimType (Internal a), MonadComp m) + => [Internal a] -- ^ Initial contents + -> m (Arr a) +constArr = constNamedArr "a" + +-- | Create a named array and initialize it with a constant list +-- +-- The provided base name may be appended with a unique identifier to avoid name +-- collisions. +constNamedArr :: (PrimType (Internal a), MonadComp m) + => String -- ^ Base name + -> [Internal a] -- ^ Initial contents + -> m (Arr a) +constNamedArr base as = + liftComp $ fmap (Arr 0 len . Single) $ Comp $ Imp.constNamedArr base as + where + len = value $ genericLength as + +-- | Get an element of an array +getArr :: (Syntax a, MonadComp m) => Arr a -> Data Index -> m a +getArr arr i = do + assertLabel + InternalAssertion + (i < length arr) + "getArr: index out of bounds" + liftComp + $ fmap resugar + $ mapStructA (Comp . flip Imp.getArr (i + arrOffset arr)) + $ unArr arr + +-- | Set an element of an array +setArr :: forall m a . (Syntax a, MonadComp m) => + Arr a -> Data Index -> a -> m () +setArr arr i a = do + assertLabel + InternalAssertion + (i < length arr) + "setArr: index out of bounds" + liftComp + $ sequence_ + $ zipListStruct + (\a' arr' -> Comp $ Imp.setArr arr' (i + arrOffset arr) a') rep + $ unArr arr + where + rep = resugar a :: Struct PrimType' Data (Internal a) + +-- | Copy the contents of an array to another array. The length of the +-- destination array must not be less than that of the source array. +-- +-- In order to copy only a part of an array, use 'slice' before calling +-- 'copyArr'. +copyArr :: MonadComp m + => Arr a -- ^ Destination + -> Arr a -- ^ Source + -> m () +copyArr arr1 arr2 = do + assertLabel + InternalAssertion + (length arr1 >= length arr2) + "copyArr: destination too small" + liftComp $ sequence_ $ + zipListStruct + (\a1 a2 -> + Comp $ Imp.copyArr + (a1, arrOffset arr1) + (a2, arrOffset arr2) + (length arr2) + ) + (unArr arr1) + (unArr arr2) + +-- | Freeze a mutable array to an immutable one. This involves copying the array +-- to a newly allocated one. +freezeArr :: (Type (Internal a), MonadComp m) => Arr a -> m (IArr a) +freezeArr arr = liftComp $ do + arr2 <- newArr (length arr) + copyArr arr2 arr + unsafeFreezeArr arr2 + -- This is better than calling `freezeArr` from imperative-edsl, since that + -- one copies without offset. + +-- | A version of 'freezeArr' that slices the array from 0 to the given length +freezeSlice :: (Type (Internal a), MonadComp m) => + Data Length -> Arr a -> m (IArr a) +freezeSlice len = fmap (slice 0 len) . freezeArr + +-- | Freeze a mutable array to an immutable one without making a copy. This is +-- generally only safe if the the mutable array is not updated as long as the +-- immutable array is alive. +unsafeFreezeArr :: MonadComp m => Arr a -> m (IArr a) +unsafeFreezeArr arr + = liftComp + $ fmap (IArr (arrOffset arr) (length arr)) + $ mapStructA (Comp . Imp.unsafeFreezeArr) + $ unArr arr + +-- | A version of 'unsafeFreezeArr' that slices the array from 0 to the given +-- length +unsafeFreezeSlice :: MonadComp m => Data Length -> Arr a -> m (IArr a) +unsafeFreezeSlice len = fmap (slice 0 len) . unsafeFreezeArr + +-- | Thaw an immutable array to a mutable one. This involves copying the array +-- to a newly allocated one. +thawArr :: (Type (Internal a), MonadComp m) => IArr a -> m (Arr a) +thawArr arr = liftComp $ do + arr2 <- unsafeThawArr arr + arr3 <- newArr (length arr) + copyArr arr3 arr2 + return arr3 + +-- | Thaw an immutable array to a mutable one without making a copy. This is +-- generally only safe if the the mutable array is not updated as long as the +-- immutable array is alive. +unsafeThawArr :: MonadComp m => IArr a -> m (Arr a) +unsafeThawArr arr + = liftComp + $ fmap (Arr (iarrOffset arr) (length arr)) + $ mapStructA (Comp . Imp.unsafeThawArr) + $ unIArr arr + +-- | Create an immutable array and initialize it with a constant list +constIArr :: (PrimType (Internal a), MonadComp m) => + [Internal a] -> m (IArr a) +constIArr = constArr >=> unsafeFreezeArr + + + +---------------------------------------- +-- ** Control-flow +---------------------------------------- + +-- | Conditional statement that returns an expression +ifE :: (Syntax a, MonadComp m) + => Data Bool -- ^ Condition + -> m a -- ^ True branch + -> m a -- ^ False branch + -> m a +ifE c t f = do + res <- newRef + iff c (t >>= setRef res) (f >>= setRef res) + unsafeFreezeRef res + +-- | Break out from a loop +break :: MonadComp m => m () +break = liftComp $ Comp Imp.break + +-- | Assertion (with implicit label @`UserAssertion` ""@) +assert :: MonadComp m + => Data Bool -- ^ Expression that should be true + -> String -- ^ Message in case of failure + -> m () +assert = assertLabel $ UserAssertion "" + +-- | Like 'assert' but tagged with an explicit assertion label +assertLabel :: MonadComp m + => AssertionLabel -- ^ Assertion label + -> Data Bool -- ^ Expression that should be true + -> String -- ^ Message in case of failure + -> m () +assertLabel c cond msg = + liftComp $ Comp $ Oper.singleInj $ Assert c cond msg + + + +---------------------------------------- +-- ** Misc. +---------------------------------------- + +-- | Force evaluation of a value and share the result (monadic version of +-- 'share') +shareM :: (Syntax a, MonadComp m) => a -> m a +shareM = initRef >=> unsafeFreezeRef + -- This function is more commonly needed than `share`, since code motion + -- doesn't work across monadic binds. + diff --git a/src/Feldspar/Optimize.hs b/src/Feldspar/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Optimize.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE CPP #-} + +-- | Optimize Feldspar expressions + +module Feldspar.Optimize where + + + +import Control.Monad.Reader +import Control.Monad.Writer hiding (Any (..)) +import Data.Maybe +import qualified Data.Monoid as Monoid +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.Constraint (Dict (..)) + +import Language.Syntactic +import Language.Syntactic.Functional +import Language.Syntactic.Functional.Tuple +import Language.Syntactic.Functional.Sharing + +import Data.Selection +import Data.TypedStruct +import Feldspar.Primitive.Representation +import Feldspar.Representation + + + +witInteger :: ASTF FeldDomain a -> Maybe (Dict (Integral a, Ord a)) +witInteger a = case getDecor a of + ValT (Single Int8T) -> Just Dict + ValT (Single Int16T) -> Just Dict + ValT (Single Int32T) -> Just Dict + ValT (Single Int64T) -> Just Dict + ValT (Single Word8T) -> Just Dict + ValT (Single Word16T) -> Just Dict + ValT (Single Word32T) -> Just Dict + ValT (Single Word64T) -> Just Dict + _ -> Nothing + +isExact :: ASTF FeldDomain a -> Bool +isExact = isJust . witInteger + +-- | 'prj' with a stronger constraint to allow using it in bidirectional +-- patterns +prj' :: (sub :<: sup) => sup sig -> Maybe (sub sig) +prj' = prj + -- I think this function wouldn't be needed if one could add an appropriate + -- type signature for such patterns, but I wan't able to do this for `SymP` + -- (the inferred type is not accepted). + +pattern SymP t s <- Sym ((prj' -> Just s) :&: ValT t) + where + SymP t s = Sym ((inj s) :&: ValT t) + +pattern VarP t v <- Sym ((prj' -> Just (VarT v)) :&: t) + where + VarP t v = Sym (inj (VarT v) :&: t) + +pattern LamP t v body <- Sym ((prj' -> Just (LamT v)) :&: t) :$ body + where + LamP t v body = Sym (inj (LamT v) :&: t) :$ body + +-- There type signatures are needed in order to use `simplifyUp` in the +-- constructor +#if __GLASGOW_HASKELL__ >= 800 +pattern LitP :: () => (Eq a, Show a) => TypeRep a -> a -> ASTF FeldDomain a +pattern AddP :: () => (Num a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern SubP :: () => (Num a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern MulP :: () => (Num a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern NegP :: () => (Num a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern QuotP :: () => (Integral a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern RemP :: () => (Integral a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern DivP :: () => (Integral a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern ModP :: () => (Integral a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern DivBalancedP :: () => (Integral a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +#else +pattern LitP :: (Eq a, Show a) => TypeRep a -> a -> ASTF FeldDomain a +pattern AddP :: (Num a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern SubP :: (Num a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern MulP :: (Num a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern NegP :: (Num a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern QuotP :: (Integral a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern RemP :: (Integral a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern DivP :: (Integral a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern ModP :: (Integral a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +pattern DivBalancedP :: (Integral a, PrimType' a) => TypeRep a -> ASTF FeldDomain a -> ASTF FeldDomain a -> ASTF FeldDomain a +#endif + +viewLit :: ASTF FeldDomain a -> Maybe a +viewLit lit + | Just (Lit a) <- prj lit = Just a +viewLit _ = Nothing + +pattern LitP t a <- Sym ((prj -> Just (Lit a)) :&: ValT t) + where + LitP t a = Sym (inj (Lit a) :&: ValT t) + +pattern NonLitP <- (viewLit -> Nothing) + +pattern AddP t a b <- SymP t Add :$ a :$ b where AddP t a b = simplifyUp $ SymP t Add :$ a :$ b +pattern SubP t a b <- SymP t Sub :$ a :$ b where SubP t a b = simplifyUp $ SymP t Sub :$ a :$ b +pattern MulP t a b <- SymP t Mul :$ a :$ b where MulP t a b = simplifyUp $ SymP t Mul :$ a :$ b +pattern NegP t a <- SymP t Neg :$ a where NegP t a = simplifyUp $ SymP t Neg :$ a + +pattern QuotP t a b <- SymP t Quot :$ a :$ b where QuotP t a b = simplifyUp $ SymP t Quot :$ a :$ b +pattern RemP t a b <- SymP t Rem :$ a :$ b where RemP t a b = simplifyUp $ SymP t Rem :$ a :$ b +pattern DivP t a b <- SymP t Div :$ a :$ b where DivP t a b = simplifyUp $ SymP t Div :$ a :$ b +pattern ModP t a b <- SymP t Mod :$ a :$ b where ModP t a b = simplifyUp $ SymP t Mod :$ a :$ b +pattern DivBalancedP t a b <- SymP t DivBalanced :$ a :$ b where DivBalancedP t a b = simplifyUp $ SymP t DivBalanced :$ a :$ b + + + +simplifyUp + :: ASTF FeldDomain a + -> ASTF FeldDomain a +simplifyUp (AddP t (LitP _ 0) b) | isExact b = b +simplifyUp (AddP t a (LitP _ 0)) | isExact a = a +simplifyUp (AddP t a@(LitP _ _) b@NonLitP) | isExact a = AddP t b a + -- Move literals to the right +simplifyUp (AddP t (AddP _ a (LitP _ b)) (LitP _ c)) | isExact a = AddP t a (LitP t (b+c)) +simplifyUp (AddP t (SubP _ a (LitP _ b)) (LitP _ c)) | isExact a = AddP t a (LitP t (c-b)) +simplifyUp (AddP t a (LitP _ b)) | Just Dict <- witInteger a, b < 0 = SubP t a (LitP t (negate b)) + +simplifyUp (SubP t (LitP _ 0) b) | isExact b = NegP t b +simplifyUp (SubP t a (LitP _ 0)) | isExact a = a +simplifyUp (SubP t a@(LitP _ _) b@NonLitP) | isExact a = AddP t (NegP t b) a + -- Move literals to the right +simplifyUp (SubP t (AddP _ a (LitP _ b)) (LitP _ c)) | isExact a = AddP t a (LitP t (b-c)) +simplifyUp (SubP t (SubP _ a (LitP _ b)) (LitP _ c)) | isExact a = SubP t a (LitP t (b+c)) +simplifyUp (SubP t a (LitP _ b)) | Just Dict <- witInteger a, b < 0 = AddP t a (LitP t (negate b)) + +simplifyUp (MulP t (LitP _ 0) b) | isExact b = LitP t 0 +simplifyUp (MulP t a (LitP _ 0)) | isExact a = LitP t 0 +simplifyUp (MulP t (LitP _ 1) b) | isExact b = b +simplifyUp (MulP t a (LitP _ 1)) | isExact a = a +simplifyUp (MulP t a@(LitP _ _) b@NonLitP) | isExact a = MulP t b a + -- Move literals to the right +simplifyUp (MulP t (MulP _ a (LitP _ b)) (LitP _ c)) | isExact a = MulP t a (LitP t (b*c)) + +simplifyUp (NegP t (NegP _ a)) | isExact a = a +simplifyUp (NegP t (AddP _ a b)) | isExact a = SubP t (NegP t a) b +simplifyUp (NegP t (SubP _ a b)) | isExact a = SubP t b a +simplifyUp (NegP t (MulP _ a b)) | isExact a = MulP t a (NegP t b) + -- Negate the right operand, because literals are moved to the right in + -- multiplications + +simplifyUp (QuotP t (LitP _ 0) b) = LitP t 0 +simplifyUp (QuotP _ a (LitP _ 1)) = a +simplifyUp (QuotP t@(Single _) a b) | alphaEq a b = LitP t 1 + +simplifyUp (RemP t (LitP _ 0) b) = LitP t 0 +simplifyUp (RemP t a (LitP _ 1)) = LitP t 0 +simplifyUp (RemP t@(Single _) a b) | alphaEq a b = LitP t 0 + +simplifyUp (DivP t (LitP _ 0) b) = LitP t 0 +simplifyUp (DivP _ a (LitP _ 1)) = a +simplifyUp (DivP t@(Single _) a b) | alphaEq a b = LitP t 1 + +simplifyUp (ModP t (LitP _ 0) b) = LitP t 0 +simplifyUp (ModP t a (LitP _ 1)) = LitP t 0 +simplifyUp (ModP t@(Single _) a b) | alphaEq a b = LitP t 0 + +simplifyUp (MulP _ (DivBalancedP _ a b) c) | alphaEq b c = a +simplifyUp (MulP _ a (DivBalancedP _ b c)) | alphaEq a c = b + -- These rewrites are only correct if the assumption of `DivBalanced` is + -- fulfilled. + +simplifyUp (SymP _ Not :$ (SymP _ Not :$ a)) = a +simplifyUp (SymP t Not :$ (SymP _ Lt :$ a :$ b)) = simplifyUp $ SymP t Ge :$ a :$ b +simplifyUp (SymP t Not :$ (SymP _ Gt :$ a :$ b)) = simplifyUp $ SymP t Le :$ a :$ b +simplifyUp (SymP t Not :$ (SymP _ Le :$ a :$ b)) = simplifyUp $ SymP t Gt :$ a :$ b +simplifyUp (SymP t Not :$ (SymP _ Ge :$ a :$ b)) = simplifyUp $ SymP t Lt :$ a :$ b + +simplifyUp (SymP _ And :$ LitP t False :$ _) = LitP t False +simplifyUp (SymP _ And :$ _ :$ LitP t False) = LitP t False +simplifyUp (SymP _ And :$ LitP t True :$ b) = b +simplifyUp (SymP _ And :$ a :$ LitP t True) = a + +simplifyUp (SymP _ Or :$ LitP t False :$ b) = b +simplifyUp (SymP _ Or :$ a :$ LitP t False) = a +simplifyUp (SymP _ Or :$ LitP t True :$ _) = LitP t True +simplifyUp (SymP _ Or :$ _ :$ LitP t True) = LitP t True + +simplifyUp (SymP _ Cond :$ LitP _ True :$ t :$ _) = t +simplifyUp (SymP _ Cond :$ LitP _ False :$ _ :$ f) = f +simplifyUp (SymP _ Cond :$ c :$ t :$ f) | equal t f = t + +-- simplifyUp (SymP _ ForLoop :$ LitP _ 0 :$ init :$ _) = init + -- This triggers the bug: . The + -- line below is a workaround: +simplifyUp (Sym ((prj -> Just ForLoop) :&: _) :$ LitP _ 0 :$ init :$ _) = init +simplifyUp (SymP _ ForLoop :$ _ :$ init :$ LamP _ _ (LamP _ vs (VarP _ vs'))) + | vs==vs' = init + +simplifyUp (SymP t Pair :$ (SymP _ Fst :$ a) :$ (SymP _ Snd :$ b)) + | alphaEq a b + , ValT t' <- getDecor a + , Just Dict <- typeEq t t' = a +simplifyUp (SymP t Fst :$ (SymP _ Pair :$ a :$ _)) = a +simplifyUp (SymP t Snd :$ (SymP _ Pair :$ _ :$ a)) = a + -- The cases for pairs don't affect the generated code, but they improve the + -- output of functions like `drawAST` + +simplifyUp a = constFold a + -- `constFold` here ensures that `simplifyUp` does not produce any expressions + -- that can be statically constant folded. This property is needed, e.g. to + -- fully simplify the expression `negate (2*x)`. The simplification should go + -- as follows: + -- + -- negate (2*x) -> negate (x*2) -> x * negate 2 -> x*(-2) + -- + -- There is no explicit rule for the last step; it is done by `constFold`. + -- Furthermore, this constant folding would not be performed by `simplifyM` + -- since it never sees the sub-expression `negate 2`. (Note that the constant + -- folding in `simplifyM` is still needed, because constructs such as + -- `ForLoop` cannot be folded by simple literal propagation.) + -- + -- In order to see that `simplifyUp` doesn't produce any "junk" + -- (sub-expressions that can be folded by `constFold`), we reason as follows: + -- + -- * Assume that the arguments of the top-level node are junk-free + -- * `simplifyUp` will either apply an explicit rewrite or apply `constFold` + -- * In the latter case, the result will be junk-free + -- * In case of an explicit rewrite, the resulting expression is constructed + -- by applying `simplifyUp` to each newly introduced node; thus the + -- resulting expression must be junk-free + + + +-- | Reduce an expression to a literal if the following conditions are met: +-- +-- * The top-most symbol can be evaluated statically (i.g. not a variable or a +-- lifted side-effecting program) +-- * All immediate sub-terms are literals +-- * The type of the expression is an allowed type for literals (e.g. not a +-- function) +-- +-- Note that this function only folds the top-level node of an expressions (if +-- possible). It does not reduce an expression like @1+(2+3)@ where the +-- sub-expression @2+3@ is not a literal. +constFold :: ASTF FeldDomain a -> ASTF FeldDomain a +constFold e + | constArgs e + , canFold e + , ValT t@(Single _) <- getDecor e + = LitP t $ evalClosed e + where + canFold :: ASTF FeldDomain a -> Bool + canFold e = simpleMatch + (\s _ -> case () of + _ | SymP _ (FreeVar _) <- e -> False + _ | SymP _ (ArrIx _) :$ _ <- e -> False + -- Don't fold array indexing + _ | SymP _ Pi <- e -> False + _ | MulP _ _ (SymP _ Pi) <- e -> False + -- Don't fold expressions like `2*pi` + _ | Just (_ :: BindingT sig) <- prj s -> False + _ | Just (_ :: Unsafe sig) <- prj s -> False + _ -> True + ) + e +constFold e = e + +-- | Check whether all arguments of a symbol are literals +constArgs :: AST FeldDomain sig -> Bool +constArgs (Sym _) = True +constArgs (s :$ LitP _ _) = constArgs s +constArgs _ = False + + + +type OptEnv = Selection AssertionLabel + +type Opt = ReaderT OptEnv (Writer (Set Name, Monoid.Any)) + +tellVar :: Name -> Opt () +tellVar v = tell (Set.singleton v, mempty) + +deleteVar :: Name -> Opt a -> Opt a +deleteVar v = censor (\(vs,unsafe) -> (Set.delete v vs, unsafe)) + +tellUnsafe :: Opt () +tellUnsafe = tell (mempty, Monoid.Any True) + +simplifyM :: ASTF FeldDomain a -> Opt (ASTF FeldDomain a) +simplifyM a = do + cs <- ask + case a of + a@(VarP _ v) -> tellVar v >> return a + (LamP t v body) -> deleteVar v $ fmap (LamP t v) $ simplifyM body + res@(SymP t I2N :$ AddP _ a b) | isExact res -> AddP t <$> simplifyM (SymP t I2N :$ a) <*> simplifyM (SymP t I2N :$ b) + res@(SymP t I2N :$ SubP _ a b) | isExact res -> SubP t <$> simplifyM (SymP t I2N :$ a) <*> simplifyM (SymP t I2N :$ b) + res@(SymP t I2N :$ MulP _ a b) | isExact res -> MulP t <$> simplifyM (SymP t I2N :$ a) <*> simplifyM (SymP t I2N :$ b) + res@(SymP t I2N :$ NegP _ a) | isExact res -> NegP t <$> simplifyM (SymP t I2N :$ a) + -- Pushing down `I2N` is not good for in-exact types, since that puts + -- more of the expression under the in-exact type. This means that fewer + -- simplifications may apply. Also, operations on in-exact types are + -- typically more expensive. + -- + -- Here it's important to guard on whether the *result* is an exact + -- type. (For other numeric operations it doesn't matter which + -- sub-expression we check because they all have the same type.) + (SymP _ (GuardVal c _) :$ _ :$ a) | not (cs `includes` c) -> simplifyM a + _ -> simpleMatch + ( \s@(_ :&: t) as -> do + (a',(vs, Monoid.Any unsafe)) <- listen (simplifyUp . appArgs (Sym s) <$> mapArgsM simplifyM as) + case () of + _ | SymP _ (FreeVar _) <- a' -> tellUnsafe >> return a' + _ | SymP _ (ArrIx _) :$ _ <- a' -> tellUnsafe >> return a' + -- Array indexing is actually not unsafe. It's more like + -- an expression with a free variable. But setting the + -- unsafe flag does the trick. + + _ | SymP _ Pi <- a' -> return a' + _ | MulP _ _ (SymP _ Pi) <- a' -> return a' + -- Don't fold expressions like `2*pi` + + _ | Just (_ :: Unsafe sig) <- prj s -> tellUnsafe >> return a' + _ | null vs && not unsafe + , ValT t'@(Single _) <- t + -> return $ LitP t' $ evalClosed a' + -- Constant fold if expression is closed and does not + -- contain unsafe operations. + _ -> return a' + ) + a + +simplify :: OptEnv -> ASTF FeldDomain a -> ASTF FeldDomain a +simplify env = fst . runWriter . flip runReaderT env . simplifyM + +-- | Interface for controlling code motion +cmInterface :: CodeMotionInterface FeldDomain +cmInterface = defaultInterfaceDecor + typeEqFun + (\(ValT t) -> FunT t) + (\(ValT t) -> case witTypeable t of Dict -> VarT) + (\(ValT t) _ -> case witTypeable t of Dict -> LamT) + sharable + (const True) + where + sharable :: ASTF FeldDomain a -> ASTF FeldDomain b -> Bool + sharable (Sym _) _ = False -- Simple expressions not shared + sharable (LamP _ _ _) _ = False + sharable _ (LamP _ _ _) = False + -- Don't place let bindings over lambdas. This ensures that function + -- arguments of higher-order constructs such as `ForLoop` are always + -- lambdas. + sharable (SymP _ (_ :: Tuple (b :-> Full c)) :$ _) _ = False + -- Any unary `Tuple` symbol must be a selector (because there are no + -- 1-tuples). + sharable (SymP _ I2N :$ _) _ = False + sharable (SymP _ (ArrIx _) :$ _) _ = False + sharable _ _ = True + +-- | Optimize a Feldspar expression +optimize :: OptEnv -> ASTF FeldDomain a -> ASTF FeldDomain a +optimize env = codeMotion cmInterface . simplify env + diff --git a/src/Feldspar/Primitive/Backend/C.hs b/src/Feldspar/Primitive/Backend/C.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Primitive/Backend/C.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE QuasiQuotes #-} + +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +-- | C code generation of primitive Feldspar expressions + +module Feldspar.Primitive.Backend.C where + + + +import Data.Complex + +import Data.Constraint (Dict (..)) +import Data.Proxy + +import Language.C.Quote.C +import qualified Language.C.Syntax as C + +import Language.C.Monad +import Language.Embedded.Backend.C + +import Language.Syntactic + +import Feldspar.Primitive.Representation + + + +-- Note: This module assumes a 32-bit target. For example the C function `abs` +-- is used up to 32-bits, and `labs` is used above that. + +viewLitPrim :: ASTF (Primitive :&: PrimTypeRep) a -> Maybe a +viewLitPrim (Sym (Lit a :&: _)) = Just a +viewLitPrim (Sym (Pi :&: _)) = Just pi +viewLitPrim _ = Nothing + +instance CompTypeClass PrimType' + where + compType _ (_ :: proxy a) = case primTypeRep :: PrimTypeRep a of + BoolT -> addInclude "" >> return [cty| typename bool |] + Int8T -> addInclude "" >> return [cty| typename int8_t |] + Int16T -> addInclude "" >> return [cty| typename int16_t |] + Int32T -> addInclude "" >> return [cty| typename int32_t |] + Int64T -> addInclude "" >> return [cty| typename int64_t |] + Word8T -> addInclude "" >> return [cty| typename uint8_t |] + Word16T -> addInclude "" >> return [cty| typename uint16_t |] + Word32T -> addInclude "" >> return [cty| typename uint32_t |] + Word64T -> addInclude "" >> return [cty| typename uint64_t |] + FloatT -> return [cty| float |] + DoubleT -> return [cty| double |] + ComplexFloatT -> addInclude "" >> return [cty| float _Complex |] + ComplexDoubleT -> addInclude "" >> return [cty| double _Complex |] + + compLit _ a = case primTypeOf a of + BoolT -> do addInclude "" + return $ if a then [cexp| true |] else [cexp| false |] + Int8T -> return [cexp| $a |] + Int16T -> return [cexp| $a |] + Int32T -> return [cexp| $a |] + Int64T -> return [cexp| $a |] + Word8T -> return [cexp| $a |] + Word16T -> return [cexp| $a |] + Word32T -> return [cexp| $a |] + Word64T -> return [cexp| $a |] + FloatT -> return [cexp| $a |] + DoubleT -> return [cexp| $a |] + ComplexFloatT -> return $ compComplexLit a + ComplexDoubleT -> return $ compComplexLit a + +-- | Compile a complex literal +compComplexLit :: (Eq a, Num a, ToExp a) => Complex a -> C.Exp +compComplexLit (r :+ 0) = [cexp| $r |] +compComplexLit (0 :+ i) = [cexp| $i * I |] +compComplexLit (r :+ i) = [cexp| $r + $i * I |] + +addTagMacro :: MonadC m => m () +addTagMacro = addGlobal [cedecl|$esc:("#define TAG(tag,exp) (exp)")|] + +-- | Compile a unary operator +compUnOp :: MonadC m => C.UnOp -> ASTF PrimDomain a -> m C.Exp +compUnOp op a = do + a' <- compPrim $ Prim a + return $ C.UnOp op a' mempty + +-- | Compile a binary operator +compBinOp :: MonadC m => + C.BinOp -> ASTF PrimDomain a -> ASTF PrimDomain b -> m C.Exp +compBinOp op a b = do + a' <- compPrim $ Prim a + b' <- compPrim $ Prim b + return $ C.BinOp op a' b' mempty + +-- | Compile a function call +compFun :: MonadC m => String -> Args (AST PrimDomain) sig -> m C.Exp +compFun fun args = do + as <- sequence $ listArgs (compPrim . Prim) args + return [cexp| $id:fun($args:as) |] + +-- | Compile a call to 'abs' +compAbs :: MonadC m => PrimTypeRep a -> ASTF PrimDomain a -> m C.Exp +compAbs t a = case viewPrimTypeRep t of + PrimTypeBool -> error "compAbs: type BoolT not supported" + PrimTypeIntWord (IntType _) -> addInclude "" >> compFun "abs" (a :* Nil) + PrimTypeIntWord (WordType _) -> compPrim $ Prim a + _ -> addInclude "" >> compFun "fabs" (a :* Nil) + -- Floating and complex types + +complexSign_def = [cedecl| +double _Complex feld_complexSign(double _Complex c) { + double z = cabs(c); + if (z == 0) { + return 0; + } else { + return (creal(c)/z + I*(cimag(c)/z)); + } +} +|] + +complexSignf_def = [cedecl| +float _Complex feld_complexSignf(float _Complex c) { + float z = cabsf(c); + if (z == 0) { + return 0; + } else { + return (crealf(c)/z + I*(cimagf(c)/z)); + } +} +|] + +-- | Compile a call to 'signum' +compSign :: MonadC m => PrimTypeRep a -> ASTF PrimDomain a -> m C.Exp +compSign t a = case viewPrimTypeRep t of + PrimTypeBool -> error "compSign: type BoolT not supported" + PrimTypeIntWord (WordType _) -> do + addTagMacro + a' <- compPrim $ Prim a + return [cexp| TAG("signum", $a' > 0) |] + PrimTypeIntWord (IntType _) -> do + addTagMacro + a' <- compPrim $ Prim a + return [cexp| TAG("signum", ($a' > 0) - ($a' < 0)) |] + PrimTypeFloating FloatType -> do + addTagMacro + a' <- compPrim $ Prim a + return [cexp| TAG("signum", (float) (($a' > 0) - ($a' < 0))) |] + PrimTypeFloating DoubleType -> do + addTagMacro + a' <- compPrim $ Prim a + return [cexp| TAG("signum", (double) (($a' > 0) - ($a' < 0))) |] + PrimTypeComplex ComplexDoubleType -> do + addInclude "" + addGlobal complexSign_def + a' <- compPrim $ Prim a + return [cexp| feld_complexSign($a') |] + PrimTypeComplex ComplexFloatType -> do + addInclude "" + addGlobal complexSignf_def + a' <- compPrim $ Prim a + return [cexp| feld_complexSignf($a') |] + -- TODO The floating point cases give `sign (-0.0) = 0.0`, which is (slightly) + -- wrong. They should return -0.0. I don't know whether it's correct for other + -- strange values. + +-- | Compile a type casted primitive expression +compCast :: MonadC m => PrimTypeRep a -> ASTF PrimDomain b -> m C.Exp +compCast t a = compPrim (Prim a) >>= compCastExp t + +-- | Applies type cast on a compiled expression +compCastExp :: MonadC m => PrimTypeRep a -> C.Exp -> m C.Exp +compCastExp t a + | Dict <- witPrimType t = do + t' <- compType (Proxy :: Proxy PrimType') t + return [cexp|($ty:t') $a|] + +-- | Compile a call to 'round' +-- A cast is added to the resulting expression to allow compatibility +-- between different integral and floating return types. +compRound :: (PrimType' a, Num a, RealFrac b, MonadC m) => + PrimTypeRep a -> ASTF PrimDomain b -> m C.Exp +compRound t a = do + addInclude "" + rounded <- case viewPrimTypeRep t of + PrimTypeIntWord _ -> compFun "lround" (a :* Nil) + PrimTypeFloating _ -> compFun "round" (a :* Nil) + PrimTypeComplex _ -> compFun "round" (a :* Nil) + _ -> error $ "compRound: type " ++ show t ++ " not supported" + compCastExp t rounded + +-- Note: There's no problem with including both `tgmath.h` and `math.h`. As long +-- as the former is included, including the latter (before or after) doesn't +-- make a difference. +-- +-- See: + +div_def = [cedecl| +int feld_div(int x, int y) { + int q = x/y; + int r = x%y; + if ((r!=0) && ((r<0) != (y<0))) --q; + return q; +} +|] + +ldiv_def = [cedecl| +long int feld_ldiv(long int x, long int y) { + int q = x/y; + int r = x%y; + if ((r!=0) && ((r<0) != (y<0))) --q; + return q; +} +|] + +mod_def = [cedecl| +int feld_mod(int x, int y) { + int r = x%y; + if ((r!=0) && ((r<0) != (y<0))) { r += y; } + return r; +} +|] + +lmod_def = [cedecl| +long int feld_lmod(long int x, long int y) { + int r = x%y; + if ((r!=0) && ((r<0) != (y<0))) { r += y; } + return r; +} +|] + +-- The above C implementations are taken from +-- + +compDiv :: MonadC m => + PrimTypeRep a -> ASTF PrimDomain a -> ASTF PrimDomain b -> m C.Exp +compDiv t a b = case viewPrimTypeRep t of + PrimTypeIntWord (WordType _) -> compBinOp C.Div a b + PrimTypeIntWord (IntType Int64Type) -> do + addGlobal ldiv_def + compFun "feld_ldiv" (a :* b :* Nil) + PrimTypeIntWord _ -> do + addGlobal div_def + compFun "feld_div" (a :* b :* Nil) + _ -> error $ "compDiv: type " ++ show t ++ " not supported" + +compMod :: MonadC m => + PrimTypeRep a -> ASTF PrimDomain a -> ASTF PrimDomain b -> m C.Exp +compMod t a b = case viewPrimTypeRep t of + PrimTypeIntWord (WordType _) -> compBinOp C.Mod a b + PrimTypeIntWord (IntType Int64Type) -> do + addGlobal lmod_def + compFun "feld_lmod" (a :* b :* Nil) + PrimTypeIntWord _ -> do + addGlobal mod_def + compFun "feld_mod" (a :* b :* Nil) + _ -> error $ "compMod: type " ++ show t ++ " not supported" + +-- | Compile an expression +compPrim :: MonadC m => Prim a -> m C.Exp +compPrim = simpleMatch (\(s :&: t) -> go t s) . unPrim + where + go :: forall m sig . MonadC m + => PrimTypeRep (DenResult sig) + -> Primitive sig + -> Args (AST PrimDomain) sig + -> m C.Exp + go _ (FreeVar v) Nil = touchVar v >> return [cexp| $id:v |] + go t (Lit a) Nil + | Dict <- witPrimType t + = compLit (Proxy :: Proxy PrimType') a + go _ Add (a :* b :* Nil) = compBinOp C.Add a b + go _ Sub (a :* b :* Nil) = compBinOp C.Sub a b + go _ Mul (a :* b :* Nil) = compBinOp C.Mul a b + go _ Neg (a :* Nil) = compUnOp C.Negate a + go t Abs (a :* Nil) = compAbs t a + go t Sign (a :* Nil) = compSign t a + + go _ Quot (a :* b :* Nil) = compBinOp C.Div a b + go _ Rem (a :* b :* Nil) = compBinOp C.Mod a b + go t Div (a :* b :* Nil) = compDiv t a b + go t Mod (a :* b :* Nil) = compMod t a b + go _ FDiv (a :* b :* Nil) = compBinOp C.Div a b + + go _ Pi Nil = addGlobal pi_def >> return [cexp| FELD_PI |] + where pi_def = [cedecl|$esc:("#define FELD_PI 3.141592653589793")|] + -- This is the value of `pi :: Double`. + -- Apparently there is no standard C99 definition of pi. + go _ Exp args = addInclude "" >> compFun "exp" args + go _ Log args = addInclude "" >> compFun "log" args + go _ Sqrt args = addInclude "" >> compFun "sqrt" args + go _ Pow args = addInclude "" >> compFun "pow" args + go _ Sin args = addInclude "" >> compFun "sin" args + go _ Cos args = addInclude "" >> compFun "cos" args + go _ Tan args = addInclude "" >> compFun "tan" args + go _ Asin args = addInclude "" >> compFun "asin" args + go _ Acos args = addInclude "" >> compFun "acos" args + go _ Atan args = addInclude "" >> compFun "atan" args + go _ Sinh args = addInclude "" >> compFun "sinh" args + go _ Cosh args = addInclude "" >> compFun "cosh" args + go _ Tanh args = addInclude "" >> compFun "tanh" args + go _ Asinh args = addInclude "" >> compFun "asinh" args + go _ Acosh args = addInclude "" >> compFun "acosh" args + go _ Atanh args = addInclude "" >> compFun "atanh" args + + go _ Complex (a :* b :* Nil) = do + addInclude "" + a' <- compPrim $ Prim a + b' <- compPrim $ Prim b + return $ case (viewLitPrim a, viewLitPrim b) of + (Just 0, _) -> [cexp| I*$b' |] + (_, Just 0) -> [cexp| $a' |] + _ -> [cexp| $a' + I*$b' |] + -- We assume that constant folding has been performed, so that not both + -- `a` and `b` are constants + go _ Polar (m :* p :* Nil) + | Just 0 <- viewLitPrim m = return [cexp| 0 |] + | Just 0 <- viewLitPrim p = do + m' <- compPrim $ Prim m + return [cexp| $m' |] + | Just 1 <- viewLitPrim m = do + p' <- compPrim $ Prim p + return [cexp| exp(I*$p') |] + | otherwise = do + m' <- compPrim $ Prim m + p' <- compPrim $ Prim p + return [cexp| $m' * exp(I*$p') |] + -- We assume that constant folding has been performed, so that not both + -- `m` and `p` are constants + go _ Real args = addInclude "" >> compFun "creal" args + go _ Imag args = addInclude "" >> compFun "cimag" args + go _ Magnitude args = addInclude "" >> compFun "cabs" args + go _ Phase args = addInclude "" >> compFun "carg" args + go _ Conjugate args = addInclude "" >> compFun "conj" args + + go t I2N (a :* Nil) = compCast t a + go t I2B (a :* Nil) = compCast t a + go t B2I (a :* Nil) = compCast t a + go t Round (a :* Nil) = compRound t a + + go _ Not (a :* Nil) = compUnOp C.Lnot a + go _ And (a :* b :* Nil) = compBinOp C.Land a b + go _ Or (a :* b :* Nil) = compBinOp C.Lor a b + go _ Eq (a :* b :* Nil) = compBinOp C.Eq a b + go _ NEq (a :* b :* Nil) = compBinOp C.Ne a b + go _ Lt (a :* b :* Nil) = compBinOp C.Lt a b + go _ Gt (a :* b :* Nil) = compBinOp C.Gt a b + go _ Le (a :* b :* Nil) = compBinOp C.Le a b + go _ Ge (a :* b :* Nil) = compBinOp C.Ge a b + + go _ BitAnd (a :* b :* Nil) = compBinOp C.And a b + go _ BitOr (a :* b :* Nil) = compBinOp C.Or a b + go _ BitXor (a :* b :* Nil) = compBinOp C.Xor a b + go _ BitCompl (a :* Nil) = compUnOp C.Not a + go _ ShiftL (a :* b :* Nil) = compBinOp C.Lsh a b + go _ ShiftR (a :* b :* Nil) = compBinOp C.Rsh a b + + go _ (ArrIx arr) (i :* Nil) = do + i' <- compPrim $ Prim i + touchVar arr + return [cexp| $id:arr[$i'] |] + + go _ Cond (c :* t :* f :* Nil) = do + c' <- compPrim $ Prim c + t' <- compPrim $ Prim t + f' <- compPrim $ Prim f + return $ C.Cond c' t' f' mempty + + go _ s _ = error $ "compPrim: no handling of symbol " ++ renderSym s + -- Should not occur, but the completeness checker doesn't know that + +instance CompExp Prim where compExp = compPrim + diff --git a/src/Feldspar/Primitive/Representation.hs b/src/Feldspar/Primitive/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Primitive/Representation.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +-- | Primitive Feldspar expressions + +module Feldspar.Primitive.Representation where + + + +import Data.Array +import Data.Bits +import Data.Complex +import Data.Int +import Data.Typeable +import Data.Word + +import Data.Constraint (Dict (..)) + +import Language.Embedded.Expression +import Language.Embedded.Imperative.CMD (IArr (..)) + +import Language.Syntactic +import Language.Syntactic.TH +import Language.Syntactic.Functional + + + +-------------------------------------------------------------------------------- +-- * Types +-------------------------------------------------------------------------------- + +type Length = Word32 +type Index = Word32 + +-- | Representation of primitive supported types +data PrimTypeRep a + where + BoolT :: PrimTypeRep Bool + Int8T :: PrimTypeRep Int8 + Int16T :: PrimTypeRep Int16 + Int32T :: PrimTypeRep Int32 + Int64T :: PrimTypeRep Int64 + Word8T :: PrimTypeRep Word8 + Word16T :: PrimTypeRep Word16 + Word32T :: PrimTypeRep Word32 + Word64T :: PrimTypeRep Word64 + FloatT :: PrimTypeRep Float + DoubleT :: PrimTypeRep Double + ComplexFloatT :: PrimTypeRep (Complex Float) + ComplexDoubleT :: PrimTypeRep (Complex Double) + +data IntTypeRep a + where + Int8Type :: IntTypeRep Int8 + Int16Type :: IntTypeRep Int16 + Int32Type :: IntTypeRep Int32 + Int64Type :: IntTypeRep Int64 + +data WordTypeRep a + where + Word8Type :: WordTypeRep Word8 + Word16Type :: WordTypeRep Word16 + Word32Type :: WordTypeRep Word32 + Word64Type :: WordTypeRep Word64 + +data IntWordTypeRep a + where + IntType :: IntTypeRep a -> IntWordTypeRep a + WordType :: WordTypeRep a -> IntWordTypeRep a + +data FloatingTypeRep a + where + FloatType :: FloatingTypeRep Float + DoubleType :: FloatingTypeRep Double + +data ComplexTypeRep a + where + ComplexFloatType :: ComplexTypeRep (Complex Float) + ComplexDoubleType :: ComplexTypeRep (Complex Double) + +-- | A different view of 'PrimTypeRep' that allows matching on similar types +data PrimTypeView a + where + PrimTypeBool :: PrimTypeView Bool + PrimTypeIntWord :: IntWordTypeRep a -> PrimTypeView a + PrimTypeFloating :: FloatingTypeRep a -> PrimTypeView a + PrimTypeComplex :: ComplexTypeRep a -> PrimTypeView a + +deriving instance Show (PrimTypeRep a) +deriving instance Show (IntTypeRep a) +deriving instance Show (WordTypeRep a) +deriving instance Show (IntWordTypeRep a) +deriving instance Show (FloatingTypeRep a) +deriving instance Show (ComplexTypeRep a) +deriving instance Show (PrimTypeView a) + +viewPrimTypeRep :: PrimTypeRep a -> PrimTypeView a +viewPrimTypeRep BoolT = PrimTypeBool +viewPrimTypeRep Int8T = PrimTypeIntWord $ IntType $ Int8Type +viewPrimTypeRep Int16T = PrimTypeIntWord $ IntType $ Int16Type +viewPrimTypeRep Int32T = PrimTypeIntWord $ IntType $ Int32Type +viewPrimTypeRep Int64T = PrimTypeIntWord $ IntType $ Int64Type +viewPrimTypeRep Word8T = PrimTypeIntWord $ WordType $ Word8Type +viewPrimTypeRep Word16T = PrimTypeIntWord $ WordType $ Word16Type +viewPrimTypeRep Word32T = PrimTypeIntWord $ WordType $ Word32Type +viewPrimTypeRep Word64T = PrimTypeIntWord $ WordType $ Word64Type +viewPrimTypeRep FloatT = PrimTypeFloating FloatType +viewPrimTypeRep DoubleT = PrimTypeFloating DoubleType +viewPrimTypeRep ComplexFloatT = PrimTypeComplex ComplexFloatType +viewPrimTypeRep ComplexDoubleT = PrimTypeComplex ComplexDoubleType + +unviewPrimTypeRep :: PrimTypeView a -> PrimTypeRep a +unviewPrimTypeRep PrimTypeBool = BoolT +unviewPrimTypeRep (PrimTypeIntWord (IntType Int8Type)) = Int8T +unviewPrimTypeRep (PrimTypeIntWord (IntType Int16Type)) = Int16T +unviewPrimTypeRep (PrimTypeIntWord (IntType Int32Type)) = Int32T +unviewPrimTypeRep (PrimTypeIntWord (IntType Int64Type)) = Int64T +unviewPrimTypeRep (PrimTypeIntWord (WordType Word8Type)) = Word8T +unviewPrimTypeRep (PrimTypeIntWord (WordType Word16Type)) = Word16T +unviewPrimTypeRep (PrimTypeIntWord (WordType Word32Type)) = Word32T +unviewPrimTypeRep (PrimTypeIntWord (WordType Word64Type)) = Word64T +unviewPrimTypeRep (PrimTypeFloating FloatType) = FloatT +unviewPrimTypeRep (PrimTypeFloating DoubleType) = DoubleT +unviewPrimTypeRep (PrimTypeComplex ComplexFloatType) = ComplexFloatT +unviewPrimTypeRep (PrimTypeComplex ComplexDoubleType) = ComplexDoubleT + +primTypeIntWidth :: PrimTypeRep a -> Maybe Int +primTypeIntWidth Int8T = Just 8 +primTypeIntWidth Int16T = Just 16 +primTypeIntWidth Int32T = Just 32 +primTypeIntWidth Int64T = Just 64 +primTypeIntWidth Word8T = Just 8 +primTypeIntWidth Word16T = Just 16 +primTypeIntWidth Word32T = Just 32 +primTypeIntWidth Word64T = Just 64 +primTypeIntWidth _ = Nothing + +-- | Primitive supported types +class (Eq a, Show a, Typeable a) => PrimType' a + where + -- | Reify a primitive type + primTypeRep :: PrimTypeRep a + +instance PrimType' Bool where primTypeRep = BoolT +instance PrimType' Int8 where primTypeRep = Int8T +instance PrimType' Int16 where primTypeRep = Int16T +instance PrimType' Int32 where primTypeRep = Int32T +instance PrimType' Int64 where primTypeRep = Int64T +instance PrimType' Word8 where primTypeRep = Word8T +instance PrimType' Word16 where primTypeRep = Word16T +instance PrimType' Word32 where primTypeRep = Word32T +instance PrimType' Word64 where primTypeRep = Word64T +instance PrimType' Float where primTypeRep = FloatT +instance PrimType' Double where primTypeRep = DoubleT +instance PrimType' (Complex Float) where primTypeRep = ComplexFloatT +instance PrimType' (Complex Double) where primTypeRep = ComplexDoubleT + +-- | Convenience function; like 'primTypeRep' but with an extra argument to +-- constrain the type parameter. The extra argument is ignored. +primTypeOf :: PrimType' a => a -> PrimTypeRep a +primTypeOf _ = primTypeRep + +-- | Check whether two type representations are equal +primTypeEq :: PrimTypeRep a -> PrimTypeRep b -> Maybe (Dict (a ~ b)) +primTypeEq BoolT BoolT = Just Dict +primTypeEq Int8T Int8T = Just Dict +primTypeEq Int16T Int16T = Just Dict +primTypeEq Int32T Int32T = Just Dict +primTypeEq Int64T Int64T = Just Dict +primTypeEq Word8T Word8T = Just Dict +primTypeEq Word16T Word16T = Just Dict +primTypeEq Word32T Word32T = Just Dict +primTypeEq Word64T Word64T = Just Dict +primTypeEq FloatT FloatT = Just Dict +primTypeEq DoubleT DoubleT = Just Dict +primTypeEq ComplexFloatT ComplexFloatT = Just Dict +primTypeEq ComplexDoubleT ComplexDoubleT = Just Dict +primTypeEq _ _ = Nothing + +-- | Reflect a 'PrimTypeRep' to a 'PrimType'' constraint +witPrimType :: PrimTypeRep a -> Dict (PrimType' a) +witPrimType BoolT = Dict +witPrimType Int8T = Dict +witPrimType Int16T = Dict +witPrimType Int32T = Dict +witPrimType Int64T = Dict +witPrimType Word8T = Dict +witPrimType Word16T = Dict +witPrimType Word32T = Dict +witPrimType Word64T = Dict +witPrimType FloatT = Dict +witPrimType DoubleT = Dict +witPrimType ComplexFloatT = Dict +witPrimType ComplexDoubleT = Dict + + + +-------------------------------------------------------------------------------- +-- * Expressions +-------------------------------------------------------------------------------- + +-- | Primitive operations +data Primitive sig + where + FreeVar :: PrimType' a => String -> Primitive (Full a) + Lit :: (Eq a, Show a) => a -> Primitive (Full a) + + Add :: (Num a, PrimType' a) => Primitive (a :-> a :-> Full a) + Sub :: (Num a, PrimType' a) => Primitive (a :-> a :-> Full a) + Mul :: (Num a, PrimType' a) => Primitive (a :-> a :-> Full a) + Neg :: (Num a, PrimType' a) => Primitive (a :-> Full a) + Abs :: (Num a, PrimType' a) => Primitive (a :-> Full a) + Sign :: (Num a, PrimType' a) => Primitive (a :-> Full a) + + Quot :: (Integral a, PrimType' a) => Primitive (a :-> a :-> Full a) + Rem :: (Integral a, PrimType' a) => Primitive (a :-> a :-> Full a) + Div :: (Integral a, PrimType' a) => Primitive (a :-> a :-> Full a) + Mod :: (Integral a, PrimType' a) => Primitive (a :-> a :-> Full a) + FDiv :: (Fractional a, PrimType' a) => Primitive (a :-> a :-> Full a) + + Pi :: (Floating a, PrimType' a) => Primitive (Full a) + Exp :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Log :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Sqrt :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Pow :: (Floating a, PrimType' a) => Primitive (a :-> a :-> Full a) + Sin :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Cos :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Tan :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Asin :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Acos :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Atan :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Sinh :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Cosh :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Tanh :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Asinh :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Acosh :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + Atanh :: (Floating a, PrimType' a) => Primitive (a :-> Full a) + + Complex :: (Num a, PrimType' a, PrimType' (Complex a)) => Primitive (a :-> a :-> Full (Complex a)) + Polar :: (Floating a, PrimType' a, PrimType' (Complex a)) => Primitive (a :-> a :-> Full (Complex a)) + Real :: (PrimType' a, PrimType' (Complex a)) => Primitive (Complex a :-> Full a) + Imag :: (PrimType' a, PrimType' (Complex a)) => Primitive (Complex a :-> Full a) + Magnitude :: (RealFloat a, PrimType' a, PrimType' (Complex a)) => Primitive (Complex a :-> Full a) + Phase :: (RealFloat a, PrimType' a, PrimType' (Complex a)) => Primitive (Complex a :-> Full a) + Conjugate :: (Num a, PrimType' (Complex a)) => Primitive (Complex a :-> Full (Complex a)) + + I2N :: (Integral a, Num b, PrimType' a, PrimType' b) => Primitive (a :-> Full b) + I2B :: (Integral a, PrimType' a) => Primitive (a :-> Full Bool) + B2I :: (Integral a, PrimType' a) => Primitive (Bool :-> Full a) + Round :: (RealFrac a, Num b, PrimType' a, PrimType' b) => Primitive (a :-> Full b) + + Not :: Primitive (Bool :-> Full Bool) + And :: Primitive (Bool :-> Bool :-> Full Bool) + Or :: Primitive (Bool :-> Bool :-> Full Bool) + Eq :: (Eq a, PrimType' a) => Primitive (a :-> a :-> Full Bool) + NEq :: (Eq a, PrimType' a) => Primitive (a :-> a :-> Full Bool) + Lt :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool) + Gt :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool) + Le :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool) + Ge :: (Ord a, PrimType' a) => Primitive (a :-> a :-> Full Bool) + + BitAnd :: (Bits a, PrimType' a) => Primitive (a :-> a :-> Full a) + BitOr :: (Bits a, PrimType' a) => Primitive (a :-> a :-> Full a) + BitXor :: (Bits a, PrimType' a) => Primitive (a :-> a :-> Full a) + BitCompl :: (Bits a, PrimType' a) => Primitive (a :-> Full a) + ShiftL :: (Bits a, PrimType' a, Integral b, PrimType' b) => Primitive (a :-> b :-> Full a) + ShiftR :: (Bits a, PrimType' a, Integral b, PrimType' b) => Primitive (a :-> b :-> Full a) + + ArrIx :: PrimType' a => IArr Index a -> Primitive (Index :-> Full a) + + Cond :: Primitive (Bool :-> a :-> a :-> Full a) + +deriving instance Show (Primitive a) + +-- The `PrimType'` constraints on certain symbols require an explanation: The +-- constraints are actually not needed for anything in the modules in +-- `Feldspar.Primitive.*`, but they are needed by `Feldspar.Run.Compile`. They +-- guarantee to the compiler that these symbols don't operate on tuples. +-- +-- It would seem more consistent to have a `PrimType'` constraint on all +-- polymorphic symbols. However, this would prevent using some symbols for +-- non-primitive types in `Feldspar.Representation`. For example, `Lit` and +-- `Cond` are used `Feldspar.Representation`, and there they can also be used +-- for tuple types. The current design was chosen because it "just works". + +deriveSymbol ''Primitive + +instance Render Primitive + where + renderSym (FreeVar v) = v + renderSym (Lit a) = show a + renderSym (ArrIx (IArrComp arr)) = "ArrIx " ++ arr + renderSym (ArrIx _) = "ArrIx ..." + renderSym s = show s + + renderArgs = renderArgsSmart + +instance StringTree Primitive + +instance Eval Primitive + where + evalSym (FreeVar v) = error $ "evaluating free variable " ++ show v + evalSym (Lit a) = a + evalSym Add = (+) + evalSym Sub = (-) + evalSym Mul = (*) + evalSym Neg = negate + evalSym Abs = abs + evalSym Sign = signum + evalSym Quot = quot + evalSym Rem = rem + evalSym Div = div + evalSym Mod = mod + evalSym FDiv = (/) + evalSym Pi = pi + evalSym Exp = exp + evalSym Log = log + evalSym Sqrt = sqrt + evalSym Pow = (**) + evalSym Sin = sin + evalSym Cos = cos + evalSym Tan = tan + evalSym Asin = asin + evalSym Acos = acos + evalSym Atan = atan + evalSym Sinh = sinh + evalSym Cosh = cosh + evalSym Tanh = tanh + evalSym Asinh = asinh + evalSym Acosh = acosh + evalSym Atanh = atanh + evalSym Complex = (:+) + evalSym Polar = mkPolar + evalSym Real = realPart + evalSym Imag = imagPart + evalSym Magnitude = magnitude + evalSym Phase = phase + evalSym Conjugate = conjugate + evalSym I2N = fromInteger . toInteger + evalSym I2B = (/=0) + evalSym B2I = \a -> if a then 1 else 0 + evalSym Round = fromInteger . round + evalSym Not = not + evalSym And = (&&) + evalSym Or = (||) + evalSym Eq = (==) + evalSym NEq = (/=) + evalSym Lt = (<) + evalSym Gt = (>) + evalSym Le = (<=) + evalSym Ge = (>=) + evalSym BitAnd = (.&.) + evalSym BitOr = (.|.) + evalSym BitXor = xor + evalSym BitCompl = complement + evalSym ShiftL = \a -> shiftL a . fromIntegral + evalSym ShiftR = \a -> shiftR a . fromIntegral + evalSym Cond = \c t f -> if c then t else f + evalSym (ArrIx (IArrRun arr)) = \i -> + if ih + then error $ "ArrIx: index " + ++ show (toInteger i) + ++ " out of bounds " + ++ show (toInteger l, toInteger h) + else arr!i + where + (l,h) = bounds arr + evalSym (ArrIx (IArrComp arr)) = error $ "evaluating symbolic array " ++ arr + +-- | Assumes no occurrences of 'FreeVar' and concrete representation of arrays +instance EvalEnv Primitive env + +instance Equality Primitive + where + equal s1 s2 = show s1 == show s2 + -- NOTE: It is very important not to use `renderSym` here, because it will + -- render all concrete arrays equal. + + -- This method uses string comparison. It is probably slightly more + -- efficient to pattern match directly on the constructors. Unfortunately + -- `deriveEquality ''Primitive` doesn't work, so it gets quite tedious to + -- write it with pattern matching. + +type PrimDomain = Primitive :&: PrimTypeRep + +-- | Primitive expressions +newtype Prim a = Prim { unPrim :: ASTF PrimDomain a } + +instance Syntactic (Prim a) + where + type Domain (Prim a) = PrimDomain + type Internal (Prim a) = a + desugar = unPrim + sugar = Prim + +-- | Evaluate a closed expression +evalPrim :: Prim a -> a +evalPrim = go . unPrim + where + go :: AST PrimDomain sig -> Denotation sig + go (Sym (s :&: _)) = evalSym s + go (f :$ a) = go f $ go a + +sugarSymPrim + :: ( Signature sig + , fi ~ SmartFun dom sig + , sig ~ SmartSig fi + , dom ~ SmartSym fi + , dom ~ PrimDomain + , SyntacticN f fi + , sub :<: Primitive + , PrimType' (DenResult sig) + ) + => sub sig -> f +sugarSymPrim = sugarSymDecor primTypeRep + +instance FreeExp Prim + where + type FreePred Prim = PrimType' + constExp = sugarSymPrim . Lit + varExp = sugarSymPrim . FreeVar + +instance EvalExp Prim + where + evalExp = evalPrim + + + +-------------------------------------------------------------------------------- +-- * Interface +-------------------------------------------------------------------------------- + +instance (Num a, PrimType' a) => Num (Prim a) + where + fromInteger = constExp . fromInteger + (+) = sugarSymPrim Add + (-) = sugarSymPrim Sub + (*) = sugarSymPrim Mul + negate = sugarSymPrim Neg + abs = sugarSymPrim Abs + signum = sugarSymPrim Sign + diff --git a/src/Feldspar/Representation.hs b/src/Feldspar/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Representation.hs @@ -0,0 +1,433 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Internal representation of Feldspar programs + +module Feldspar.Representation where + + + +import Control.Monad.Reader +import Data.Complex +import Data.Hash (hashInt) +import Data.Int +import Data.List (genericTake) +import Data.Proxy +import Data.Typeable (Typeable) +import Data.Word + +import Data.Constraint (Dict (..)) + +import Language.Syntactic +import Language.Syntactic.Functional +import Language.Syntactic.Functional.Tuple +import Language.Syntactic.TH + +import qualified Control.Monad.Operational.Higher as Operational + +import qualified Language.Embedded.Expression as Imp +import qualified Language.Embedded.Imperative.CMD as Imp +import qualified Language.Embedded.Backend.C.Expression as Imp + +import Data.Inhabited +import Data.Selection +import Data.TypedStruct +import Feldspar.Primitive.Representation +import Feldspar.Primitive.Backend.C () + + + +-------------------------------------------------------------------------------- +-- * Object-language types +-------------------------------------------------------------------------------- + +-- | Representation of all supported types +type TypeRep = Struct PrimType' PrimTypeRep + +-- | Supported types +class (Eq a, Show a, Typeable a, Inhabited a) => Type a + where + -- | Reify a type + typeRep :: TypeRep a + +instance Type Bool where typeRep = Single BoolT +instance Type Int8 where typeRep = Single Int8T +instance Type Int16 where typeRep = Single Int16T +instance Type Int32 where typeRep = Single Int32T +instance Type Int64 where typeRep = Single Int64T +instance Type Word8 where typeRep = Single Word8T +instance Type Word16 where typeRep = Single Word16T +instance Type Word32 where typeRep = Single Word32T +instance Type Word64 where typeRep = Single Word64T +instance Type Float where typeRep = Single FloatT +instance Type Double where typeRep = Single DoubleT +instance Type (Complex Float) where typeRep = Single ComplexFloatT +instance Type (Complex Double) where typeRep = Single ComplexDoubleT +instance (Type a, Type b) => Type (a,b) where typeRep = Two typeRep typeRep + +-- | Alias for the conjunction of 'PrimType'' and 'Type' +class (PrimType' a, Type a) => PrimType a +instance (PrimType' a, Type a) => PrimType a + +instance Imp.CompTypeClass PrimType + where + compType _ = Imp.compType (Proxy :: Proxy PrimType') + compLit _ = Imp.compLit (Proxy :: Proxy PrimType') + -- This instance is used by + +-- | Convert any 'Struct' with a 'PrimType' constraint to a 'TypeRep' +toTypeRep :: Struct PrimType' c a -> TypeRep a +toTypeRep = mapStruct (const primTypeRep) + +-- | Check whether two type representations are equal +typeEq :: TypeRep a -> TypeRep b -> Maybe (Dict (a ~ b)) +typeEq (Single t) (Single u) = primTypeEq t u +typeEq (Two t1 t2) (Two u1 u2) = do + Dict <- typeEq t1 u1 + Dict <- typeEq t2 u2 + return Dict +typeEq _ _ = Nothing + +-- | Reflect a 'TypeRep' to a 'Typeable' constraint +witTypeable :: TypeRep a -> Dict (Typeable a) +witTypeable (Single t) + | Dict <- witPrimType t + = Dict +witTypeable (Two ta tb) + | Dict <- witTypeable ta + , Dict <- witTypeable tb + = Dict + +-- | Representation of supported value types + N-ary functions over such types +data TypeRepFun a + where + ValT :: TypeRep a -> TypeRepFun a + FunT :: TypeRep a -> TypeRepFun b -> TypeRepFun (a -> b) + -- Another option would have been to make `FunT` a constructor in `TypeRep`. + -- That would have got rid of the extra layer at the expense of less accurate + -- types (functions would be allowed in pairs, etc.). The current design was + -- chosen in order to be able to reuse `Struct` instead of making `TypeRep` a + -- new data type. + +-- | Check whether two type representations are equal +typeEqFun :: TypeRepFun a -> TypeRepFun b -> Maybe (Dict (a ~ b)) +typeEqFun (ValT t) (ValT u) = typeEq t u +typeEqFun (FunT ta tb) (FunT ua ub) = do + Dict <- typeEq ta ua + Dict <- typeEqFun tb ub + return Dict +typeEqFun _ _ = Nothing + +-- | Mutable variable +newtype Ref a = Ref { unRef :: Struct PrimType' Imp.Ref (Internal a) } + -- A reference to a tuple is a struct of smaller references. This means that + -- creating a reference to a tuple will generate several calls to generate new + -- references. This must be done already in the front end, which means that + -- the work in the back end becomes simpler. + -- + -- Another option would be to allow a single reference to refer to a tuple, + -- and then turn that into smaller references in the back end. However, this + -- would complicate the back end for no obvious reason. (One way to do it + -- would be to run the back end in a store that maps each front end reference + -- to a struct of small references. Among other things, that would require + -- dynamic typing.) + +-- | Reference specialized to 'Data' elements +type DRef a = Ref (Data a) + +instance Eq (Ref a) + where + Ref a == Ref b = and $ zipListStruct (==) a b + +-- | Mutable array +data Arr a = Arr + { arrOffset :: Data Index + , arrLength :: Data Length + , unArr :: Struct PrimType' (Imp.Arr Index) (Internal a) + } + -- `arrOffset` gives the offset into the internal arrays. The user should not + -- be able to access the offset or the internal arrays. + -- + -- `arrLength` gives the maximum index+1 according to the view provided by + -- `arrIx`. Thus, the maximum index in the internal arrays is + -- `arrLength + arrOffset - 1`. + -- `arrLength` should not be exported directly to prevent the user from using + -- record syntax to change the length of an array. But an equivalent function + -- can be exported. + + -- An array of tuples is represented as a struct of smaller arrays. See + -- comment to `Ref`. + +-- | Array specialized to 'Data' elements +type DArr a = Arr (Data a) + +-- | '==' checks if two 'Arr' use the same physical array. The length and offset +-- are ignored. +instance Eq (Arr a) + where + Arr _ _ arr1 == Arr _ _ arr2 = and (zipListStruct (==) arr1 arr2) + +-- | Immutable array +data IArr a = IArr + { iarrOffset :: Data Index + , iarrLength :: Data Length + , unIArr :: Struct PrimType' (Imp.IArr Index) (Internal a) + } + +-- | Immutable array specialized to 'Data' elements +type DIArr a = IArr (Data a) + +-- | Check if an 'Arr' and and 'IArr' use the same physical array. The length +-- and offset are ignored. This operation may give false negatives, but never +-- false positives. Whether or not false negatives occur may also depend on the +-- interpretation of the program. +-- +-- Due to this unreliability, the function should only be used to affect the +-- non-functional properties of a program (e.g. to avoid unnecessary array +-- copying). +unsafeEqArrIArr :: Arr a -> IArr a -> Bool +unsafeEqArrIArr (Arr _ _ arr1) (IArr _ _ arr2) = + and (zipListStruct sameId arr1 arr2) + where + sameId :: Imp.Arr Index a -> Imp.IArr Index a -> Bool + sameId (Imp.ArrComp a) (Imp.IArrComp i) = a==i + sameId _ _ = False + + + +-------------------------------------------------------------------------------- +-- * Pure expressions +-------------------------------------------------------------------------------- + +-- | Assertion labels +data AssertionLabel + = InternalAssertion + -- ^ Internal assertion to guarantee meaningful results + | LibraryAssertion String + -- ^ Assertion related to a specific library + | UserAssertion String + -- ^ Assertion in user code. The default label for user assertions is + -- @`UserAssertion` ""@ + deriving (Eq, Show) + +-- | A selection that includes all labels defined as 'UserAssertion' +onlyUserAssertions :: Selection AssertionLabel +onlyUserAssertions = selectBy $ \l -> case l of + UserAssertion _ -> True + _ -> False + +data ExtraPrimitive sig + where + -- Integer division assuming `divBalanced x y * y == x` (i.e. no remainder). + -- The purpose of the assumption is to use it in simplifications. + DivBalanced :: (Integral a, PrimType' a) => + ExtraPrimitive (a :-> a :-> Full a) + + -- Guard a value by an assertion + GuardVal :: + AssertionLabel -> String -> ExtraPrimitive (Bool :-> a :-> Full a) + +instance Eval ExtraPrimitive + where + evalSym DivBalanced = \a b -> if a `mod` b /= 0 + then error $ unwords ["divBalanced", show a, show b, "is not balanced"] + else div a b + evalSym (GuardVal _ msg) = \cond a -> + if cond then a else error $ "Feldspar assertion failure: " ++ msg + +instance EvalEnv ExtraPrimitive env + +instance Equality ExtraPrimitive + where + equal DivBalanced DivBalanced = True + equal (GuardVal _ _) (GuardVal _ _) = True + equal _ _ = False + + hash DivBalanced = hashInt 1 + hash (GuardVal _ _) = hashInt 2 + +instance StringTree ExtraPrimitive + +-- | For loop +data ForLoop sig + where + ForLoop :: Type st => + ForLoop (Length :-> st :-> (Index -> st -> st) :-> Full st) + +instance Eval ForLoop + where + evalSym ForLoop = \len init body -> + foldl (flip body) init $ genericTake len [0..] + +instance EvalEnv ForLoop env + +instance StringTree ForLoop + +-- | Interaction with the IO layer +data Unsafe sig + where + -- Turn a program into a pure value + UnsafePerform :: Comp (Data a) -> Unsafe (Full a) + +instance Render Unsafe + where + renderSym (UnsafePerform _) = "UnsafePerform ..." + +instance StringTree Unsafe + +instance Eval Unsafe + where + evalSym s = error $ "eval: cannot evaluate unsafe operation " ++ renderSym s + +instance EvalEnv Unsafe env + +-- | 'equal' always returns 'False' +instance Equality Unsafe + where + equal _ _ = False + +type FeldConstructs + = BindingT + :+: Let + :+: Tuple + :+: Primitive + :+: ExtraPrimitive + :+: ForLoop + :+: Unsafe + +type FeldDomain = FeldConstructs :&: TypeRepFun + +newtype Data a = Data { unData :: ASTF FeldDomain a } + +-- | Declaring 'Data' as syntactic sugar +instance Syntactic (Data a) + where + type Domain (Data a) = FeldDomain + type Internal (Data a) = a + desugar = unData + sugar = Data + +instance Syntactic (Struct PrimType' Data a) + -- Note that this instance places no constraints on `a`. This is crucial in + -- the way it is used in the rest of the code. It would be possible to + -- define `desugar` and `sugar` in terms of the instance for pairs; however, + -- that would require constraining `a`. + where + type Domain (Struct PrimType' Data a) = FeldDomain + type Internal (Struct PrimType' Data a) = a + + desugar (Single a) = unData a + desugar (Two a b) = sugarSymDecor (ValT $ Two ta tb) Pair a' b' + where + a' = desugar a + b' = desugar b + ValT ta = getDecor a' + ValT tb = getDecor b' + + sugar a = case getDecor a of + ValT (Single _) -> Single $ Data a + ValT (Two ta tb) -> + Two (sugarSymDecor (ValT ta) Fst a) (sugarSymDecor (ValT tb) Snd a) + +-- | Specialization of the 'Syntactic' class for the Feldspar domain +class (Syntactic a, Domain a ~ FeldDomain, Type (Internal a)) => Syntax a +instance (Syntactic a, Domain a ~ FeldDomain, Type (Internal a)) => Syntax a + +-- | Make a smart constructor for a symbol +sugarSymFeld + :: ( Signature sig + , fi ~ SmartFun FeldDomain sig + , sig ~ SmartSig fi + , FeldDomain ~ SmartSym fi + , SyntacticN f fi + , sub :<: FeldConstructs + , Type (DenResult sig) + ) + => sub sig -> f +sugarSymFeld = sugarSymDecor $ ValT typeRep + +-- | Make a smart constructor for a symbol +sugarSymFeldPrim + :: ( Signature sig + , fi ~ SmartFun FeldDomain sig + , sig ~ SmartSig fi + , FeldDomain ~ SmartSym fi + , SyntacticN f fi + , sub :<: FeldConstructs + , PrimType' (DenResult sig) + ) + => sub sig -> f +sugarSymFeldPrim = sugarSymDecor $ ValT $ Single primTypeRep + +-- | Evaluate a closed expression +eval :: (Syntactic a, Domain a ~ FeldDomain) => a -> Internal a +eval = evalClosed . desugar + -- Note that a `Syntax` constraint would rule out evaluating functions + +instance Imp.FreeExp Data + where + type FreePred Data = PrimType' + constExp = sugarSymFeldPrim . Lit + varExp = sugarSymFeldPrim . FreeVar + +instance Imp.EvalExp Data + where + evalExp = eval + + + +-------------------------------------------------------------------------------- +-- * Monadic computations +-------------------------------------------------------------------------------- + +data AssertCMD fs a + where + Assert + :: AssertionLabel + -> exp Bool + -> String + -> AssertCMD (Operational.Param3 prog exp pred) () + +instance Operational.HFunctor AssertCMD + where + hfmap _ (Assert c cond msg) = Assert c cond msg + +instance Operational.HBifunctor AssertCMD + where + hbimap _ g (Assert c cond msg) = Assert c (g cond) msg + +instance Operational.InterpBi AssertCMD IO (Operational.Param1 PrimType') + where + interpBi (Assert _ cond msg) = do + cond' <- cond + unless cond' $ error $ "Assertion failed: " ++ msg + +type CompCMD + = Imp.RefCMD + Operational.:+: Imp.ArrCMD + Operational.:+: Imp.ControlCMD + Operational.:+: AssertCMD + +-- | Monad for computational effects: mutable data structures and control flow +newtype Comp a = Comp + { unComp :: + Operational.Program CompCMD (Operational.Param2 Data PrimType') a + } + deriving (Functor, Applicative, Monad) + + + +-------------------------------------------------------------------------------- +-- Template Haskell instances +-------------------------------------------------------------------------------- + +deriveSymbol ''ExtraPrimitive +deriveRender id ''ExtraPrimitive + +deriveSymbol ''ForLoop +deriveRender id ''ForLoop +deriveEquality ''ForLoop + +deriveSymbol ''Unsafe + diff --git a/src/Feldspar/Run.hs b/src/Feldspar/Run.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Run.hs @@ -0,0 +1,43 @@ +-- | Monad for running Feldspar programs and C code back ends + +module Feldspar.Run + ( -- * Front end + module Feldspar + , module Feldspar.Run.Frontend + , module Feldspar.Run.Marshal + -- * Compilation options + , Selection, select, allExcept, selectBy + , CompilerOpts (..) + , ExternalCompilerOpts (..) + , Default (..) + -- * Back ends + , runIO + , compile' + , compile + , compileAll' + , compileAll + , icompile' + , icompile + , compileAndCheck' + , compileAndCheck + , runCompiled' + , runCompiled + , withCompiled' + , withCompiled + , captureCompiled' + , captureCompiled + , compareCompiled' + , compareCompiled + ) where + + + +import Language.Embedded.Backend.C (ExternalCompilerOpts (..), Default (..)) + +import Data.Selection +import Feldspar +import Feldspar.Run.Representation +import Feldspar.Run.Compile +import Feldspar.Run.Frontend +import Feldspar.Run.Marshal + diff --git a/src/Feldspar/Run/Compile.hs b/src/Feldspar/Run/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Run/Compile.hs @@ -0,0 +1,526 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Feldspar.Run.Compile where + + + +import Control.Monad.Identity +import Control.Monad.Reader +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.Constraint (Dict (..)) +import Data.Default.Class + +import Language.Syntactic hiding ((:+:) (..), (:<:) (..)) +import Language.Syntactic.Functional hiding (Binding (..)) +import Language.Syntactic.Functional.Tuple + +import qualified Control.Monad.Operational.Higher as Oper + +import Language.Embedded.Expression +import Language.Embedded.Imperative hiding ((:+:) (..), (:<:) (..)) +import Language.Embedded.Concurrent +import qualified Language.Embedded.Imperative as Imp +import Language.Embedded.Backend.C (ExternalCompilerOpts (..)) +import qualified Language.Embedded.Backend.C as Imp + +import Data.TypedStruct +import Data.Selection +import Feldspar.Primitive.Representation +import Feldspar.Primitive.Backend.C () +import Feldspar.Representation +import Feldspar.Run.Representation +import Feldspar.Optimize + + + +-------------------------------------------------------------------------------- +-- * Struct expressions and variables +-------------------------------------------------------------------------------- + +-- | Struct expression +type VExp = Struct PrimType' Prim + +-- | Struct expression with hidden result type +data VExp' + where + VExp' :: Struct PrimType' Prim a -> VExp' + +newRefV :: Monad m => TypeRep a -> String -> TargetT m (Struct PrimType' Imp.Ref a) +newRefV t base = lift $ mapStructA (const (newNamedRef base)) t + +initRefV :: Monad m => String -> VExp a -> TargetT m (Struct PrimType' Imp.Ref a) +initRefV base = lift . mapStructA (initNamedRef base) + +getRefV :: Monad m => Struct PrimType' Imp.Ref a -> TargetT m (VExp a) +getRefV = lift . mapStructA getRef + +setRefV :: Monad m => Struct PrimType' Imp.Ref a -> VExp a -> TargetT m () +setRefV r = lift . sequence_ . zipListStruct setRef r + +unsafeFreezeRefV :: Monad m => Struct PrimType' Imp.Ref a -> TargetT m (VExp a) +unsafeFreezeRefV = lift . mapStructA unsafeFreezeRef + + + +-------------------------------------------------------------------------------- +-- * Compilation options +-------------------------------------------------------------------------------- + +-- | Options affecting code generation +-- +-- A default set of options is given by 'def'. +-- +-- The assertion labels to include in the generated code can be stated using the +-- functions 'select', 'allExcept' and 'selectBy'. For example +-- +-- @`def` {compilerAssertions = `allExcept` [`InternalAssertion`]}@ +-- +-- states that we want to include all except internal assertions. +data CompilerOpts = CompilerOpts + { compilerAssertions :: Selection AssertionLabel + -- ^ Which assertions to include in the generated code + } + +instance Default CompilerOpts + where + def = CompilerOpts + { compilerAssertions = universal + } + + + +-------------------------------------------------------------------------------- +-- * Translation environment +-------------------------------------------------------------------------------- + +-- | Translation environment +data Env = Env + { envAliases :: Map Name VExp' + , envOptions :: CompilerOpts + } + +env0 :: Env +env0 = Env Map.empty def + +-- | Add a local alias to the environment +localAlias :: MonadReader Env m + => Name -- ^ Old name + -> VExp a -- ^ New expression + -> m b + -> m b +localAlias v e = + local (\env -> env {envAliases = Map.insert v (VExp' e) (envAliases env)}) + +-- | Lookup an alias in the environment +lookAlias :: MonadReader Env m => TypeRep a -> Name -> m (VExp a) +lookAlias t v = do + env <- asks envAliases + return $ case Map.lookup v env of + Nothing -> error $ "lookAlias: variable " ++ show v ++ " not in scope" + Just (VExp' e) -> case typeEq t (toTypeRep e) of Just Dict -> e + + + +-------------------------------------------------------------------------------- +-- * Translation of expressions +-------------------------------------------------------------------------------- + +type TargetCMD + = RefCMD + Imp.:+: ArrCMD + Imp.:+: ControlCMD + Imp.:+: ThreadCMD + Imp.:+: ChanCMD + Imp.:+: PtrCMD + Imp.:+: FileCMD + Imp.:+: C_CMD + +-- | Target monad during translation +type TargetT m = ReaderT Env (ProgramT TargetCMD (Param2 Prim PrimType') m) + +-- | Monad for translated program +type ProgC = Program TargetCMD (Param2 Prim PrimType') + +-- | Translate an expression +translateExp :: forall m a . Monad m => Data a -> TargetT m (VExp a) +translateExp a = do + cs <- asks (compilerAssertions . envOptions) + goAST $ optimize cs $ unData a + where + -- Assumes that `b` is not a function type + goAST :: ASTF FeldDomain b -> TargetT m (VExp b) + goAST = simpleMatch (\(s :&: ValT t) -> go t s) + + goSmallAST :: PrimType' b => ASTF FeldDomain b -> TargetT m (Prim b) + goSmallAST = fmap extractSingle . goAST + + go :: TypeRep (DenResult sig) + -> FeldConstructs sig + -> Args (AST FeldDomain) sig + -> TargetT m (VExp (DenResult sig)) + go t lit Nil + | Just (Lit a) <- prj lit + = return $ mapStruct (constExp . runIdentity) $ toStruct t a + go t lit Nil + | Just (Literal a) <- prj lit + = return $ mapStruct (constExp . runIdentity) $ toStruct t a + go t var Nil + | Just (VarT v) <- prj var + = lookAlias t v + go t lt (a :* (lam :$ body) :* Nil) + | Just (Let tag) <- prj lt + , Just (LamT v) <- prj lam + = do let base = if null tag then "let" else tag + r <- initRefV base =<< goAST a + a' <- unsafeFreezeRefV r + localAlias v a' $ goAST body + go t tup (a :* b :* Nil) + | Just Pair <- prj tup = Two <$> goAST a <*> goAST b + go t sel (ab :* Nil) + | Just Fst <- prj sel = do + Two a _ <- goAST ab + return a + | Just Snd <- prj sel = do + Two _ b <- goAST ab + return b + go _ c Nil + | Just Pi <- prj c = return $ Single $ sugarSymPrim Pi + go _ op (a :* Nil) + | Just Neg <- prj op = liftStruct (sugarSymPrim Neg) <$> goAST a + | Just Abs <- prj op = liftStruct (sugarSymPrim Abs) <$> goAST a + | Just Sign <- prj op = liftStruct (sugarSymPrim Sign) <$> goAST a + | Just Exp <- prj op = liftStruct (sugarSymPrim Exp) <$> goAST a + | Just Log <- prj op = liftStruct (sugarSymPrim Log) <$> goAST a + | Just Sqrt <- prj op = liftStruct (sugarSymPrim Sqrt) <$> goAST a + | Just Sin <- prj op = liftStruct (sugarSymPrim Sin) <$> goAST a + | Just Cos <- prj op = liftStruct (sugarSymPrim Cos) <$> goAST a + | Just Tan <- prj op = liftStruct (sugarSymPrim Tan) <$> goAST a + | Just Asin <- prj op = liftStruct (sugarSymPrim Asin) <$> goAST a + | Just Acos <- prj op = liftStruct (sugarSymPrim Acos) <$> goAST a + | Just Atan <- prj op = liftStruct (sugarSymPrim Atan) <$> goAST a + | Just Sinh <- prj op = liftStruct (sugarSymPrim Sinh) <$> goAST a + | Just Cosh <- prj op = liftStruct (sugarSymPrim Cosh) <$> goAST a + | Just Tanh <- prj op = liftStruct (sugarSymPrim Tanh) <$> goAST a + | Just Asinh <- prj op = liftStruct (sugarSymPrim Asinh) <$> goAST a + | Just Acosh <- prj op = liftStruct (sugarSymPrim Acosh) <$> goAST a + | Just Atanh <- prj op = liftStruct (sugarSymPrim Atanh) <$> goAST a + | Just Real <- prj op = liftStruct (sugarSymPrim Real) <$> goAST a + | Just Imag <- prj op = liftStruct (sugarSymPrim Imag) <$> goAST a + | Just Magnitude <- prj op = liftStruct (sugarSymPrim Magnitude) <$> goAST a + | Just Phase <- prj op = liftStruct (sugarSymPrim Phase) <$> goAST a + | Just Conjugate <- prj op = liftStruct (sugarSymPrim Conjugate) <$> goAST a + | Just I2N <- prj op = liftStruct (sugarSymPrim I2N) <$> goAST a + | Just I2B <- prj op = liftStruct (sugarSymPrim I2B) <$> goAST a + | Just B2I <- prj op = liftStruct (sugarSymPrim B2I) <$> goAST a + | Just Round <- prj op = liftStruct (sugarSymPrim Round) <$> goAST a + | Just Not <- prj op = liftStruct (sugarSymPrim Not) <$> goAST a + | Just BitCompl <- prj op = liftStruct (sugarSymPrim BitCompl) <$> goAST a + go _ op (a :* b :* Nil) + | Just Add <- prj op = liftStruct2 (sugarSymPrim Add) <$> goAST a <*> goAST b + | Just Sub <- prj op = liftStruct2 (sugarSymPrim Sub) <$> goAST a <*> goAST b + | Just Mul <- prj op = liftStruct2 (sugarSymPrim Mul) <$> goAST a <*> goAST b + | Just FDiv <- prj op = liftStruct2 (sugarSymPrim FDiv) <$> goAST a <*> goAST b + | Just Quot <- prj op = liftStruct2 (sugarSymPrim Quot) <$> goAST a <*> goAST b + | Just Rem <- prj op = liftStruct2 (sugarSymPrim Rem) <$> goAST a <*> goAST b + | Just Div <- prj op = liftStruct2 (sugarSymPrim Div) <$> goAST a <*> goAST b + | Just Mod <- prj op = liftStruct2 (sugarSymPrim Mod) <$> goAST a <*> goAST b + | Just Complex <- prj op = liftStruct2 (sugarSymPrim Complex) <$> goAST a <*> goAST b + | Just Polar <- prj op = liftStruct2 (sugarSymPrim Polar) <$> goAST a <*> goAST b + | Just Pow <- prj op = liftStruct2 (sugarSymPrim Pow) <$> goAST a <*> goAST b + | Just Eq <- prj op = liftStruct2 (sugarSymPrim Eq) <$> goAST a <*> goAST b + | Just And <- prj op = liftStruct2 (sugarSymPrim And) <$> goAST a <*> goAST b + | Just Or <- prj op = liftStruct2 (sugarSymPrim Or) <$> goAST a <*> goAST b + | Just Lt <- prj op = liftStruct2 (sugarSymPrim Lt) <$> goAST a <*> goAST b + | Just Gt <- prj op = liftStruct2 (sugarSymPrim Gt) <$> goAST a <*> goAST b + | Just Le <- prj op = liftStruct2 (sugarSymPrim Le) <$> goAST a <*> goAST b + | Just Ge <- prj op = liftStruct2 (sugarSymPrim Ge) <$> goAST a <*> goAST b + | Just BitAnd <- prj op = liftStruct2 (sugarSymPrim BitAnd) <$> goAST a <*> goAST b + | Just BitOr <- prj op = liftStruct2 (sugarSymPrim BitOr) <$> goAST a <*> goAST b + | Just BitXor <- prj op = liftStruct2 (sugarSymPrim BitXor) <$> goAST a <*> goAST b + | Just ShiftL <- prj op = liftStruct2 (sugarSymPrim ShiftL) <$> goAST a <*> goAST b + | Just ShiftR <- prj op = liftStruct2 (sugarSymPrim ShiftR) <$> goAST a <*> goAST b + go _ arrIx (i :* Nil) + | Just (ArrIx arr) <- prj arrIx = do + i' <- goSmallAST i + return $ Single $ sugarSymPrim (ArrIx arr) i' + go ty cond (c :* t :* f :* Nil) + | Just Cond <- prj cond = do + env <- ask + case (flip runReaderT env $ goAST t, flip runReaderT env $ goAST f) of + (t',f') -> do + tView <- lift $ lift $ Oper.viewT t' + fView <- lift $ lift $ Oper.viewT f' + case (tView,fView) of + (Oper.Return (Single tExp), Oper.Return (Single fExp)) -> do + c' <- goSmallAST c + return $ Single $ sugarSymPrim Cond c' tExp fExp + _ -> do + c' <- goSmallAST c + res <- newRefV ty "v" + ReaderT $ \env -> iff c' + (flip runReaderT env . setRefV res =<< t') + (flip runReaderT env . setRefV res =<< f') + unsafeFreezeRefV res + go t divBal (a :* b :* Nil) + | Just DivBalanced <- prj divBal + = liftStruct2 (sugarSymPrim Quot) <$> goAST a <*> goAST b + go t guard (cond :* a :* Nil) + | Just (GuardVal c msg) <- prj guard + = do cs <- asks (compilerAssertions . envOptions) + when (cs `includes` c) $ do + cond' <- extractSingle <$> goAST cond + lift $ assert cond' msg + goAST a + go t loop (len :* init :* (lami :$ (lams :$ body)) :* Nil) + | Just ForLoop <- prj loop + , Just (LamT iv) <- prj lami + , Just (LamT sv) <- prj lams + = do len' <- goSmallAST len + state <- initRefV "state" =<< goAST init + ReaderT $ \env -> for (0, 1, Excl len') $ \i -> flip runReaderT env $ do + s <- case t of + Single _ -> unsafeFreezeRefV state -- For non-compound states + _ -> getRefV state + s' <- localAlias iv (Single i) $ + localAlias sv s $ + goAST body + setRefV state s' + unsafeFreezeRefV state + go _ free Nil + | Just (FreeVar v) <- prj free = return $ Single $ sugarSymPrim $ FreeVar v + go t unsPerf Nil + | Just (UnsafePerform prog) <- prj unsPerf + = translateExp =<< + Oper.reexpressEnv unsafeTransSmallExp (Oper.liftProgram $ unComp prog) + go _ s _ = error $ "translateExp: no handling of symbol " ++ renderSym s + +-- | Translate an expression that is assumed to fulfill @`PrimType` a@ +unsafeTransSmallExp :: Monad m => Data a -> TargetT m (Prim a) +unsafeTransSmallExp a = do + Single b <- translateExp a + return b + -- This function should ideally have a `PrimType' a` constraint, but that is + -- not allowed when passing it to `reexpressEnv`. It should be possible to + -- make it work by changing the interface to `reexpressEnv`. + +translate :: Env -> Run a -> ProgC a +translate env + = Oper.interpretWithMonadT Oper.singleton id + -- fuse the monad stack + . flip runReaderT env . Oper.reexpressEnv unsafeTransSmallExp + -- compile outer monad + . Oper.interpretWithMonadT Oper.singleton + (lift . flip runReaderT env . Oper.reexpressEnv unsafeTransSmallExp) + -- compile inner monad + . unRun + +instance (Imp.ControlCMD Oper.:<: instr) => + Oper.Reexpressible AssertCMD instr Env + where + reexpressInstrEnv reexp (Assert c cond msg) = do + cs <- asks (compilerAssertions . envOptions) + when (cs `includes` c) $ + (reexp cond >>= lift . flip Imp.assert msg) + + + +-------------------------------------------------------------------------------- +-- * Back ends +-------------------------------------------------------------------------------- + +-- | Interpret a program in the 'IO' monad +runIO :: MonadRun m => m a -> IO a +runIO = Imp.runIO . translate env0 . liftRun + +-- | Interpret a program in the 'IO' monad +runIO' :: MonadRun m => m a -> IO a +runIO' + = Oper.interpretWithMonadBiT + (return . evalExp) + Oper.interpBi + (Imp.interpretBi (return . evalExp)) + . unRun + . liftRun + -- Unlike `runIO`, this function does the interpretation directly, without + -- first lowering the program. This might be faster, but I haven't done any + -- measurements to se if it is. + -- + -- One disadvantage with `runIO'` is that it cannot handle expressions + -- involving `IOSym`. But at the moment of writing this, we're not using those + -- symbols for anything anyway. + +-- | Like 'runIO' but with explicit input/output connected to @stdin@/@stdout@ +captureIO :: MonadRun m + => m a -- ^ Program to run + -> String -- ^ Input to send to @stdin@ + -> IO String -- ^ Result from @stdout@ +captureIO = Imp.captureIO . translate env0 . liftRun + +-- | Compile a program to C code represented as a string. To compile the +-- resulting C code, use something like +-- +-- > cc -std=c99 YOURPROGRAM.c +-- +-- This function returns only the first (main) module. To get all C translation +-- unit, use 'compileAll'. +compile' :: MonadRun m => CompilerOpts -> m a -> String +compile' opts = Imp.compile . translate (Env mempty opts) . liftRun + +-- | Compile a program to C code represented as a string. To compile the +-- resulting C code, use something like +-- +-- > cc -std=c99 YOURPROGRAM.c +-- +-- This function returns only the first (main) module. To get all C translation +-- unit, use 'compileAll'. +-- +-- By default, only assertions labeled with 'UserAssertion' will be included in +-- the generated code. +compile :: MonadRun m => m a -> String +compile = compile' def {compilerAssertions = onlyUserAssertions} + +-- | Compile a program to C modules, each one represented as a pair of a name +-- and the code represented as a string +-- +-- To compile the resulting C code, use something like +-- +-- > cc -std=c99 YOURPROGRAM.c +compileAll' :: MonadRun m => CompilerOpts -> m a -> [(String, String)] +compileAll' opts = Imp.compileAll . translate (Env mempty opts) . liftRun + +-- | Compile a program to C modules, each one represented as a pair of a name +-- and the code represented as a string +-- +-- To compile the resulting C code, use something like +-- +-- > cc -std=c99 YOURPROGRAM.c +-- +-- By default, only assertions labeled with 'UserAssertion' will be included in +-- the generated code. +compileAll :: MonadRun m => m a -> [(String, String)] +compileAll = compileAll' def {compilerAssertions = onlyUserAssertions} + +-- | Compile a program to C code and print it on the screen. To compile the +-- resulting C code, use something like +-- +-- > cc -std=c99 YOURPROGRAM.c +icompile' :: MonadRun m => CompilerOpts -> m a -> IO () +icompile' opts = Imp.icompile . translate (Env mempty opts) . liftRun + +-- | Compile a program to C code and print it on the screen. To compile the +-- resulting C code, use something like +-- +-- > cc -std=c99 YOURPROGRAM.c +-- +-- By default, only assertions labeled with 'UserAssertion' will be included in +-- the generated code. +icompile :: MonadRun m => m a -> IO () +icompile = icompile' def {compilerAssertions = onlyUserAssertions} + +-- | Generate C code and use CC to check that it compiles (no linking) +compileAndCheck' :: MonadRun m + => CompilerOpts + -> ExternalCompilerOpts + -> m a + -> IO () +compileAndCheck' opts eopts = + Imp.compileAndCheck' eopts . translate (Env mempty opts) . liftRun + +-- | Generate C code and use CC to check that it compiles (no linking) +-- +-- By default, all assertions will be included in the generated code. +compileAndCheck :: MonadRun m => m a -> IO () +compileAndCheck = compileAndCheck' def def + +-- | Generate C code, use CC to compile it, and run the resulting executable +runCompiled' :: MonadRun m + => CompilerOpts + -> ExternalCompilerOpts + -> m a + -> IO () +runCompiled' opts eopts = + Imp.runCompiled' eopts . translate (Env mempty opts) . liftRun + +-- | Generate C code, use CC to compile it, and run the resulting executable +-- +-- By default, all assertions will be included in the generated code. +runCompiled :: MonadRun m => m a -> IO () +runCompiled = runCompiled' def def + +-- | Compile a program and make it available as an 'IO' function from 'String' +-- to 'String' (connected to @stdin@/@stdout@. respectively). Note that +-- compilation only happens once, even if the 'IO' function is used many times +-- in the body. +withCompiled' :: MonadRun m + => CompilerOpts + -> ExternalCompilerOpts + -> m a -- ^ Program to compile + -> ((String -> IO String) -> IO b) + -- ^ Function that has access to the compiled executable as a function + -> IO b +withCompiled' opts eopts = + Imp.withCompiled' eopts . translate (Env mempty opts) . liftRun + +-- | Compile a program and make it available as an 'IO' function from 'String' +-- to 'String' (connected to @stdin@/@stdout@. respectively). Note that +-- compilation only happens once, even if the 'IO' function is used many times +-- in the body. +-- +-- By default, all assertions will be included in the generated code. +withCompiled :: MonadRun m + => m a -- ^ Program to compile + -> ((String -> IO String) -> IO b) + -- ^ Function that has access to the compiled executable as a function + -> IO b +withCompiled = withCompiled' def def {externalSilent = True} + +-- | Like 'runCompiled'' but with explicit input/output connected to +-- @stdin@/@stdout@. Note that the program will be compiled every time the +-- function is applied to a string. In order to compile once and run many times, +-- use the function 'withCompiled''. +captureCompiled' :: MonadRun m + => CompilerOpts + -> ExternalCompilerOpts + -> m a -- ^ Program to run + -> String -- ^ Input to send to @stdin@ + -> IO String -- ^ Result from @stdout@ +captureCompiled' opts eopts = + Imp.captureCompiled' eopts . translate (Env mempty opts) . liftRun + +-- | Like 'runCompiled' but with explicit input/output connected to +-- @stdin@/@stdout@. Note that the program will be compiled every time the +-- function is applied to a string. In order to compile once and run many times, +-- use the function 'withCompiled'. +-- +-- By default, all assertions will be included in the generated code. +captureCompiled :: MonadRun m + => m a -- ^ Program to run + -> String -- ^ Input to send to @stdin@ + -> IO String -- ^ Result from @stdout@ +captureCompiled = captureCompiled' def def + +-- | Compare the content written to @stdout@ from the reference program and from +-- running the compiled C code +compareCompiled' :: MonadRun m + => CompilerOpts + -> ExternalCompilerOpts + -> m a -- ^ Program to run + -> IO a -- ^ Reference program + -> String -- ^ Input to send to @stdin@ + -> IO () +compareCompiled' opts eopts = + Imp.compareCompiled' eopts . translate (Env mempty opts) . liftRun + +-- | Compare the content written to @stdout@ from the reference program and from +-- running the compiled C code +-- +-- By default, all assertions will be included in the generated code. +compareCompiled :: MonadRun m + => m a -- ^ Program to run + -> IO a -- ^ Reference program + -> String -- ^ Input to send to @stdin@ + -> IO () +compareCompiled = compareCompiled' def def + diff --git a/src/Feldspar/Run/Concurrent.hs b/src/Feldspar/Run/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Run/Concurrent.hs @@ -0,0 +1,248 @@ +module Feldspar.Run.Concurrent + ( ThreadId + , Chan, Closeable, Uncloseable + , Transferable (..), BulkTransferable (..) + , fork + , forkWithId + , asyncKillThread + , killThread + , waitThread + , delayThread + , closeChan + , lastChanReadOK + ) where + + + +import Prelude hiding ((&&)) +import Data.Proxy +import Data.TypedStruct + +import qualified Language.Embedded.Concurrent as Imp +import Language.Embedded.Concurrent (ThreadId, Chan, Closeable, Uncloseable) + +import Feldspar +import Feldspar.Representation +import Feldspar.Run.Representation + + + +-- | Fork off a computation as a new thread. +fork :: Run () -> Run ThreadId +fork = Run . Imp.fork . unRun + +-- | Fork off a computation as a new thread, with access to its own thread ID. +forkWithId :: (ThreadId -> Run ()) -> Run ThreadId +forkWithId f = Run $ Imp.forkWithId (unRun . f) + +-- | Forcibly terminate a thread, then continue execution immediately. +asyncKillThread :: ThreadId -> Run () +asyncKillThread = Run . Imp.asyncKillThread + +-- | Forcibly terminate a thread. Blocks until the thread is actually dead. +killThread :: ThreadId -> Run () +killThread = Run . Imp.killThread + +-- | Wait for a thread to terminate. +waitThread :: ThreadId -> Run () +waitThread = Run . Imp.waitThread + +-- | Sleep for a given amount of microseconds. Implemented with `usleep`. +-- A C compiler might require a feature test macro to be defined, +-- otherwise it emits a warning about an implicitly declared function. +-- For more details, see: http://man7.org/linux/man-pages/man3/usleep.3.html +delayThread :: Integral i => Data i -> Run () +delayThread = Run . Imp.delayThread + + +-------------------------------------------------------------------------------- +-- * 'Transferable' classes +-------------------------------------------------------------------------------- + +class Transferable a + where + -- | Size specification of a channel. In most of the cases, it is a natural + -- number representing how many elements could be stored at the same time + -- in the channel. + type SizeSpec a :: * + + -- | Maps a size specification to an internal channel size representation, + -- that is a map from primitive types to quantities. The byte size of the + -- channel will be calculated as the sum of multiplying the byte size of + -- each type with its quantity. + calcChanSize :: proxy a -> SizeSpec a -> Imp.ChanSize Data PrimType' Length + + -- | Create a new channel. Writing a reference type to a channel will copy + -- contents into the channel, so modifying it post-write is completely + -- safe. + newChan :: SizeSpec a -> Run (Chan Uncloseable a) + newChan = Run . Imp.newChan' . calcChanSize (Proxy :: Proxy a) + + newCloseableChan :: SizeSpec a -> Run (Chan Closeable a) + newCloseableChan = Run . Imp.newCloseableChan' . calcChanSize (Proxy :: Proxy a) + + -- | Read an element from a channel. If channel is empty, blocks until there + -- is an item available. + -- If 'closeChan' has been called on the channel *and* if the channel is + -- empty, @readChan@ returns an undefined value immediately. + readChan :: Chan t a -> Run a + readChan = untypedReadChan + + -- | Reads a value from any kind of channel. Instances should define this, + -- but the user should never call it. + untypedReadChan :: Chan t c -> Run a + + -- | Write a data element to a channel. + -- If 'closeChan' has been called on the channel, all calls to @writeChan@ + -- become non-blocking no-ops and return @False@, otherwise returns @True@. + -- If the channel is full, this function blocks until there's space in the + -- queue. + writeChan :: Chan t a -> a -> Run (Data Bool) + writeChan = untypedWriteChan + + -- | Writes a value to any kind of channel. Instances should define this, + -- but the user should never call it. + untypedWriteChan :: Chan t c -> a -> Run (Data Bool) + + +class Transferable a => BulkTransferable a + where + type ContainerType a :: * + + -- | Read an arbitrary number of elements from a channel into an array. + -- The semantics are the same as for 'readChan', where "channel is empty" + -- is defined as "channel contains less data than requested". + -- Returns @False@ without reading any data if the channel is closed. + readChanBuf :: Chan t a + -> Data Index -- ^ Offset in array to start writing + -> Data Index -- ^ Elements to read + -> (ContainerType a) + -> Run (Data Bool) + readChanBuf = untypedReadChanBuf (Proxy :: Proxy a) + + -- | Read an arbitrary number of elements from any channel into an array. + -- Instances should define this, but the user should never call it. + untypedReadChanBuf :: proxy a + -> Chan t c + -> Data Index -- ^ Offset in array to start writing + -> Data Index -- ^ Elements to read + -> (ContainerType a) + -> Run (Data Bool) + + -- | Write an arbitrary number of elements from an array into an channel. + -- The semantics are the same as for 'writeChan', where "channel is full" + -- is defined as "channel has insufficient free space to store all written + -- data". + writeChanBuf :: Chan t a + -> Data Index -- ^ Offset in array to start reading + -> Data Index -- ^ Elements to write + -> (ContainerType a) + -> Run (Data Bool) + writeChanBuf = untypedWriteChanBuf (Proxy :: Proxy a) + + -- | Write an arbitrary number of elements from an array into any channel. + -- Instances should define this, but the user should never call it. + untypedWriteChanBuf :: proxy a + -> Chan t c + -> Data Index -- ^ Offset in array to start reading + -> Data Index -- ^ Elements to write + -> (ContainerType a) + -> Run (Data Bool) + +-- | When 'readChan' was last called on the given channel, did the read +-- succeed? +-- Always returns @True@ unless 'closeChan' has been called on the channel. +-- Always returns @True@ if the channel has never been read. +lastChanReadOK :: Chan Closeable a -> Run (Data Bool) +lastChanReadOK = Run . Imp.lastChanReadOK + +-- | Close a channel. All subsequent write operations will be no-ops. +-- After the channel is drained, all subsequent read operations will be +-- no-ops as well. +closeChan :: Chan Closeable a -> Run () +closeChan = Run . Imp.closeChan + + +-------------------------------------------------------------------------------- +-- * 'Transferable' instances +-------------------------------------------------------------------------------- + +instance PrimType' a => Transferable (Data a) + where + type SizeSpec (Data a) = Data Length + calcChanSize _ sz = sz `Imp.timesSizeOf` (Proxy :: Proxy a) + untypedReadChan = Run . Imp.readChan' + untypedWriteChan c = Run . Imp.writeChan' c + +instance PrimType' a => BulkTransferable (Data a) + where + type ContainerType (Data a) = DArr a + untypedReadChanBuf _ c off len arr = do + r <- sequence $ listStruct (Run . Imp.readChanBuf' c off len) (unArr arr) + return $ foldl1 (&&) r + untypedWriteChanBuf _ c off len arr = do + r <- sequence $ listStruct (Run . Imp.writeChanBuf' c off len) (unArr arr) + return $ foldl1 (&&) r + +instance ( Transferable a, Transferable b + , SizeSpec a ~ SizeSpec b + ) => Transferable (a, b) + where + type SizeSpec (a, b) = SizeSpec a + calcChanSize _ sz = + let asz = calcChanSize (Proxy :: Proxy a) sz + bsz = calcChanSize (Proxy :: Proxy b) sz + in asz `Imp.plusSize` bsz + untypedReadChan ch = (,) <$> untypedReadChan ch <*> untypedReadChan ch + untypedWriteChan ch (a, b) = do + sa <- untypedWriteChan ch a + ifE sa (untypedWriteChan ch b) (return false) + +instance ( Transferable a, Transferable b, Transferable c + , SizeSpec a ~ SizeSpec b, SizeSpec b ~ SizeSpec c + ) => Transferable (a, b, c) + where + type SizeSpec (a, b, c) = SizeSpec a + calcChanSize _ sz = + let asz = calcChanSize (Proxy :: Proxy a) sz + bsz = calcChanSize (Proxy :: Proxy b) sz + csz = calcChanSize (Proxy :: Proxy c) sz + in asz `Imp.plusSize` bsz `Imp.plusSize` csz + untypedReadChan ch = (,,) + <$> untypedReadChan ch + <*> untypedReadChan ch + <*> untypedReadChan ch + untypedWriteChan ch (a, b, c) = do + sa <- untypedWriteChan ch a + ifE sa + (do sb <- untypedWriteChan ch b + ifE sb (untypedWriteChan ch c) (return false)) + (return false) + +instance ( Transferable a, Transferable b, Transferable c, Transferable d + , SizeSpec a ~ SizeSpec b, SizeSpec b ~ SizeSpec c, SizeSpec c ~ SizeSpec d + ) => Transferable (a, b, c, d) + where + type SizeSpec (a, b, c, d) = SizeSpec a + calcChanSize _ sz = + let asz = calcChanSize (Proxy :: Proxy a) sz + bsz = calcChanSize (Proxy :: Proxy b) sz + csz = calcChanSize (Proxy :: Proxy c) sz + dsz = calcChanSize (Proxy :: Proxy d) sz + in asz `Imp.plusSize` bsz `Imp.plusSize` csz `Imp.plusSize` dsz + untypedReadChan ch = (,,,) + <$> untypedReadChan ch + <*> untypedReadChan ch + <*> untypedReadChan ch + <*> untypedReadChan ch + untypedWriteChan ch (a, b, c, d) = do + sa <- untypedWriteChan ch a + ifE sa + (do sb <- untypedWriteChan ch b + ifE sb + (do sc <- untypedWriteChan ch c + ifE sc + (untypedWriteChan ch d) + (return false)) + (return false)) + (return false) diff --git a/src/Feldspar/Run/Frontend.hs b/src/Feldspar/Run/Frontend.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Run/Frontend.hs @@ -0,0 +1,267 @@ +-- | Monad for running Feldspar programs + +module Feldspar.Run.Frontend + ( Run + , MonadRun (..) + , module Feldspar.Run.Frontend + , module Language.Embedded.Imperative.Frontend.General + ) where + + + +import Language.Syntactic + +import qualified Control.Monad.Operational.Higher as Oper + +import Language.Embedded.Imperative.Frontend.General hiding (Ref, Arr, IArr) +import qualified Language.Embedded.Imperative as Imp +import qualified Language.Embedded.Imperative.CMD as Imp + +import Data.TypedStruct +import Feldspar.Primitive.Representation +import Feldspar.Primitive.Backend.C () +import Feldspar.Representation +import Feldspar.Run.Representation + + + +-------------------------------------------------------------------------------- +-- * Pointer operations +-------------------------------------------------------------------------------- + +-- | Swap two pointers +-- +-- This is generally an unsafe operation. E.g. it can be used to make a +-- reference to a data structure escape the scope of the data. +-- +-- The 'IsPointer' class ensures that the operation is only possible for types +-- that are represented as pointers in C. +unsafeSwap :: IsPointer a => a -> a -> Run () +unsafeSwap a b = Run $ Imp.unsafeSwap a b + +-- | Like 'unsafeSwap' but for arrays. The why we cannot use 'unsafeSwap' +-- directly is that 'Arr' cannot be made an instance of 'IsPointer'. +unsafeSwapArr :: Arr a -> Arr a -> Run () +unsafeSwapArr arr1 arr2 = Run $ sequence_ $ + zipListStruct Imp.unsafeSwap (unArr arr1) (unArr arr2) + -- An alternative would be to make a new `IsPointer` class for Feldspar + + + +-------------------------------------------------------------------------------- +-- * File handling +-------------------------------------------------------------------------------- + +-- | Open a file +fopen :: FilePath -> IOMode -> Run Handle +fopen file = Run . Imp.fopen file + +-- | Close a file +fclose :: Handle -> Run () +fclose = Run . Imp.fclose + +-- | Check for end of file +feof :: Handle -> Run (Data Bool) +feof = Run . Imp.feof + +class PrintfType r + where + fprf :: Handle -> String -> [Imp.PrintfArg Data] -> r + +instance (a ~ ()) => PrintfType (Run a) + where + fprf h form = Run . Oper.singleInj . Imp.FPrintf h form . reverse + +instance (Formattable a, PrimType a, PrintfType r) => PrintfType (Data a -> r) + where + fprf h form as = \a -> fprf h form (Imp.PrintfArg a : as) + +-- | Print to a handle. Accepts a variable number of arguments. +fprintf :: PrintfType r => Handle -> String -> r +fprintf h format = fprf h format [] + +-- | Put a primitive value to a handle +fput :: (Formattable a, PrimType a) + => Handle + -> String -- Prefix + -> Data a -- Expression to print + -> String -- Suffix + -> Run () +fput h pre e post = Run $ Imp.fput h pre e post + +-- | Get a primitive value from a handle +fget :: (Formattable a, PrimType a) => Handle -> Run (Data a) +fget = Run . Imp.fget + +-- | Print to @stdout@. Accepts a variable number of arguments. +printf :: PrintfType r => String -> r +printf = fprintf Imp.stdout + + + +-------------------------------------------------------------------------------- +-- * C-specific commands +-------------------------------------------------------------------------------- + +-- | Create a null pointer +newPtr :: PrimType a => Run (Ptr a) +newPtr = newNamedPtr "p" + +-- | Create a named null pointer +-- +-- The provided base name may be appended with a unique identifier to avoid name +-- collisions. +newNamedPtr :: PrimType a + => String -- ^ Base name + -> Run (Ptr a) +newNamedPtr = Run . Imp.newNamedPtr + +-- | Cast a pointer to an array +ptrToArr :: PrimType a => Ptr a -> Data Length -> Run (DArr a) +ptrToArr ptr len = fmap (Arr 0 len . Single) $ Run $ Imp.ptrToArr ptr + +-- | Create a pointer to an abstract object. The only thing one can do with such +-- objects is to pass them to 'callFun' or 'callProc'. +newObject + :: String -- ^ Object type + -> Bool -- ^ Pointed? + -> Run Object +newObject = newNamedObject "obj" + +-- | Create a pointer to an abstract object. The only thing one can do with such +-- objects is to pass them to 'callFun' or 'callProc'. +-- +-- The provided base name may be appended with a unique identifier to avoid name +-- collisions. +newNamedObject + :: String -- ^ Base name + -> String -- ^ Object type + -> Bool -- ^ Pointed? + -> Run Object +newNamedObject base t p = Run $ Imp.newNamedObject base t p + +-- | Add an @#include@ statement to the generated code +addInclude :: String -> Run () +addInclude = Run . Imp.addInclude + +-- | Add a global definition to the generated code +-- +-- Can be used conveniently as follows: +-- +-- > {-# LANGUAGE QuasiQuotes #-} +-- > +-- > import Feldspar.IO +-- > +-- > prog = do +-- > ... +-- > addDefinition myCFunction +-- > ... +-- > where +-- > myCFunction = [cedecl| +-- > void my_C_function( ... ) +-- > { +-- > // C code +-- > // goes here +-- > } +-- > |] +addDefinition :: Imp.Definition -> Run () +addDefinition = Run . Imp.addDefinition + +-- | Declare an external function +addExternFun :: PrimType res + => String -- ^ Function name + -> proxy res -- ^ Proxy for expression and result type + -> [FunArg Data PrimType'] -- ^ Arguments (only used to determine types) + -> Run () +addExternFun fun res args = Run $ Imp.addExternFun fun res args + +-- | Declare an external procedure +addExternProc + :: String -- ^ Procedure name + -> [FunArg Data PrimType'] -- ^ Arguments (only used to determine types) + -> Run () +addExternProc proc args = Run $ Imp.addExternProc proc args + +-- | Call a function +callFun :: PrimType a + => String -- ^ Function name + -> [FunArg Data PrimType'] -- ^ Arguments + -> Run (Data a) +callFun fun as = Run $ Imp.callFun fun as + +-- | Call a procedure +callProc + :: String -- ^ Function name + -> [FunArg Data PrimType'] -- ^ Arguments + -> Run () +callProc fun as = Run $ Imp.callProc fun as + +-- | Call a procedure and assign its result +callProcAssign :: Assignable obj + => obj -- ^ Object to which the result should be assigned + -> String -- ^ Procedure name + -> [FunArg Data PrimType'] -- ^ Arguments + -> Run () +callProcAssign obj fun as = Run $ Imp.callProcAssign obj fun as + +-- | Declare and call an external function +externFun :: PrimType res + => String -- ^ Procedure name + -> [FunArg Data PrimType'] -- ^ Arguments + -> Run (Data res) +externFun fun args = Run $ Imp.externFun fun args + +-- | Declare and call an external procedure +externProc + :: String -- ^ Procedure name + -> [FunArg Data PrimType'] -- ^ Arguments + -> Run () +externProc proc args = Run $ Imp.externProc proc args + +-- | Generate code into another translation unit +inModule :: String -> Run () -> Run () +inModule mod = Run . Imp.inModule mod . unRun + +-- | Get current time as number of seconds passed today +getTime :: Run (Data Double) +getTime = Run Imp.getTime + +-- | Constant string argument +strArg :: String -> FunArg Data PrimType' +strArg = Imp.strArg + +-- | Value argument +valArg :: PrimType' a => Data a -> FunArg Data PrimType' +valArg = Imp.valArg + +-- | Reference argument +refArg :: PrimType' (Internal a) => Ref a -> FunArg Data PrimType' +refArg (Ref r) = Imp.refArg (extractSingle r) + +-- | Mutable array argument +arrArg :: PrimType' (Internal a) => Arr a -> FunArg Data PrimType' +arrArg (Arr o _ a) = Imp.offset (Imp.arrArg (extractSingle a)) o + +-- | Immutable array argument +iarrArg :: PrimType' (Internal a) => IArr a -> FunArg Data PrimType' +iarrArg (IArr o _ a) = Imp.offset (Imp.iarrArg (extractSingle a)) o + +-- | Abstract object argument +objArg :: Object -> FunArg Data PrimType' +objArg = Imp.objArg + +-- | Named constant argument +constArg + :: String -- ^ Type + -> String -- ^ Named constant + -> FunArg Data PrimType' +constArg = Imp.constArg + +-- | Modifier that takes the address of another argument +addr :: FunArg Data PrimType' -> FunArg Data PrimType' +addr = Imp.addr + +-- | Modifier that dereferences another argument +deref :: FunArg Data PrimType' -> FunArg Data PrimType' +deref = Imp.deref + diff --git a/src/Feldspar/Run/Marshal.hs b/src/Feldspar/Run/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Run/Marshal.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Feldspar.Run.Marshal where + + + +import qualified Prelude +import Prelude hiding (length) + +import Data.Typeable + +import Feldspar +import Feldspar.Run.Representation +import Feldspar.Run.Compile +import Feldspar.Run.Frontend + +import Language.Embedded.Backend.C (ExternalCompilerOpts (..), Default (..)) + + + +newtype Parser a = Parser {runParser :: String -> (a, String)} + deriving (Functor) + +instance Applicative Parser + where + pure = return + (<*>) = ap + +instance Monad Parser + where + return a = Parser $ \s -> (a,s) + p >>= k = Parser $ \s -> let (a,s') = runParser p s in runParser (k a) s' + +readParser :: forall a . (Read a, Typeable a) => Parser a +readParser = Parser $ \s -> case reads s of + [(a,s')] -> (a,s') + _ -> error $ unwords + [ "toHaskell: cannot read" + , show s + , "as type" + , show (typeOf (undefined :: a)) + ] + +parse :: Parser a -> String -> a +parse = (fst .) . runParser + +-- | Serialization/deserialization of Haskell values +-- +-- The following property must hold for all @a@: +-- +-- > a = parse toHaskell (fromHaskell a) Prelude.== a +class MarshalHaskell a + where + -- | Serialize a Haskell value + fromHaskell :: a -> String + default fromHaskell :: Show a => a -> String + fromHaskell = show + + -- | Deserialize a Haskell value + toHaskell :: Parser a + default toHaskell :: (Read a, Typeable a) => Parser a + toHaskell = readParser + +instance MarshalHaskell Int +instance MarshalHaskell Int8 +instance MarshalHaskell Int16 +instance MarshalHaskell Int32 +instance MarshalHaskell Int64 +instance MarshalHaskell Word8 +instance MarshalHaskell Word16 +instance MarshalHaskell Word32 +instance MarshalHaskell Word64 +instance MarshalHaskell Float +instance MarshalHaskell Double + +instance MarshalHaskell (Complex Float) + where + fromHaskell (r :+ i) = fromHaskell (r,i) + toHaskell = fmap (uncurry (:+)) toHaskell + +instance MarshalHaskell (Complex Double) + where + fromHaskell (r :+ i) = fromHaskell (r,i) + toHaskell = fmap (uncurry (:+)) toHaskell + +instance (MarshalHaskell a, MarshalHaskell b) => MarshalHaskell (a,b) + where + fromHaskell (a,b) = unwords [fromHaskell a, fromHaskell b] + toHaskell = (,) <$> toHaskell <*> toHaskell + +instance (MarshalHaskell a, MarshalHaskell b, MarshalHaskell c) => MarshalHaskell (a,b,c) + where + fromHaskell (a,b,c) = unwords [fromHaskell a, fromHaskell b, fromHaskell c] + toHaskell = (,,) <$> toHaskell <*> toHaskell <*> toHaskell + +instance (MarshalHaskell a, MarshalHaskell b, MarshalHaskell c, MarshalHaskell d) => MarshalHaskell (a,b,c,d) + where + fromHaskell (a,b,c,d) = unwords [fromHaskell a, fromHaskell b, fromHaskell c, fromHaskell d] + toHaskell = (,,,) <$> toHaskell <*> toHaskell <*> toHaskell <*> toHaskell + +instance MarshalHaskell a => MarshalHaskell [a] + where + fromHaskell as = unwords $ show (Prelude.length as) : map fromHaskell as + + toHaskell = do + len <- toHaskell + replicateM len toHaskell + +-- | Serialization/deserialization of Feldspar values +class (MarshalHaskell (HaskellRep a)) => MarshalFeld a + where + -- | The Haskell representation of a Feldspar value + type HaskellRep a + + -- | Serialize a Feldspar value to a handle + fwrite :: Handle -> a -> Run () + + default fwrite :: (PrimType b, Formattable b, a ~ Data b) => + Handle -> a -> Run () + fwrite hdl i = fput hdl "" i "" + + -- | Deserialize a Feldspar value from a handle + fread :: Handle -> Run a + + default fread :: (PrimType b, Formattable b, a ~ Data b) => Handle -> Run a + fread = fget + +-- | Write a value to @stdout@ +writeStd :: MarshalFeld a => a -> Run () +writeStd = fwrite stdout + +-- | Read a value from @stdin@ +readStd :: MarshalFeld a => Run a +readStd = fread stdin + +instance MarshalFeld (Data Int8) where type HaskellRep (Data Int8) = Int8 +instance MarshalFeld (Data Int16) where type HaskellRep (Data Int16) = Int16 +instance MarshalFeld (Data Int32) where type HaskellRep (Data Int32) = Int32 +instance MarshalFeld (Data Int64) where type HaskellRep (Data Int64) = Int64 +instance MarshalFeld (Data Word8) where type HaskellRep (Data Word8) = Word8 +instance MarshalFeld (Data Word16) where type HaskellRep (Data Word16) = Word16 +instance MarshalFeld (Data Word32) where type HaskellRep (Data Word32) = Word32 +instance MarshalFeld (Data Word64) where type HaskellRep (Data Word64) = Word64 +instance MarshalFeld (Data Float) where type HaskellRep (Data Float) = Float +instance MarshalFeld (Data Double) where type HaskellRep (Data Double) = Double + +instance MarshalFeld (Data (Complex Float)) + where + type HaskellRep (Data (Complex Float)) = Complex Float + fwrite hdl c = fwrite hdl (realPart c, imagPart c) + fread = fmap (uncurry complex) . fread + +instance MarshalFeld (Data (Complex Double)) + where + type HaskellRep (Data (Complex Double)) = Complex Double + fwrite hdl c = fwrite hdl (realPart c, imagPart c) + fread = fmap (uncurry complex) . fread + +instance (MarshalFeld a, MarshalFeld b) => MarshalFeld (a,b) + where + type HaskellRep (a,b) = (HaskellRep a, HaskellRep b) + fwrite hdl (a,b) = fwrite hdl a >> fprintf hdl " " >> fwrite hdl b + fread hdl = (,) <$> fread hdl <*> fread hdl + +instance (MarshalFeld a, MarshalFeld b, MarshalFeld c) => MarshalFeld (a,b,c) + where + type HaskellRep (a,b,c) = (HaskellRep a, HaskellRep b, HaskellRep c) + fwrite hdl (a,b,c) + = fwrite hdl a >> fprintf hdl " " + >> fwrite hdl b >> fprintf hdl " " + >> fwrite hdl c + fread hdl = (,,) <$> fread hdl <*> fread hdl <*> fread hdl + +instance (MarshalFeld a, MarshalFeld b, MarshalFeld c, MarshalFeld d) => MarshalFeld (a,b,c,d) + where + type HaskellRep (a,b,c,d) = (HaskellRep a, HaskellRep b, HaskellRep c, HaskellRep d) + fwrite hdl (a,b,c,d) + = fwrite hdl a >> fprintf hdl " " + >> fwrite hdl b >> fprintf hdl " " + >> fwrite hdl c >> fprintf hdl " " + >> fwrite hdl d + fread hdl = (,,,) <$> fread hdl <*> fread hdl <*> fread hdl <*> fread hdl + +instance (MarshalHaskell (Internal a), MarshalFeld a, Syntax a) => + MarshalFeld (Arr a) + where + type HaskellRep (Arr a) = [Internal a] + + fwrite hdl arr = do + len <- shareM $ length arr + fput hdl "" len " " + for (0,1,Excl len) $ \i -> do + a <- getArr arr i + fwrite hdl a + fprintf hdl " " + + fread hdl = do + len <- fget hdl + arr <- newArr len + for (0,1,Excl len) $ \i -> do + a <- fread hdl + setArr arr i a + return arr + +instance (MarshalHaskell (Internal a), MarshalFeld a, Syntax a) => + MarshalFeld (IArr a) + where + type HaskellRep (IArr a) = [Internal a] + + fwrite hdl arr = do + len <- shareM $ length arr + fput hdl "" len " " + for (0,1,Excl len) $ \i -> do + fwrite hdl $ arrIx arr i + fprintf hdl " " + + fread hdl = do + len <- fget hdl + arr <- newArr len + for (0,1,Excl len) $ \i -> do + a <- fread hdl + setArr arr i a + iarr <- unsafeFreezeArr arr + return iarr + +-- | Connect a Feldspar function between serializable types to @stdin@/@stdout@ +connectStdIO :: (MarshalFeld a, MarshalFeld b) => (a -> Run b) -> Run () +connectStdIO f = (readStd >>= f) >>= writeStd + +-- | A version of 'marshalled' that takes 'ExternalCompilerOpts' as additional +-- argument +marshalled' :: (MarshalFeld a, MarshalFeld b) + => CompilerOpts + -> ExternalCompilerOpts + -> (a -> Run b) -- ^ Function to compile + -> ((HaskellRep a -> IO (HaskellRep b)) -> IO c) + -- ^ Function that has access to the compiled executable as a function + -> IO c +marshalled' opts eopts f body = + withCompiled' opts eopts (connectStdIO f) $ \g -> + body (fmap (parse toHaskell) . g . fromHaskell) + +-- | Compile a function and make it available as an 'IO' function. Note that +-- compilation only happens once, even if the function is used many times in the +-- body. +-- +-- For example, given the following Feldspar function: +-- +-- > sumArr :: DIArr Int32 -> Run (Data Int32) +-- > sumArr arr = do +-- > r <- initRef 0 +-- > for (0,1,Excl $ length arr) $ \i -> modifyRef r (+ arrIx arr i) +-- > unsafeFreezeRef r +-- +-- 'marshalled' can be used as follows: +-- +-- > *Main> marshalled sumArr $ \f -> (f [3,4,5] >>= print) >> (f [6,7,8,9] >>= print) +marshalled :: (MarshalFeld a, MarshalFeld b) + => (a -> Run b) -- ^ Function to compile + -> ((HaskellRep a -> IO (HaskellRep b)) -> IO c) + -- ^ Function that has access to the compiled executable as a function + -> IO c +marshalled = marshalled' def def + diff --git a/src/Feldspar/Run/Representation.hs b/src/Feldspar/Run/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Run/Representation.hs @@ -0,0 +1,50 @@ +-- | Monad for running Feldspar programs + +module Feldspar.Run.Representation where + + + +import Control.Monad.Trans + +import Language.Embedded.Imperative as Imp +import Language.Embedded.Concurrent + +import Feldspar.Primitive.Representation +import Feldspar.Representation +import Feldspar.Frontend + + + +type RunCMD + = ControlCMD + :+: PtrCMD + :+: ThreadCMD + :+: ChanCMD + :+: FileCMD + :+: C_CMD + +-- | Monad for running Feldspar programs +newtype Run a = Run + { unRun :: + ProgramT + RunCMD + (Param2 Data PrimType') + (Program CompCMD (Param2 Data PrimType')) + a + } + deriving (Functor, Applicative, Monad) + +instance MonadComp Run + where + liftComp = Run . lift . unComp + iff c t f = Run $ Imp.iff c (unRun t) (unRun f) + for range body = Run $ Imp.for range (unRun . body) + while cont body = Run $ Imp.while (unRun cont) (unRun body) + +class Monad m => MonadRun m + where + liftRun :: m a -> Run a + +instance MonadRun Comp where liftRun = liftComp +instance MonadRun Run where liftRun = id + diff --git a/src/Feldspar/Sugar.hs b/src/Feldspar/Sugar.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Sugar.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | 'Syntactic' instances for functions and tuples + +module Feldspar.Sugar where + + + +import qualified Language.Haskell.TH as TH + +import Language.Syntactic +import Language.Syntactic.TH +import Language.Syntactic.Functional +import Language.Syntactic.Functional.Tuple +import Language.Syntactic.Functional.Tuple.TH + +import Feldspar.Representation + + + +instance (Syntax a, Syntactic b, Domain b ~ FeldDomain) => Syntactic (a -> b) + where + type Domain (a -> b) = FeldDomain + type Internal (a -> b) = Internal a -> Internal b + desugar f = lamT_template varSym lamSym (desugar . f . sugar) + where + varSym v = inj (VarT v) :&: ValT typeRep + lamSym v b = Sym (inj (LamT v) :&: FunT typeRep (getDecor b)) :$ b + sugar = error "sugar not implemented for (a -> b)" + +instance (Syntax a, Syntax b) => Syntactic (a,b) + where + type Domain (a,b) = FeldDomain + type Internal (a,b) = (Internal a, Internal b) + desugar (a,b) = sugarSymFeld Pair (desugar a) (desugar b) + sugar ab = (sugarSymFeld Fst ab, sugarSymFeld Snd ab) + +deriveSyntacticForTuples + (return . classPred ''Type TH.ConT . return) + (\sym -> foldl TH.AppT (TH.ConT ''(:&:)) [sym, TH.ConT ''TypeRepFun]) + [foldl TH.AppT TH.EqualityT + [TH.VarT (TH.mkName "sym"), TH.ConT ''FeldConstructs] + ] + 15 + diff --git a/tests/Compilation.hs b/tests/Compilation.hs new file mode 100644 --- /dev/null +++ b/tests/Compilation.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +import qualified Prelude +import Control.Monad.Trans + +import Feldspar.Run +import Feldspar.Data.Vector +import Feldspar.Data.Option + + + +-------------------------------------------------------------------------------- +-- * Option +-------------------------------------------------------------------------------- + +-- | Safe indexing in a 'Manifest' vector +indexO :: (Syntax a, Monad m) => Manifest a -> Data Index -> OptionT m a +indexO vec i = guarded "indexO: out of bounds" (i Manifest (Data Int32) -> Data Index -> OptionT m (Data Int32) +funO vec i = do + a <- indexO vec i + b <- indexO vec (i+1) + c <- indexO vec (i+2) + d <- indexO vec (i+4) + return (a+b+c+d) + +test_option :: Run () +test_option = do + vec <- manifestFresh $ fmap i2n (1...10) + i <- readStd + printf "%d\n" $ fromSome $ funO vec i + +test_optionM :: Run () +test_optionM = do + vec <- manifestFresh $ fmap i2n (1...10) + i <- readStd + caseOptionM (funO vec i) + printf + (printf "%d\n") + +readPositive :: OptionT Run (Data Int32) +readPositive = do + i <- lift readStd + guarded "negative" (i>=0) i + +test_optionT = optionT printf (\_ -> return ()) $ do + vec <- manifestFresh $ fmap i2n (1...10) + len <- readPositive + sumr <- initRef (0 :: Data Int32) + for (0, 1, Excl len) $ \i -> do + lift $ printf "reading index %d\n" i + x <- indexO vec (i2n i) + modifyRef sumr (+x) + s <- unsafeFreezeRef sumr + lift $ printf "%d" s + + + +-------------------------------------------------------------------------------- +-- * Misc. +-------------------------------------------------------------------------------- + +-- Test that constant folding does not attempt to fold array indexing +test_constFoldArr :: Run () +test_constFoldArr = do + arr <- constIArr [1..10] + let a = (arrIx arr 0 == arrIx arr 1) ? arrIx arr 100 $ arrIx arr 2 + printf "%d\n" (a :: Data Int32) + + + +-------------------------------------------------------------------------------- + +main = do + tag "test_option" >> compareCompiled test_option (runIO test_option) "5\n" + tag "test_option" >> compareCompiled test_option (runIO test_option) "6\n" + tag "test_optionM" >> compareCompiled test_optionM (runIO test_option) "5\n" + tag "test_optionM" >> compareCompiled test_optionM (runIO test_optionM) "6\n" + tag "test_optionT" >> compareCompiled test_optionT (runIO test_optionT) "10\n" + tag "test_constFoldArr" >> compareCompiled test_constFoldArr (runIO test_constFoldArr) "" + where + tag str = putStrLn $ "---------------- examples/Demo.hs/" Prelude.++ str Prelude.++ "\n" + diff --git a/tests/Examples.hs b/tests/Examples.hs new file mode 100644 --- /dev/null +++ b/tests/Examples.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +import qualified Prelude + +import qualified Data.Complex as Complex + +import Feldspar.Run +import Feldspar.Data.Vector +import Feldspar.Data.Buffered + +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.Monadic as QC + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import qualified Tut1_HelloWorld as Tut1 +import qualified Tut2_ExpressionsAndTypes as Tut2 +import qualified Tut3_Vectors as Tut3 +import qualified Tut4_MemoryManagement as Tut4 +import qualified Tut5_Matrices as Tut5 +import qualified Tut6_Testing as Tut6 +import qualified Tut7_ImperativeProgramming as Tut7 +import qualified Concurrent +import DFT +import FFT + + + +almostEq a b + = Complex.magnitude d Prelude.< 1e-7 + Prelude.&& Complex.phase d Prelude.< 1e-7 + where + d = abs (a-b) + +a ~= b = Prelude.and $ Prelude.zipWith almostEq a b + +wrapStore :: (Syntax a, Finite (vec a), MonadComp m) => + (Store a -> vec a -> m b) -> vec a -> m b +wrapStore f v = do + st <- newStore $ length v + f st v + +fftS = wrapStore fft :: DManifest (Complex Double) -> _ +ifftS = wrapStore ifft :: DManifest (Complex Double) -> _ + +prop_fft_dft dft' fft' = QC.monadicIO $ do + n :: Int <- QC.pick $ QC.choose (2,5) + inp :: [Complex Double] <- QC.pick $ QC.vector (2 Prelude.^ n) + outd <- QC.run $ dft' inp + outf <- QC.run $ fft' inp + QC.assert (outd ~= outf) + +prop_inverse f fi = QC.monadicIO $ do + n :: Int <- QC.pick $ QC.choose (2,5) + inp :: [Complex Double] <- QC.pick $ QC.vector (2 Prelude.^ n) + out1 <- QC.run $ f inp + out2 <- QC.run $ fi out1 + QC.assert (inp ~= out2) + +main = + marshalledM (return . dft) $ \dft' -> + marshalledM (return . idft) $ \idft' -> + marshalledM fftS $ \fft' -> + marshalledM ifftS $ \ifft' -> + + defaultMain $ testGroup "tests" + [ testCase "Tut1" Tut1.testAll + , testCase "Tut2" Tut2.testAll + , testCase "Tut3" Tut3.testAll + , testCase "Tut4" Tut4.testAll + , testCase "Tut5" Tut5.testAll + , testCase "Tut6" Tut6.testAll + , testCase "Tut7" Tut7.testAll + , testCase "Concurrent" Concurrent.testAll + , testProperty "fft_dft" $ prop_fft_dft dft' fft' + , testProperty "dft_idft" $ prop_inverse dft' idft' + , testProperty "fft_ifft" $ prop_inverse fft' ifft' + ] + + where + marshalledM = marshalled' def def {externalFlagsPost = ["-lm"]} + diff --git a/tests/NumSimpl.hs b/tests/NumSimpl.hs new file mode 100644 --- /dev/null +++ b/tests/NumSimpl.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} + +import Control.Monad +import Data.Dynamic +import Data.Int +import Data.Word + +import Test.Tasty.QuickCheck +import Test.Tasty.TH + +import Language.Syntactic +import Language.Syntactic.Functional + +import Feldspar.Representation +import Feldspar.Optimize +import Feldspar.Frontend () + + + +data NumExp + = VAR Int + | INT Int + | ADD NumExp NumExp + | SUB NumExp NumExp + | MUL NumExp NumExp + | NEG NumExp + deriving (Eq, Show) + +evalNumExp :: Num a => (Int -> a) -> NumExp -> a +evalNumExp env (VAR v) = env v +evalNumExp env (INT i) = fromIntegral i +evalNumExp env (ADD a b) = evalNumExp env a + evalNumExp env b +evalNumExp env (SUB a b) = evalNumExp env a - evalNumExp env b +evalNumExp env (MUL a b) = evalNumExp env a * evalNumExp env b +evalNumExp env (NEG a) = negate (evalNumExp env a) + +num2AST :: (Num a, PrimType a) => NumExp -> ASTF FeldDomain a +num2AST = simplify mempty . unData . + evalNumExp (\v -> sugarSymFeld $ VarT $ fromIntegral v) + +genNumExp :: Gen NumExp +genNumExp = sized go + where + go s = frequency + [ -- Variable + (1, do v <- choose (0,4) + return $ VAR v + ) + -- Literal + , (1, fmap INT $ elements [-100 .. 100]) + , (s, binOp ADD) + , (s, binOp SUB) + , (s, binOp MUL) + , (s, unOp NEG) + ] + where + binOp op = liftM2 op (go (s `div` 2)) (go (s `div` 2)) + unOp op = liftM op (go (s-1)) + +instance Arbitrary NumExp + where + arbitrary = genNumExp + + shrink (ADD a b) = a : b : [ADD a' b | a' <- shrink a] ++ [ADD a b' | b' <- shrink b] + shrink (SUB a b) = a : b : [SUB a' b | a' <- shrink a] ++ [SUB a b' | b' <- shrink b] + shrink (MUL a b) = a : b : [MUL a' b | a' <- shrink a] ++ [MUL a b' | b' <- shrink b] + shrink (NEG a) = a : [NEG a' | a' <- shrink a] + shrink _ = [] + +-- Test that numeric expressions are simplified correctly +prop_numExp :: (a ~ Int32) => (a,a,a,a,a) -> NumExp -> Bool +prop_numExp (a,b,c,d,e) numExp = + evalNumExp env1 numExp == evalOpen env2 (num2AST numExp) + where + env1 v = [a,b,c,d,e] !! v + env2 = zip ([0..] :: [Name]) $ map toDyn [a,b,c,d,e] + +-- Test that inexact numeric expressions are handled correctly +-- +-- This property fails if one changes `isExact` to `const True` +prop_numExp_inexact :: (a ~ Float) => (a,a,a,a,a) -> NumExp -> Bool +prop_numExp_inexact (a,b,c,d,e) numExp = + evalNumExp env1 numExp == evalOpen env2 (num2AST numExp) + where + env1 v = [a,b,c,d,e] !! v + env2 = zip ([0..] :: [Name]) $ map toDyn [a,b,c,d,e] + +prop_simplify_idempotent_int :: NumExp -> Property +prop_simplify_idempotent_int exp = counterexample (unlines [show e, show $ simplify mempty e]) + $ e == simplify mempty e + where + e :: ASTF FeldDomain Int32 + e = num2AST exp + +prop_simplify_idempotent_word :: NumExp -> Bool +prop_simplify_idempotent_word exp = e == simplify mempty e + where + e :: ASTF FeldDomain Word32 + e = num2AST exp + +prop_simplify_idempotent_double :: NumExp -> Bool +prop_simplify_idempotent_double exp = e == simplify mempty e + where + e :: ASTF FeldDomain Double + e = num2AST exp + +main = $defaultMainGenerator + diff --git a/tests/Semantics.hs b/tests/Semantics.hs new file mode 100644 --- /dev/null +++ b/tests/Semantics.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +import qualified Prelude + +import Data.List (genericIndex, genericLength) + +import qualified Test.QuickCheck.Monadic as QC + +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.TH + +import Feldspar.Run +import Feldspar.Data.Array + + + +generic_prop_marshalHaskell a = parse toHaskell (fromHaskell a) Prelude.== a + +prop_marshalHaskell_Int8 a = generic_prop_marshalHaskell (a :: Int8) +prop_marshalHaskell_Int16 a = generic_prop_marshalHaskell (a :: Int16) +prop_marshalHaskell_Int32 a = generic_prop_marshalHaskell (a :: Int32) +prop_marshalHaskell_Int64 a = generic_prop_marshalHaskell (a :: Int64) +prop_marshalHaskell_Word8 a = generic_prop_marshalHaskell (a :: Word8) +prop_marshalHaskell_Word16 a = generic_prop_marshalHaskell (a :: Word16) +prop_marshalHaskell_Word32 a = generic_prop_marshalHaskell (a :: Word32) +prop_marshalHaskell_Word64 a = generic_prop_marshalHaskell (a :: Word64) +prop_marshalHaskell_Float a = generic_prop_marshalHaskell (a :: Float) +prop_marshalHaskell_Double a = generic_prop_marshalHaskell (a :: Double) +prop_marshalHaskell_CompFloat a = generic_prop_marshalHaskell (a :: Complex Float) +prop_marshalHaskell_CompDouble a = generic_prop_marshalHaskell (a :: Complex Double) +prop_marshalHaskell_List a = generic_prop_marshalHaskell (a :: [Double]) +prop_marshalHaskell_Pair a = generic_prop_marshalHaskell (a :: (Word8,Double)) +prop_marshalHaskell_Nested a = generic_prop_marshalHaskell (a :: ([Double],(Int8,[Complex Float]))) +prop_marshalHaskell_ListOfList a = generic_prop_marshalHaskell (a :: [(Int8,[Word8])]) + +property_marshalFeld f a = QC.monadicIO $ do + b <- QC.run $ f a + QC.assert (a Prelude.== b) + +-- | Indexing in a 3-dimensional structure +nestIndex + :: ( DIArr Int32 + , (Data Length, Data Length, Data Length) + , (Data Index, Data Index, Data Index) + ) + -> Run (Data Int32) +nestIndex (arr,(l1,l2,l3),(i1,i2,i3)) = return $ nestedArr ! i1 ! i2 ! i3 + where + nestedArr = multiNest (Outer :> l2 :> l3) arr + +property_nestIndex f = + forAll genLenIx $ \(l1,i1) -> + forAll genLenIx $ \(l2,i2) -> + forAll genLenIx $ \(l3,i3) -> + let l = Prelude.fromIntegral (l1*l2*l3) + in forAll (vector l) $ \(as :: [Int32]) -> QC.monadicIO $ do + a <- QC.run $ f (as,(l1,l2,l3),(i1,i2,i3)) + QC.assert (a Prelude.== genericIndex as (i1*l2*l3 + i2*l3 + i3)) + where + genLenIx = do + l <- choose (1,5) + i <- choose (0,l-1) + return (l,i) + +-- | Indexing in a 3-dimensional structure +nestIndexLength + :: ( DIArr Int32 + , (Data Length, Data Length, Data Length) + , (Data Index, Data Index) + ) + -> Run (DIArr Int32) +nestIndexLength (arr,(l1,l2,l3),(i1,i2)) = return $ nestedArr ! i1 ! i2 + where + nestedArr = multiNest (Outer :> l2 :> l3) arr + +property_nestIndexLength f = + forAll genLenIx $ \(l1,i1) -> + forAll genLenIx $ \(l2,i2) -> + forAll (choose (1,5)) $ \l3 -> + let l = Prelude.fromIntegral (l1*l2*l3) + in forAll (vector l) $ \(as :: [Int32]) -> QC.monadicIO $ do + bs <- QC.run $ f (as,(l1,l2,l3),(i1,i2)) + QC.assert (genericLength bs Prelude.== l3) + where + genLenIx = do + l <- choose (1,5) + i <- choose (0,l-1) + return (l,i) + +main = + marshalled (return :: _ -> Run (Data Int8)) $ \f_Int8 -> + marshalled (return :: _ -> Run (Data Int16)) $ \f_Int16 -> + marshalled (return :: _ -> Run (Data Int32)) $ \f_Int32 -> + marshalled (return :: _ -> Run (Data Int64)) $ \f_Int64 -> + marshalled (return :: _ -> Run (Data Word8)) $ \f_Word8 -> + marshalled (return :: _ -> Run (Data Word16)) $ \f_Word16 -> + marshalled (return :: _ -> Run (Data Word32)) $ \f_Word32 -> + marshalled (return :: _ -> Run (Data Word64)) $ \f_Word64 -> + marshalled (return :: _ -> Run (Data Float)) $ \f_Float -> + marshalled (return :: _ -> Run (Data Double)) $ \f_Double -> + marshalled (return :: _ -> Run (Data (Complex Float))) $ \f_CompFloat -> + marshalled (return :: _ -> Run (Data (Complex Double))) $ \f_CompDouble -> + marshalled (return :: _ -> Run (DArr Double)) $ \f_Arr -> + marshalled (return :: _ -> Run (DIArr Int32)) $ \f_IArr -> + marshalled (return :: _ -> Run (Data Word8, Data Double)) $ \f_Pair -> + marshalled (return :: _ -> Run (DIArr Double, (Data Int8, DArr (Complex Float)))) $ \f_Nested -> + + marshalled nestIndex $ \nestIndex_c -> + marshalled nestIndexLength $ \nestIndexLength_c -> + + defaultMain $ testGroup "tests" + [ $testGroupGenerator + , testGroup "marshalFeld" + [ testProperty "marshalFeld Int8" $ property_marshalFeld f_Int8 + , testProperty "marshalFeld Int16" $ property_marshalFeld f_Int16 + , testProperty "marshalFeld Int32" $ property_marshalFeld f_Int32 + , testProperty "marshalFeld Int64" $ property_marshalFeld f_Int64 + , testProperty "marshalFeld Word8" $ property_marshalFeld f_Word8 + , testProperty "marshalFeld Word16" $ property_marshalFeld f_Word16 + , testProperty "marshalFeld Word32" $ property_marshalFeld f_Word32 + , testProperty "marshalFeld Word64" $ property_marshalFeld f_Word64 + , testProperty "marshalFeld Float" $ property_marshalFeld f_Float + , testProperty "marshalFeld Double" $ property_marshalFeld f_Double + , testProperty "marshalFeld Complex Float" $ property_marshalFeld f_CompFloat + , testProperty "marshalFeld Complex Double" $ property_marshalFeld f_CompDouble + , testProperty "marshalFeld Arr" $ property_marshalFeld f_Arr + , testProperty "marshalFeld IArr" $ property_marshalFeld f_IArr + , testProperty "marshalFeld Pair" $ property_marshalFeld f_Pair + , testProperty "marshalFeld Nested" $ property_marshalFeld f_Nested + ] + , testGroup "misc" + [ testProperty "nestIndex" $ property_nestIndex nestIndex_c + , testProperty "nestIndexLength" $ property_nestIndexLength nestIndexLength_c + ] + ] +