feldspar-language 0.6.0.3 → 0.7

raw patch · 97 files changed

+2764/−1671 lines, 97 filesdep +data-defaultdep +deepseqdep +tastydep −QuickAnnotatedep −test-frameworkdep −test-framework-goldendep ~arraydep ~basedep ~monad-parPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default, deepseq, tasty, tasty-golden, tasty-quickcheck, tasty-th, utf8-string

Dependencies removed: QuickAnnotate, test-framework, test-framework-golden, test-framework-quickcheck2, test-framework-th, type-level

Dependency ranges changed: array, base, monad-par, patch-combinators, random, syntactic, tagged

API changes (from Hackage documentation)

Files

• LICENSE +4/−2
• examples/Examples/Simple/Basics.hs +1/−0
• examples/Tutorial/Array.lhs +29/−0
• examples/Tutorial/Basic.lhs +65/−0
• examples/Tutorial/Patch.lhs +101/−0
• examples/Tutorial/Size.lhs +139/−0
• examples/Tutorial/Vector.lhs +51/−0
• examples/Tutorial/index.lhs +23/−0
• feldspar-language.cabal +54/−32
• src/Feldspar/Algorithm/FFT.hs +0/−9
• src/Feldspar/BitVector.hs +64/−85
• src/Feldspar/Core/Constructs.hs +55/−68
• src/Feldspar/Core/Constructs/Array.hs +77/−51
• src/Feldspar/Core/Constructs/Binding.hs +143/−43
• src/Feldspar/Core/Constructs/Bits.hs +68/−44
• src/Feldspar/Core/Constructs/Complex.hs +20/−19
• src/Feldspar/Core/Constructs/Condition.hs +67/−15
• src/Feldspar/Core/Constructs/ConditionM.hs +17/−23
• src/Feldspar/Core/Constructs/Conversion.hs +21/−16
• src/Feldspar/Core/Constructs/Eq.hs +14/−13
• src/Feldspar/Core/Constructs/Error.hs +10/−11
• src/Feldspar/Core/Constructs/FFI.hs +9/−8
• src/Feldspar/Core/Constructs/Floating.hs +12/−11
• src/Feldspar/Core/Constructs/Fractional.hs +13/−12
• src/Feldspar/Core/Constructs/Future.hs +15/−11
• src/Feldspar/Core/Constructs/Integral.hs +43/−37
• src/Feldspar/Core/Constructs/Literal.hs +5/−5
• src/Feldspar/Core/Constructs/Logic.hs +21/−20
• src/Feldspar/Core/Constructs/Loop.hs +71/−42
• src/Feldspar/Core/Constructs/Mutable.hs +59/−40
• src/Feldspar/Core/Constructs/MutableArray.hs +23/−15
• src/Feldspar/Core/Constructs/MutableReference.hs +33/−13
• src/Feldspar/Core/Constructs/MutableToPure.hs +13/−18
• src/Feldspar/Core/Constructs/NoInline.hs +12/−11
• src/Feldspar/Core/Constructs/Num.hs +116/−56
• src/Feldspar/Core/Constructs/Ord.hs +59/−25
• src/Feldspar/Core/Constructs/Par.hs +43/−47
• src/Feldspar/Core/Constructs/RealFloat.hs +47/−0
• src/Feldspar/Core/Constructs/Save.hs +9/−8
• src/Feldspar/Core/Constructs/SizeProp.hs +10/−9
• src/Feldspar/Core/Constructs/SourceInfo.hs +9/−18
• src/Feldspar/Core/Constructs/Switch.hs +74/−0
• src/Feldspar/Core/Constructs/Trace.hs +8/−8
• src/Feldspar/Core/Constructs/Tuple.hs +65/−21
• src/Feldspar/Core/Frontend.hs +82/−42
• src/Feldspar/Core/Frontend/Array.hs +0/−2
• src/Feldspar/Core/Frontend/Binding.hs +5/−2
• src/Feldspar/Core/Frontend/Bits.hs +39/−15
• src/Feldspar/Core/Frontend/Complex.hs +0/−2
• src/Feldspar/Core/Frontend/Condition.hs +9/−5
• src/Feldspar/Core/Frontend/ConditionM.hs +6/−0
• src/Feldspar/Core/Frontend/Conversion.hs +6/−10
• src/Feldspar/Core/Frontend/Eq.hs +2/−3
• src/Feldspar/Core/Frontend/Error.hs +0/−2
• src/Feldspar/Core/Frontend/FFI.hs +3/−6
• src/Feldspar/Core/Frontend/Floating.hs +5/−3
• src/Feldspar/Core/Frontend/Fractional.hs +1/−2
• src/Feldspar/Core/Frontend/Future.hs +1/−3
• src/Feldspar/Core/Frontend/Integral.hs +5/−10
• src/Feldspar/Core/Frontend/Literal.hs +1/−4
• src/Feldspar/Core/Frontend/Logic.hs +2/−4
• src/Feldspar/Core/Frontend/Mutable.hs +5/−3
• src/Feldspar/Core/Frontend/MutableArray.hs +26/−8
• src/Feldspar/Core/Frontend/MutableReference.hs +2/−4
• src/Feldspar/Core/Frontend/NoInline.hs +0/−2
• src/Feldspar/Core/Frontend/Num.hs +1/−2
• src/Feldspar/Core/Frontend/Ord.hs +2/−7
• src/Feldspar/Core/Frontend/Par.hs +6/−6
• src/Feldspar/Core/Frontend/RealFloat.hs +17/−0
• src/Feldspar/Core/Frontend/Save.hs +0/−8
• src/Feldspar/Core/Frontend/Select.hs +0/−41
• src/Feldspar/Core/Frontend/SourceInfo.hs +0/−9
• src/Feldspar/Core/Frontend/Switch.hs +56/−0
• src/Feldspar/Core/Frontend/Trace.hs +0/−2
• src/Feldspar/Core/Frontend/Tuple.hs +2/−109
• src/Feldspar/Core/Interpretation.hs +134/−56
• src/Feldspar/Core/Interpretation/Typed.hs +1/−2
• src/Feldspar/Core/Types.hs +54/−40
• src/Feldspar/FixedPoint.hs +24/−24
• src/Feldspar/Lattice.hs +37/−31
• src/Feldspar/Matrix.hs +5/−19
• src/Feldspar/Memoize.hs +22/−0
• src/Feldspar/Option.hs +12/−9
• src/Feldspar/Prelude.hs +7/−7
• src/Feldspar/Range.hs +165/−56
• src/Feldspar/Repa.hs +11/−22
• src/Feldspar/Stream.hs +3/−3
• src/Feldspar/Vector.hs +6/−6
• src/Feldspar/Vector/Internal.hs +35/−27
• src/Feldspar/Vector/Push.hs +36/−18
• src/Feldspar/Wrap.hs +0/−90
• tests/DecorationTests.hs +27/−7
• tests/Feldspar/Range/Test.hs +74/−51
• tests/Feldspar/Vector/Test.hs +10/−10
• tests/RangeTest.hs +2/−2
• tests/SemanticsTest.hs +11/−9
• tests/TutorialTest.hs +12/−0

@@ -1,3 +1,5 @@+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@@ -6,7 +8,7 @@ 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, +    * 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@@ -17,7 +19,7 @@  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 +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

@@ -2,6 +2,7 @@  import qualified Prelude import Feldspar+import Feldspar.Vector  -- Identity function for 32 bit integers. example1 :: Data Int32 -> Data Int32

@@ -0,0 +1,29 @@+% Core arrays++  <br/>++++*[This document needs to be extended.]*++It is generally not recommended to use core arrays directly. A more high-level interface is provided by the [vector library](Vector.html).++\begin{code}+module Tutorial.Array where++import qualified Prelude+import Feldspar+\end{code}++An array containing the powers of two:++\begin{code}+powsOfTwo :: Data Length -> Data [WordN]+powsOfTwo l = parallel l (2^)+\end{code}++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Array> eval powsOfTwo 10+[1,2,4,8,16,32,64,128,256,512]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+

@@ -0,0 +1,65 @@+% Basic usage++  <br/>++++*[This document needs to be extended.]*++Getting started+===============++Feldspar is implemented as an embedded language in Haskell. To use Feldspar, simply import the `Feldspar` module in a Haskell source file:++\begin{code}+module Tutorial.Basic where++import Feldspar+\end{code}++Since Feldspar redefines several standard Haskell identifiers, it is strongly recommended to import the standard `Prelude` qualified:++\begin{code}+import qualified Prelude+\end{code}++(Certain useful `Prelude` identifiers that are not used by Feldspar are reexported by the `Feldspar` module.)++In order to try out the examples in this file, we just load the file in GHCi:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+terminal> ghci Basic.lhs+GHCi, version 7.6.1: http://www.haskell.org/ghc/  :? for help+Loading package ghc-prim ... linking ... done.+Loading package integer-gmp ... linking ... done.+Loading package base ... linking ... done.+[1 of 1] Compiling Tutorial.Basic   ( Basic.lhs, interpreted )+Ok, modules loaded: Tutorial.Basic.+*Tutorial.Basic>+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We are now ready to define a simple program. The following function computes the length of the hypotenuse of a triangle, given the lengths of the two catheti:++\begin{code}+hypotenuse :: Data Float -> Data Float -> Data Float+hypotenuse c1 c2 = sqrt (square c1 + square c2)+  where+    square x = x*x+\end{code}++Note that this code is *identical* to the corresponding code in ordinary Haskell, except for the `Data` constructor in the type.++What makes `hypotenuse` different from the corresponding Haskell function can be seen when we try to evaluate it:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Basic> hypotenuse 3 4+(sqrt ((3.0 * 3.0) + (4.0 * 4.0)))+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Hm... instead of computing a result, `hypotenuse` returned an unevaluated expression. In order to evaluate this expression, we have to use the function `eval`:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Basic> eval hypotenuse 3 4+5.0+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+

@@ -0,0 +1,101 @@+% Constraints++  <br/>++++This file demonstrates how to use [patches](http://hackage.haskell.org/package/patch-combinators) to constrain types and sizes of Feldspar expressions.++\begin{code}+module Tutorial.Patch where++import qualified Prelude+import Feldspar+import Feldspar.Vector+\end{code}++++Type patches+============++Say we want to print the core expression resulting from the `scalarProd` function. Attempting this without giving any size constraints leads to an "ambiguous type" error:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Patch> printExpr scalarProd+<interactive>:26:1:+    Couldn't match type `syntactic-1.5.0:Language.Syntactic.Sugar.Domain+                           a0'+                  with `FeldDomain'+    The type variable `a0' is ambiguous+    Possible fix: add a type signature that fixes these type variable(s)+    In the expression: printExpr scalarProd+    In an equation for `it': it = printExpr scalarProd+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The solution is to provide a type signature for `scalarProd`:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Patch> printExpr (scalarProd :: Vector1 Float -> Vector1 Float -> Data Float)+...+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++An alternative --- and less verbose --- way of specifying type constraints is to use *type patches* instead:++\begin{code}+test1 = printExpr $ scalarProd -:: tVec1 tFloat >-> id+\end{code}++The part to the right of `-::` is the "patch", which is applied as a wrapper around `scalarProd`. In general, patches can change the behavior of the wrapped function, but type patches, such as the one above, only have the effect of constraining the function's type. The patch `tVec1 tFloat >-> id` is composed of two smaller patches: `tVec1 tFloat` and `id` (the identity function). The first of these is applied to the first argument and constrains its type to `Vector1 Float`. The `id` patch simply leaves the result (that is, the partially applied `scalarProd`) untouched. Thus, the whole patch can be thought of as the following *partial type signature* for `scalarProd`:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~{.haskell}+scalarProd :: Vector1 Float -> _  -- Not legal Haskell+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~{.haskell}++++Avoiding length checks+======================++In the expression printed by `test1`, we see a `min` function computing the number of iterations as the minimum of the input vector lengths. It is possible to get rid of this comparison by giving the second vector the same length as the first:++\begin{code}+test2 = printExpr $ scalarProd+    -:: tVec1 tFloat >-> id+    -:: name (\a -> id >-> newLen (length a) >-> id)+\end{code}++The `name` combinator lets us bind the first argument (to the variable `a`) and use it in the patch. The actual patch is then++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~{.haskell}+id >-> newLen (length a) >-> id+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~{.haskell}++which simply sets the length of the second argument to the length of `a`.++++Size patches+============++[`Tutorial.Size`](Size.html) describes how size analysis works and how to provide size constraints to improve the analysis. Size constraints are often convenient to use as patches.++The following example was used to demonstrate how the programmer can guide the analysis by providing guarantees about the ranges of values in the program:++\begin{code}+drop4 :: Data Index -> Vector (Data Word8) -> Vector (Data Word8)+drop4 n v = drop n' v'+  where+    n' = between 100 120 n+    v' = newLen (between 150 200 (length v)) v+\end{code}++Using patch combinators, `drop4` can be written more succinctly as++\begin{code}+drop4' :: Data Index -> Vector (Data Word8) -> Vector (Data Word8)+drop4' = drop -:: between 100 120 >-> (between 150 200 |> id) >-> id+\end{code}++The patch combinator `(|>)` takes a patch for the length (`between 150 200`) and a patch for the elements (`id`) and returns a patch for a whole vector.+

@@ -0,0 +1,139 @@+% Size analysis++  <br/>++++\begin{code}+module Tutorial.Size where++import qualified Prelude+import Feldspar+import Feldspar.Vector+\end{code}++Feldspar programs are quite dynamic. For example, functions like `drop` can operate on and return vectors of arbitrary length. However, when generating high-performance code to run on embedded targets, it is usually advantageous to have programs that are as static as possible, for example, to avoid dynamic memory allocation. Feldspar approaches this problem by performing a static size analysis on the programs. The inferred sizes are also used for optimizations on the core language.++Consider the following function:++\begin{code}+f :: Data Word8 -> Data Word8+f a = min (a+2) 10+\end{code}++To see the results of size inference, we use the function `drawDecor`, which draws the AST decorated with (among other things) size information:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Size> drawDecor f+<<Word8 -> Word8 | Range {lowerBound = 0, upperBound = 10}>>+|+`- Lambda 0+   |+   `- <<Word8 | Range {lowerBound = 0, upperBound = 10}>>+      |+      `- min+         |+         +- <<Word8 | Range {lowerBound = 0, upperBound = 255}>>+         |  |+         |  `- (+)+         |     |+         |     +- <<Word8 | Range {lowerBound = 0, upperBound = 255}>>+         |     |  |+         |     |  `- var:0+         |     |+         |     `- <<Word8 | Range {lowerBound = 2, upperBound = 2}>>+         |        |+         |        `- 2+         |+         `- <<Word8 | Range {lowerBound = 10, upperBound = 10}>>+            |+            `- 10+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The size on the root of the tree says that the result of `f` is in the range [0,10].++Size constraints+================++Imagine we want to generate code for the `drop` function in such a way that we can statically allocate the result. Let us see what size inference gives us:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Size> drawDecor (drop :: Data Index -> Vector (Data Word8) -> Vector (Data Word8))+<<WordN -> [Word8] -> [Word8] | Range {lowerBound = 0, upperBound = 4294967295} :> Range {lowerBound = 0, upperBound = 255}>>+...+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The root has a size of the form `rl :> re`, where `rl` is the range of the vector's length and `re` is the range of the elements. As we see, no useful size could be inferred, since the analysis knows nothing about the length of the input vector or the number of elements we want to drop.++In cases where we --- the programmers --- have additional information about the sizes of the inputs, it is possible to help size inference to achieve more accurate results. Imagine that we know that the input has at most 200 elements and that we will always drop at least 100 elements. Then we can make a specialized version of `drop` that has this information hard-coded:++\begin{code}+drop2 :: Data Index -> Vector (Data Word8) -> Vector (Data Word8)+drop2 n v = drop n' v'+  where+    n' = max 100 n+    v' = newLen (min 200 (length v)) v+\end{code}++This lets the analysis infer the range [0,100] for the length of the result, which means that it is safe for the back end to allocate a 100-element array.++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Size> drawDecor drop2+<<WordN -> [Word8] -> [Word8] | Range {lowerBound = 0, upperBound = 100} :> Range {lowerBound = 0, upperBound = 255}>>+...+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++++Avoiding run-time checks+========================++The down-side of the technique used in `drop2` is that the use of `max` and `min` incurs a run-time overhead. If we are certain that the input has at most 200 elements and that we will always drop at least 100 elements, these checks are useless, and could just as well be removed. To do this, we simply replace `max` and `min` with `notBelow` and `notAbove` respectively:++\begin{code}+drop3 :: Data Index -> Vector (Data Word8) -> Vector (Data Word8)+drop3 n v = drop n' v'+  where+    n' = notBelow 100 n+    v' = newLen (notAbove 200 (length v)) v+\end{code}++Functions `notBelow` and `notAbove` should be used with care as they are only well-defined as long as the guarantee is fulfilled. These, and some other functions for guiding the size analysis are found in the module [`Feldspar.Core.Frontend.SizeProp`](http://hackage.haskell.org/package/feldspar-language).++++Size-based optimization+=======================++If we look at the core expression resulting from `drop3`, we see that it still contains a run-time check:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Size> printExpr drop3+(\var0 -> (\var1 -> (letBind (getLength var1) (\var3 -> (parallel (var3 - (min var3 var0)) (\var2 -> (var1 ! (var2 + var0))))))))+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The `min` function is used to check that we don't try to drop more elements than we have in the array. If we know that we will never try to drop too many elements, we can get rid of this check as well. To do this, we have to supply an upper bound for first argument and a lower bound for the length, using the `between` function:++\begin{code}+drop4 :: Data Index -> Vector (Data Word8) -> Vector (Data Word8)+drop4 n v = drop n' v'+  where+    n' = between 100 120 n+    v' = newLen (between 150 200 (length v)) v+\end{code}++This gives us a core expression without any run-time checks:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Size> printExpr drop4+(\var0 -> (\var1 -> (parallel ((getLength var1) - var0) (\var2 -> (var1 ! (var2 + var0))))))+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Curiously, size analysis also figures out that the resulting vector length is in the range [30..100]:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Size> drawDecor drop4+<<WordN -> [Word8] -> [Word8] | Range {lowerBound = 30, upperBound = 100} :> Range {lowerBound = 0, upperBound = 255}>>+...+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+

@@ -0,0 +1,51 @@+% Vector library++  <br/>++++*[This document needs to be extended.]*++The vector library provides an interface for vector operations similar to Haskell's list library. It is available through the module `Feldspar.Vector`:++\begin{code}+module Tutorial.Vector where++import qualified Prelude+import Feldspar+import Feldspar.Vector+\end{code}++Scalar product:++\begin{code}+scProd :: (Syntax a, Num a) => Vector a -> Vector a -> a+scProd a b = sum (zipWith (*) a b)+\end{code}++Specialize the type:++\begin{code}+scProdF = scProd :: Vector (Data Float) -> Vector (Data Float) -> Data Float+\end{code}++Testing:++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Vector> eval scProdF [1,2,3,4] [5,6,7,8::Float]+70.0+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Resulting core expression (with manually inserted white space):++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Tutorial.Vector> printExpr scProdF+(\var0 -> (\var1 -> (+    forLoop (min (getLength var0) (getLength var1)) 0.0 (\var2 -> (\var3 ->+        (var3 + ((var0 ! var2) * (var1 ! var2)))+    ))+)))+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Note how `sum` and `zipWith` have been fused into a single `forLoop`.+

@@ -0,0 +1,23 @@+% Feldspar Tutorial++++<!--+Empty code block to make the literate pre-processor happy++\begin{code}+\end{code}+-->++++This is a light-weight introduction to the [Feldspar](http://hackage.haskell.org/package/feldspar-language) language in the form of a set of documented example files. The source code of the examples is available as literate Haskell files distributed in the `examples/Tutorial` directory of the [`feldspar-language`](http://hackage.haskell.org/package/feldspar-language) package. This documentation does not cover the [back end](http://hackage.haskell.org/package/feldspar-compiler).++<h1>Contents</h1>++  * [Basic usage](Basic.html)+  * [Core arrays](Array.html)+  * [Vector library](Vector.html)+  * [Size analysis](Size.html)+  * [Type and size patches](Patch.html)+

@@ -1,21 +1,23 @@ name:           feldspar-language-version:        0.6.0.3+version:        0.7 synopsis:       A functional embedded language for DSP and parallelism description:    Feldspar (Functional Embedded Language for DSP and PARallelism)                 is an embedded DSL for describing digital signal processing                 algorithms. This package contains the language front-end and an                 interpreter. category:       Language-copyright:      Copyright (c) 2012 Emil Axelsson, Gergely Dévai,+copyright:      Copyright (c) 2013-2014 Emil Axelsson, Peter Jonsson,+                                        Anders Persson, Josef Svenningsson+                Copyright (c) 2012 Emil Axelsson, Gergely Dévai,                                    Anders Persson, Josef Svenningsson                 Copyright (c) 2009-2011, ERICSSON AB author:         Functional programming group at Chalmers University of Technology-maintainer:     Emil Axelsson <emax@chalmers.se>+maintainer:     Emil Axelsson <emax@chalmers.se>,                 Anders Persson <anders.cj.persson@gmail.com> license:        BSD3 license-file:   LICENSE stability:      experimental-homepage:       https://feldspar.github.com+homepage:       http://feldspar.github.com bug-reports:    https://github.com/feldspar/feldspar-language/issues build-type:     Simple cabal-version:  >= 1.14@@ -23,21 +25,20 @@  extra-source-files:   examples/Examples/Simple/Basics.hs+  examples/Tutorial/*.lhs  source-repository head   type:     git-  location: git://github.com/feldspar/feldspar-language.git+  location: git://github.com/Feldspar/feldspar-language.git  library   exposed-modules:     Feldspar.Prelude     Feldspar.Lattice     Feldspar.Range-    Feldspar.Algorithm.CRC-    Feldspar.Algorithm.FFT     Feldspar.Core.Types-    Feldspar.Core.Interpretation     Feldspar.Core.Interpretation.Typed+    Feldspar.Core.Interpretation     Feldspar.Core.Constructs.Array     Feldspar.Core.Constructs.Binding     Feldspar.Core.Constructs.Bits@@ -64,6 +65,8 @@     Feldspar.Core.Constructs.Ord     Feldspar.Core.Constructs.SizeProp     Feldspar.Core.Constructs.SourceInfo+    Feldspar.Core.Constructs.Switch+    Feldspar.Core.Constructs.RealFloat     Feldspar.Core.Constructs.Trace     Feldspar.Core.Constructs.Tuple     Feldspar.Core.Constructs.FFI@@ -93,9 +96,10 @@     Feldspar.Core.Frontend.Par     Feldspar.Core.Frontend.Num     Feldspar.Core.Frontend.Ord-    Feldspar.Core.Frontend.Select     Feldspar.Core.Frontend.SizeProp     Feldspar.Core.Frontend.SourceInfo+    Feldspar.Core.Frontend.Switch+    Feldspar.Core.Frontend.RealFloat     Feldspar.Core.Frontend.Trace     Feldspar.Core.Frontend.Tuple     Feldspar.Core.Frontend.FFI@@ -103,37 +107,40 @@     Feldspar.Core.Frontend     Feldspar.Core.Collection     Feldspar.Core+    Feldspar     Feldspar.BitVector     Feldspar.FixedPoint     Feldspar.Future     Feldspar.Matrix+    Feldspar.Memoize     Feldspar.Option     Feldspar.Repa     Feldspar.Stream     Feldspar.Vector.Internal     Feldspar.Vector     Feldspar.Vector.Push-    Feldspar.Wrap     Feldspar.Par-    Feldspar+    Feldspar.Algorithm.CRC+    Feldspar.Algorithm.FFT    default-language: Haskell2010    build-depends:-    array                       >= 0.4    && < 0.5,-    base                        >= 4      && < 4.7,+    array,+    base                        >= 4      && < 4.8,     containers                  >= 0.4    && < 0.6,     data-hash                   >= 0.1    && < 0.3,     data-lens                   >= 2.10   && < 2.11,     mtl                         >= 2.0    && < 2.2,     QuickCheck                  >= 2.5    && < 3,-    patch-combinators           >= 0.1    && < 0.2,-    syntactic                   >= 1.4    && < 1.5,-    tagged                      >= 0.4    && < 0.5,+    patch-combinators           >= 0.2    && < 0.3,+    syntactic                   >= 1.10   && < 1.12,+    tagged                      >= 0.4    && < 0.8,     tuple                       >= 0.2    && < 0.3,-    type-level                  >= 0.2.4  && < 0.3,-    monad-par                   >= 0.3    && < 0.3.4,-    QuickAnnotate               >= 0.6    && < 0.7+    monad-par                   >= 0.3.4.5,+    deepseq,+    random                      >= 1.0    && < 1.1,+    data-default                >= 0.5.3  && < 0.6    other-extensions:     DeriveDataTypeable@@ -171,11 +178,11 @@    build-depends:     feldspar-language,-    base >= 4 && < 4.7,-    random >= 1 && <2,-    QuickCheck >= 2.4 && <3,-    test-framework >= 0.6 && < 0.7,-    test-framework-quickcheck2 >= 0.2 && < 0.3+    base,+    random           >= 1   && < 2,+    QuickCheck       >= 2.4 && < 3,+    tasty            >= 0.3,+    tasty-quickcheck >= 0.2  test-suite semantics   type: exitcode-stdio-1.0@@ -192,11 +199,11 @@    build-depends:     feldspar-language,-    base                       >= 4   && < 4.7,-    QuickCheck                 >= 2.4 && < 3,-    test-framework             >= 0.6 && < 0.7,-    test-framework-th          >= 0.2 && < 0.3,-    test-framework-quickcheck2 >= 0.2 && < 0.3+    base,+    QuickCheck       >= 2.4 && < 3,+    tasty            >= 0.3,+    tasty-th         >= 0.1,+    tasty-quickcheck >= 0.2  test-suite decoration   type: exitcode-stdio-1.0@@ -209,8 +216,23 @@    build-depends:     feldspar-language,-    base                  >= 4   && < 4.7,+    base,     bytestring            >= 0.9 && < 0.11,-    test-framework        >= 0.6 && < 0.7,-    test-framework-golden >= 1.1 && < 1.2+    tasty                 >= 0.3,+    tasty-golden          >= 2.0,+    utf8-string           >= 0.3.7++test-suite tutorial+  type: exitcode-stdio-1.0++  hs-source-dirs: tests examples++  main-is: TutorialTest.hs++  default-language: Haskell2010++  build-depends:+    feldspar-language,+    base,+    bytestring         >= 0.9 && < 0.11 

@@ -91,12 +91,3 @@     rights = ir .&. oneBits k     lefts  = (((ir .>>. k) .<<. 1) .|. (i .&. 1)) .<<. k -oneBits :: (Bits a) => Data Index -> Data a-oneBits n = complement (allOnes .<<. n)--allOnes :: (Bits a) => Data a-allOnes = complement 0--lsbs :: Bits a => Data Index -> Data a -> Data a-lsbs k i = i .&. oneBits k-

@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,8 +34,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- -- | A 'Vector' interface to packed sequences of bits -- module Feldspar.BitVector where@@ -43,11 +42,9 @@ import Data.Word import Data.List (inits) import Data.Proxy-import qualified Data.TypeLevel as TL  import Language.Syntactic hiding (fold) -import Feldspar.Wrap import Feldspar.Prelude import Feldspar hiding (sugar, desugar, resugar) import qualified Feldspar.Vector as Vec@@ -90,13 +87,11 @@  instance (Unit a) => Syntactic (BitVector a)   where-    type Domain (BitVector a)   = FeldDomainAll+    type Domain (BitVector a)   = FeldDomain     type Internal (BitVector a) = [a]     desugar = desugar . freezeBitVector     sugar   = unfreezeBitVector . sugar -instance (Unit a) => Syntax (BitVector a)- -- * Operations  length :: forall w . (Unit w) => BitVector w -> Data Length@@ -143,7 +138,7 @@     w = value $ width (Proxy :: Proxy w)     wl = Vec.length v `div` w     loop n ix = forLoop n 0 $ \i st ->-        st `shiftLU` 1 .|. (v ! (w * ix + i) ? (1,0))+        st `shiftLU` 1 .|. (v ! (w * ix + i) ? 1 $ 0)  toVector :: forall w . (Unit w, Size w ~ Range w) => BitVector w -> Vec.Vector (Data Bool) toVector bv = Vec.indexed (length bv) (bv!)@@ -155,10 +150,9 @@         help _      [] = false             -- XXX Should be an error here...         help accum [s] = ixf s accum i-        help accum (s:ss) = i < accum + numUnits s * w ?-            ( ixf s accum i-            , help (accum + numUnits s * w) ss-            )+        help accum (s:ss) = (i < accum + numUnits s * w)+            ? ixf s accum i+            $ help (accum + numUnits s * w) ss         w = value $ width (Proxy :: Proxy w)         ixf s accum ix = testBit (elements s ((ix - accum) `div` w)) (w - 1 - ((ix - accum) `mod` w)) @@ -192,20 +186,18 @@ takeUnits len bv = help len [] $ segments bv   where     help _ acc [] = BitVector acc-    help n acc (s:ss) = n < numUnits s ?-        ( BitVector (acc Prelude.++ [s{numUnits = n}])-        , help (n - numUnits s) (acc Prelude.++ [s]) ss-        )+    help n acc (s:ss) = (n < numUnits s)+        ? BitVector (acc Prelude.++ [s{numUnits = n}])+        $ help (n - numUnits s) (acc Prelude.++ [s]) ss  dropUnits :: forall w . (Unit w) =>     Data Length -> BitVector w -> BitVector w dropUnits len bv = help len $ segments bv   where     help _ [] = BitVector []-    help n (s:ss) = n < numUnits s ?-        ( BitVector $ s':ss-        , help (n - numUnits s) ss-        )+    help n (s:ss) = (n < numUnits s)+        ? BitVector (s':ss)+        $ help (n - numUnits s) ss       where         s' = Segment             { numUnits = numUnits s - n@@ -222,10 +214,9 @@   where     w = value $ width (Proxy :: Proxy w)     dropSegments _ [] = BitVector []-    dropSegments n (s:ss) = n < sLen ?-        ( dropUnits n s ss-        , dropSegments (n - sLen) ss-        )+    dropSegments n (s:ss) = (n < sLen)+        ? dropUnits n s ss+        $ dropSegments (n - sLen) ss       where         sLen = numUnits s * w     dropUnits n s ss = dropBits bitsToDrop (s':ss)@@ -237,10 +228,9 @@         wordsToDrop = n `div` w         bitsToDrop = n `mod` w     dropBits _ [] = BitVector []-    dropBits n (s:ss) = n > 0 ?-        ( BitVector $ s' : segments bv'-        , BitVector (s:ss)-        )+    dropBits n (s:ss) = (n > 0)+        ? BitVector (s' : segments bv')+        $ BitVector (s:ss)       where         s' = Segment             { numUnits = numUnits s - 1@@ -251,10 +241,9 @@             }         bv' = addBits (w - n) (elements s (numUnits s - 1) `shiftLU` n) ss     addBits n bs [] = BitVector [Segment 1 $ const $ bs .|. (end `shiftRU` n)]-    addBits n bs (s:ss) = numUnits s > 0 ?-        ( BitVector $ s' : segments bv'-        , addBits n bs ss-        )+    addBits n bs (s:ss) = (numUnits s > 0)+        ? BitVector (s' : segments bv')+        $ addBits n bs ss       where         s' = Segment             { numUnits = 1@@ -314,71 +303,61 @@     (Data Bool -> Data Bool)     -> ((Data w -> Data w) -> t)     -> t-boolFun1 f c = f true ?-        ( f false ? (c (const $ complement 0), c id)-        , f false ? (c complement, c (const 0))-        )+boolFun1 f c = f true+        ? (f false ? c (const $ complement 0) $ c id)+        $ (f false ? c complement $ c (const 0))  boolFun2 :: (Syntax t, Unit w, Size w ~ Range w) =>     (Data Bool -> Data Bool -> Data Bool)     -> ((Data w -> Data w -> Data w) -> t)     -> t boolFun2 f c =-    f true true ?-    ( f true false ?-      ( f false true ?-        ( f false false ?-          ( c $ \_ _ -> complement 0-          , c $ (.|.)-          )-        , f false false ?-          ( c $ \x y -> x .|. complement y-          , c $ \x _ -> x-          )-        )-      , f false true ?-        ( f false false ?-          ( c $ \x y -> complement x .|. y-          , c $ \_ y -> y+    f true true+    ? ( f true false+        ? ( f false true+            ? ( f false false+                ? (c $ \_ _ -> complement 0)+                $ (c $ (.|.))+              )+            $ ( f false false+                ? (c $ \x y -> x .|. complement y)+                $ (c $ \x _ -> x)+              )           )-        , f false false ?-          ( c $ \x y -> complement (x `xor` y)-          , c $ (.&.)+        $ ( f false true+            ? ( f false false+                ? (c $ \x y -> complement x .|. y)+                $ (c $ \_ y -> y)+              )+            $ ( f false false+                ? (c $ \x y -> complement (x `xor` y))+                $ (c $ (.&.))+              )           )-        )       )-    , f true false ?-      ( f false true ?-        ( f false false ?-          ( c $ \x y -> complement (x .&. y)-          , c $ \x y -> x `xor` y-          )-        , f false false ?-          ( c $ \_ y -> complement y-          , c $ \x y -> x .&. complement y-          )-        )-      , f false true ?-        ( f false false ?-          ( c $ \x _ -> complement x-          , c $ \x y -> complement x .&. y+    $ ( f true false+        ? (f false true+            ? ( f false false+                ? (c $ \x y -> complement (x .&. y))+                $ (c $ \x y -> x `xor` y)+              )+            $ ( f false false+                ? (c $ \_ y -> complement y)+                $ (c $ \x y -> x .&. complement y)+              )           )-        , f false false ?-          ( c $ \x y -> complement (x .|. y)-          , c $ \_ _ -> 0+        $ ( f false true+            ? ( f false false+                ? (c $ \x _ -> complement x)+                $ (c $ \x y -> complement x .&. y)+              )+            $ ( f false false+                ? (c $ \x y -> complement (x .|. y))+                $ (c $ \_ _ -> 0)++              )           )-        )       )-    )---- * Wrapping for bitvectors--instance (Unit w) => Wrap (BitVector w) (Data [w]) where-    wrap = freezeBitVector--instance (Wrap t u, Unit w, TL.Nat s) => Wrap (BitVector w -> t) (Data' s [w] -> u) where-    wrap f = \(Data' d) -> wrap $ f $ unfreezeBitVector $ setLength s' d where-        s' = fromInteger $ toInteger $ TL.toInt (undefined :: s)  -- * Patch combinators for bitvectors 

@@ -1,10 +1,13 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -71,8 +74,10 @@ import Feldspar.Core.Constructs.Num import Feldspar.Core.Constructs.Ord import Feldspar.Core.Constructs.Save+import Feldspar.Core.Constructs.Switch import Feldspar.Core.Constructs.SizeProp import Feldspar.Core.Constructs.SourceInfo+import Feldspar.Core.Constructs.RealFloat import Feldspar.Core.Constructs.Trace import Feldspar.Core.Constructs.Tuple @@ -84,7 +89,6 @@     =   (Decor SourceInfo1 Identity :|| Type)     :+: (Condition  :|| Type)     :+: (FFI        :|| Type)-    :+: (Let        :|| Type)     :+: (Literal    :|| Type)     :+: (Select     :|| Type)     :+: (Tuple      :|| Type)@@ -95,6 +99,7 @@     :+: (EQ         :|| Type)     :+: (Error      :|| Type)     :+: (FLOATING   :|| Type)+    :+: (REALFLOAT  :|| Type)     :+: (FRACTIONAL :|| Type)     :+: (FUTURE     :|| Type)     :+: (INTEGRAL   :|| Type)@@ -105,7 +110,9 @@     :+: (ORD        :|| Type)     :+: (PropSize   :|| Type)     :+: (Save       :|| Type)+    :+: (Switch     :|| Type)     :+: (Trace      :|| Type)+    :+: Let     :+: ConditionM Mut     :+: LoopM Mut     :+: MONAD Mut@@ -122,65 +129,45 @@ --      `MutableToPure` (at least) have `Type` baked in. Note that `(MutableToPure :|| Type)` would --      currently not work, since `WithArray` has monadic result type. -type FeldDomain    = FODomain FeldSymbols Typeable Type--type FeldDomainAll = HODomain FeldSymbols Typeable Type----newtype FeldDomain a = FeldDomain (FeldSymbols a)-----deriving instance (sym :<: FeldSymbols) => sym :<: FeldDomain---deriving instance (Project sym FeldSymbols) => Project sym FeldDomain------instance (InjectC sym FeldSymbols a) => InjectC sym FeldDomain a-----    where-----      injC = injC . FeldDomain+type FeldDom = FODomain FeldSymbols Typeable Type -----instance Constrained FeldDomain---    where---        type Sat FeldDomain = Sat FeldSymbols---        exprDict (FeldDomain a) = exprDict a+newtype FeldDomain a = FeldDomain { getFeldDomain :: HODomain FeldSymbols Typeable Type a } ---deriving instance Equality FeldDomain---deriving instance Render   FeldDomain---deriving instance ToTree   FeldDomain---deriving instance Eval     FeldDomain---deriving instance EvalBind FeldDomain+-- Note: `FeldDomain` is a newtype in order to hide the large `FeldSymbols` type to the user.+-- Previously, we also had separate instances of the `Syntax` class for each type, but that doesn't+-- seem to be needed anymore. Type errors seem to have improved since `Domain` was made an+-- associated type of the `Syntactic` class rather than a functional dependency.+--+-- Here are some programs that have previously resulted in horribly long error messages:+--+--     drawAST map+--     drawAST (map (+))+--     drawAST (map (+1))+--     drawAST (forLoop 10 0 (const (+id))) ---instance VarEqEnv env => AlphaEq---    FeldDomain---    FeldDomain---    ((Lambda :+: (Variable :+: ((FeldDomain :|| Eq) :| Show))) :|| Typeable)---    env---  where---    alphaEqSym (FeldDomain a) aArgs (FeldDomain b) bArgs =---        alphaEqSym a aArgs b bArgs+instance Constrained FeldDomain+  where+    type Sat FeldDomain = Typeable+    exprDict (FeldDomain s) = exprDict s ---instance AlphaEq---    FeldDomain---    FeldDomain---    ((Lambda :+: (Variable :+: ((FeldDomain :|| Eq) :| Show))) :|| Typeable)---    [(VarId, VarId)]---  where---    alphaEqSym (FeldDomain a) aArgs (FeldDomain b) bArgs =---        alphaEqSym a aArgs b bArgs+deriving instance (Project sym FeldSymbols) => Project sym FeldDomain -{--instance Equality dom => AlphaEq dom dom (Decor Info (dom :|| Typeable)) [(VarId,VarId)]+instance (InjectC sym FeldSymbols a, Typeable a) => InjectC sym FeldDomain a   where-    alphaEqSym = alphaEqSymDefault--}+    injC = FeldDomain . injC ---deriving instance Sharable FeldDomain+toFeld :: ASTF (HODomain FeldSymbols Typeable Type) a -> ASTF FeldDomain a+toFeld = fold $ appArgs . Sym . FeldDomain+  -- TODO Use unsafeCoerce? -{--instance Optimize FeldDomain (Lambda TypeCtx :+: (Variable TypeCtx :+: FeldDomain))-  where-    optimizeFeat       (FeldDomain a) = optimizeFeat       a-    constructFeatOpt   (FeldDomain a) = constructFeatOpt   a-    constructFeatUnOpt (FeldDomain a) = constructFeatUnOpt a--}+fromFeld :: ASTF FeldDomain a -> ASTF (HODomain FeldSymbols Typeable Type) a+fromFeld = fold $ appArgs . Sym . getFeldDomain+  -- TODO Use unsafeCoerce? +instance IsHODomain FeldDomain Typeable Type+  where+    lambda f = case lambda (fromFeld . f . toFeld) of+        Sym s -> Sym (FeldDomain s)   @@ -188,24 +175,26 @@ -- * Front end -------------------------------------------------------------------------------- -newtype Data a = Data { unData :: ASTF FeldDomainAll a }+newtype Data a = Data { unData :: ASTF FeldDomain a } +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Data+#else deriving instance Typeable1 Data+#endif  instance Type a => Syntactic (Data a)   where-    type Domain (Data a)   = FeldDomainAll+    type Domain (Data a)   = FeldDomain     type Internal (Data a) = a     desugar = unData     sugar   = Data +type SyntacticFeld a = (Syntactic a, Domain a ~ FeldDomain, Typeable (Internal a))+ -- | Specialization of the 'Syntactic' class for the Feldspar domain-class-    ( Syntactic a-    , Domain a ~ FeldDomainAll-    , Type (Internal a)-    ) =>-      Syntax a+class    (SyntacticFeld a, Type (Internal a)) => Syntax a+instance (SyntacticFeld a, Type (Internal a)) => Syntax a   -- It would be possible to let 'Syntax' be an alias instead of giving separate   -- instances for all types. However, this leads to horrible error messages.   -- For example, if 'Syntax' is an alias, the following expression gives a huge@@ -216,24 +205,22 @@   -- The type error is not very readable now either, but at least it fits on the   -- screen. -instance Type a => Syntax (Data a)+reifyF :: SyntacticFeld a => a -> ASTF FeldDom (Internal a)+reifyF = reifyTop . fromFeld . desugar  instance Type a => Eq (Data a)   where-    Data a == Data b = alphaEq (reify a) (reify b)+    Data a == Data b = alphaEq (reifyF a) (reifyF b)  instance Type a => Show (Data a)   where-    show (Data a) = render $ reify a----c' :: (Type (DenResult sig)) => feature sig -> (feature :|| Type) sig---c' = C'+    show = render . reifyF . unData -sugarSymF :: ( ApplySym sig b dom+sugarSymF :: ( ApplySym sig b FeldDomain              , SyntacticN c b-             , InjectC (feature :|| Type) dom (DenResult sig)+             , InjectC (feature :|| Type) (HODomain FeldSymbols Typeable Type) (DenResult sig)              , Type (DenResult sig)              )           => feature sig -> c-sugarSymF sym = sugarSymC (c' sym)+sugarSymF sym = sugarN $ appSym' $ Sym $ FeldDomain $ injC $ c' sym 

@@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,8 +35,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Array where @@ -42,7 +42,6 @@ import Data.Map (notMember)  import Language.Syntactic-import Language.Syntactic.Constructs.Binding hiding (betaReduce) import Language.Syntactic.Constructs.Binding.HigherOrder (CLambda)  import Feldspar.Range@@ -50,6 +49,8 @@ import Feldspar.Core.Types import Feldspar.Core.Interpretation import Feldspar.Core.Constructs.Binding+import Feldspar.Core.Constructs.Complex+import Feldspar.Core.Constructs.Integral import Feldspar.Core.Constructs.Num import Feldspar.Core.Constructs.Ord @@ -95,10 +96,8 @@           where             len = genericLength as -instance Equality Array where equal = equalDefault; exprHash = exprHashDefault-instance Render   Array where renderArgs = renderArgsDefault-instance ToTree   Array-instance Eval     Array where evaluate = evaluateDefault+semanticInstances ''Array+ instance EvalBind Array where evalBindSym = evalBindSymDefault  instance AlphaEq dom dom dom env => AlphaEq Array Array dom env@@ -106,16 +105,15 @@     alphaEqSym = alphaEqSymDefault  instance Sharable Array-  where-    sharable GetIx = False-    sharable _     = True +instance Monotonic Array+ instance SizeProp (Array :|| Type)   where     sizeProp (C' Parallel) (WrapFull len :* WrapFull ixf :* Nil) =-        infoSize len :> infoSize ixf+        infoSize len :> snd (infoSize ixf)     sizeProp (C' Sequential) (WrapFull len :* _ :* WrapFull step :* Nil) =-        infoSize len :> fst (infoSize step)+        infoSize len :> fst (snd $ snd $ infoSize step)     sizeProp (C' Append) (WrapFull arra :* WrapFull arrb :* Nil) =         (alen + blen) :> (aelem \/ belem)       where@@ -137,103 +135,131 @@         _ :> el = infoSize arr  instance-    ( (Array :|| Type) :<: dom-    , (NUM   :|| Type) :<: dom-    , (ORD   :|| Type) :<: dom+    ( (Array    :|| Type) :<: dom+    , (NUM      :|| Type) :<: dom+    , Let                 :<: dom+    , (ORD      :|| Type) :<: dom+    , (INTEGRAL :|| Type) :<: dom+    , (COMPLEX  :|| Type) :<: dom     , (Variable :|| Type) :<: dom     , CLambda Type :<: dom     , OptimizeSuper dom     ) =>       Optimize (Array :|| Type) dom   where-    optimizeFeat sym@(C' Parallel) (len :* ixf :* Nil) = do-        len' <- optimizeM len+    optimizeFeat opts sym@(C' Parallel) (len :* ixf :* Nil) = do+        len' <- optimizeM opts len         let szI     = infoSize (getInfo len')-            ixRange = rangeByRange 0 (szI-1)-        ixf' <- optimizeFunction optimizeM (mkInfo ixRange) ixf-        constructFeat sym (len' :* ixf' :* Nil)+            ixRange = rangeByRange 0 (rangeSubSat szI 1)+        ixf' <- optimizeFunction opts (optimizeM opts) (mkInfo ixRange) ixf+        constructFeat opts sym (len' :* ixf' :* Nil) -    optimizeFeat sym@(C' Sequential) (len :* inital :* step :* Nil) = do-        len'  <- optimizeM len-        init' <- optimizeM inital+    optimizeFeat opts sym@(C' Sequential) (len :* inital :* step :* Nil) = do+        len'  <- optimizeM opts len+        init' <- optimizeM opts inital         let szI     = infoSize (getInfo len')-            ixRange = rangeByRange 0 (szI-1)-        step' <- optimizeFunction-            optimizeM  -- TODO (optimizeFunctionFix optimizeM (mkInfo universal))+            ixRange = rangeByRange 0 (rangeSubSat szI 1)+        step' <- optimizeFunction opts+            (optimizeM opts)  -- TODO (optimizeFunctionFix optimizeM (mkInfo universal))             (mkInfo ixRange)             step-        constructFeat sym (len' :* init' :* step' :* Nil)+        constructFeat opts sym (len' :* init' :* step' :* Nil)       -- TODO Should use fixed-point iteration, but `optimizeFunctionFix` only       --      works for functions of type `a -> a`. -    optimizeFeat a args = optimizeFeatDefault a args+    optimizeFeat opts a args = optimizeFeatDefault opts a args -    constructFeatOpt (C' Parallel) (len :* _ :* Nil)+    -- parallel l (\x -> let y = e in e') => let y = e in parallel l (\x -> e')+    --+    -- Test case: nothing simple. Look at the index calculation in the+    -- outer second loop in turboDecode.+    constructFeatOpt opts sym@(C' Parallel) (len :* (lam1 :$ (lt :$ e1 :$ (lam2 :$ bd))) :* Nil)+        | Just       (SubConstr2 (Lambda v1)) <- prjLambda lam1+        , Just lam2'@(SubConstr2 (Lambda _ )) <- prjLambda lam2+        , Just Let <- prj lt+        , v1 `notMember` infoVars (getInfo e1)+        , SICS `inTarget` opts+        = do+             sym' <- constructFeat opts sym (len :* (lam1 :$ bd) :* Nil)+             sym'' <- constructFeat opts (reuseCLambda lam2') (sym' :* Nil)+             constructFeat opts Let (e1 :* sym'' :* Nil)++    constructFeatOpt _ (C' Parallel) (len :* _ :* Nil)         | Just 0 <- viewLiteral len         = return $ literalDecor []       -- TODO Optimize when length is one. This requires a way to create an       --      uninitialized array of length one, and setting the first element.       --      Use `betaReduce` to apply `ixf` to the literal 0. -    constructFeatOpt (C' Parallel) (len :* (lam :$ (gix :$ arr2 :$ ix)) :* Nil)+    constructFeatOpt opts (C' Parallel) (len :* (lam :$ (gix :$ arr2 :$ ix)) :* Nil)         | Just (SubConstr2 (Lambda v1))   <- prjLambda lam         , Just (C' GetIx)         <- prjF gix         , Just (C' (Variable v2)) <- prjF ix         , v1 == v2         , v1 `notMember` infoVars (getInfo arr2)-        = constructFeat (c' SetLength) (len :* arr2 :* Nil)+        = constructFeat opts (c' SetLength) (len :* arr2 :* Nil) -    constructFeatOpt (C' Sequential) (len :* _ :* _ :* Nil)+    constructFeatOpt _ (C' Sequential) (len :* _ :* _ :* Nil)         | Just 0 <- viewLiteral len         = return $ literalDecor []       -- TODO Optimize when length is one. This requires a way to create an       --      uninitialized array of length one, and setting the first element.       --      Use `betaReduce` to apply the step function. -    constructFeatOpt (C' Append) (a :* b :* Nil)+    constructFeatOpt _ (C' Append) (a :* b :* Nil)         | Just [] <- viewLiteral a = return b         | Just [] <- viewLiteral b = return a -    constructFeatOpt (C' GetIx) ((op :$ _ :$ ixf) :* ix :* Nil)+    constructFeatOpt opts (C' GetIx) ((op :$ _ :$ ixf) :* ix :* Nil)         | Just (C' Parallel) <- prjF op-        = optimizeM $ betaReduce (stripDecor ix) (stripDecor ixf)+        = optimizeM opts $ betaReduce (stripDecor ix) (stripDecor ixf)           -- TODO should not need to drop the decorations -    constructFeatOpt s@(C' GetIx) ((op :$ _ :$ arr) :* ix :* Nil)+    constructFeatOpt opts s@(C' GetIx) ((op :$ _ :$ arr) :* ix :* Nil)         | Just (C' SetLength) <- prjF op-        = constructFeat s (arr :* ix :* Nil)+        = constructFeat opts s (arr :* ix :* Nil) -    constructFeatOpt (C' GetLength) (arr :* Nil)+    constructFeatOpt _ (C' GetLength) (arr :* Nil)         | Just as <- viewLiteral arr = return $ literalDecor $ genericLength as -    constructFeatOpt s@(C' GetLength) ((op :$ a :$ _ :$ _) :* Nil)+    constructFeatOpt opts s@(C' GetLength) ((op :$ a :$ _ :$ _) :* Nil)         | Just (C' Sequential) <- prjF op = return a-        | Just (C' SetIx)      <- prjF op = constructFeat s (a :* Nil)+        | Just (C' SetIx)      <- prjF op = constructFeat opts s (a :* Nil) -    constructFeatOpt sym@(C' GetLength) ((op :$ a :$ b) :* Nil)+    constructFeatOpt opts sym@(C' GetLength) ((op :$ a :$ b) :* Nil)         | Just (C' Append) <- prjF op = do-            aLen <- constructFeat sym (a :* Nil)-            bLen <- constructFeat sym (b :* Nil)-            constructFeatOpt (c' Add) (aLen :* bLen :* Nil)+            aLen <- constructFeat opts sym (a :* Nil)+            bLen <- constructFeat opts sym (b :* Nil)+            constructFeatOpt opts (c' Add) (aLen :* bLen :* Nil)         | Just (C' Parallel)  <- prjF op = return a         | Just (C' SetLength) <- prjF op = return a      -- TODO remove this optimization when the singletonRange -> literal-    -- optimization in Feldspar.Core.Interpretation has been implemented-    constructFeatOpt (C' GetLength) (arr :* Nil)+    -- optimization in Feldspar.Core.Interpretation has been implemented (issue #27)+    constructFeatOpt _ (C' GetLength) (arr :* Nil)         | len :> _ <- infoSize $ getInfo arr         , isSingleton len         = return $ literalDecor $ lowerBound len -    constructFeatOpt (C' SetLength) (len :* _ :* Nil)+    constructFeatOpt _ (C' SetLength) (len :* _ :* Nil)         | Just 0 <- viewLiteral len = return $ literalDecor [] -    constructFeatOpt (C' SetLength) ((getLength :$ arr') :* arr :* Nil)+    constructFeatOpt _ (C' SetLength) ((getLength :$ arr') :* arr :* Nil)         | Just (C' GetLength) <- prjF getLength         , alphaEq arr arr'         = return arr -    constructFeatOpt (C' SetLength) (len :* arr :* Nil)+    constructFeatOpt opts (C' SetLength) (len1 :* (par :$ len2 :$ ixf) :* Nil)+        | Just p@(C' Parallel) <- prjF par+        , alphaEq len1 len2+        = constructFeat opts p (len2 :* ixf :* Nil)++    constructFeatOpt opts (C' SetLength) (len1 :* (sq :$ len2 :$ ini :$ step) :* Nil)+        | Just s@(C' Sequential) <- prjF sq+        , alphaEq len1 len2+        = constructFeat opts s (len2 :* ini :* step :* Nil)++    constructFeatOpt _ (C' SetLength) (len :* arr :* Nil)         | rlen      <- infoSize $ getInfo len         , rarr :> _ <- infoSize $ getInfo arr         , isSingleton rlen@@ -241,7 +267,7 @@         , rlen == rarr         = return arr -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts a args = constructFeatUnOpt opts a args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -37,8 +38,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- -- | Interpretation of binding constructs  module Feldspar.Core.Constructs.Binding@@ -46,9 +45,12 @@     , optimizeLambda     , optimizeFunction --    , optimizeFunctionFix-    , prjLambda+    , subst     , betaReduce+    , prjLambda     , cLambda+    , reuseCLambda+    , collectLetBinders     ) where  import Control.Monad.Reader@@ -56,8 +58,7 @@ import Data.Map import Data.Typeable (Typeable, gcast) -import Data.Lens.Common-import Data.Proxy+--import Data.Lens.Common  import Language.Syntactic import Language.Syntactic.Constructs.Binding hiding (subst,betaReduce)@@ -71,20 +72,20 @@ instance Sharable Lambda    -- Will not be shared anyway because we disallow variables of `->` type instance Sharable Let --- | Should be a capture-avoiding substitution, but it is currently not correct.------ Note: Variables with a different type than the new expression will be--- silently ignored.-subst :: forall constr dom a b+instance Monotonic Variable+instance Monotonic Lambda+instance Monotonic Let++subst :: forall dom a b     .  ( Constrained dom        , CLambda Type :<: dom        , (Variable :|| Type) :<: dom        )-    => VarId       -- ^ Variable to be substituted+    => VarId                      -- ^ Variable to be substituted     -> ASTF (dom :|| Typeable) a  -- ^ Expression to substitute for     -> ASTF (dom :|| Typeable) b  -- ^ Expression to substitute in     -> ASTF (dom :|| Typeable) b-subst v new a = go a+subst v new = go   where     go :: AST (dom :|| Typeable) c -> AST (dom :|| Typeable) c     go a@((prjLambda -> Just (SubConstr2 (Lambda w))) :$ _)@@ -98,9 +99,7 @@         , Just new' <- gcast new         = new'     go a = a-  -- TODO Make it correct (may need to alpha-convert `new` before inserting it)-  -- TODO Should there be an error if `gcast` fails? (See note in Haddock-  --      comment.)+  -- TODO Should be possible to use the one in Syntactic instead  betaReduce     :: ( Constrained dom@@ -112,32 +111,65 @@     -> ASTF (dom :|| Typeable) b betaReduce new (lam :$ body)     | Just (SubConstr2 (Lambda v)) <- prjLambda lam = subst v new body+  -- TODO Should be possible to use the one in Syntactic instead  optimizeLambda :: ( CLambda Type :<: dom                   , OptimizeSuper dom)-    => (ASTF (dom :|| Typeable) b -> Opt (ASTF (Decor Info (dom :|| Typeable)) b))  -- ^ Optimization of the body+    => FeldOpts+    -> (ASTF (dom :|| Typeable) b -> Opt (ASTF (Decor Info (dom :|| Typeable)) b))  -- ^ Optimization of the body     -> Info a     -> CLambda Type (b :-> Full (a -> b))     -> Args (AST (dom :|| Typeable)) (b :-> Full (a -> b))     -> Opt (ASTF (Decor Info (dom :|| Typeable)) (a -> b))-optimizeLambda opt info lam@(SubConstr2 (Lambda v)) (body :* Nil)+optimizeLambda opts opt info lam@(SubConstr2 (Lambda v)) (body :* Nil)     | Dict <- exprDict body     = do         body' <- localVar v info $ opt body-        constructFeatUnOpt lam (body' :* Nil)+        constructFeatUnOpt opts lam (body' :* Nil)  -- | Assumes that the expression is a 'Lambda'-optimizeFunction :: ( CLambda Type :<: dom-                    , OptimizeSuper dom)-    => (ASTF (dom :|| Typeable) b -> Opt (ASTF (Decor Info (dom :|| Typeable)) b))  -- ^ Optimization of the body+optimizeFunction :: ( (Variable :|| Type) :<: dom+                    , CLambda Type :<: dom+                    , Let :<: dom+                    , OptimizeSuper dom+                    )+    => FeldOpts+    -> (ASTF (dom :|| Typeable) b -> Opt (ASTF (Decor Info (dom :|| Typeable)) b))  -- ^ Optimization of the body     -> Info a     -> (ASTF (dom :|| Typeable) (a -> b) -> Opt (ASTF (Decor Info (dom :|| Typeable)) (a -> b)))-optimizeFunction opt info a@(sym :$ body)+optimizeFunction opts opt info e+    | e'@(bs, _) <- collectLetBinders e+    , not (Prelude.null bs)+    = optimizeLet opts opt info e'+optimizeFunction opts opt info a@(sym :$ body)     | Dict <- exprDict a     , Dict <- exprDict body-    , Just (lam@(SubConstr2 (Lambda v))) <- prjLambda sym-    = optimizeLambda opt info lam (body :* Nil)+    , Just (lam@(SubConstr2 (Lambda _))) <- prjLambda sym+    = optimizeLambda opts opt info lam (body :* Nil)+optimizeFunction _ _ info a+    = error $ "optimizeFunction: AST is not a function: " ++ show a ++ "\n" ++ show (infoType info) +optimizeLet+    :: ( (Variable :|| Type) :<: dom+       , CLambda Type :<: dom+       , Let :<: dom+       , OptimizeSuper dom+       )+    => FeldOpts+    -> (ASTF (dom :|| Typeable) b -> Opt (ASTF (Decor Info (dom :|| Typeable)) b))  -- ^ Optimization of the body+    -> Info a+    -> ([(VarId, ASTB (dom :|| Typeable) Type)], ASTF (dom :|| Typeable) (a -> b))+    -> Opt (ASTF (Decor Info (dom :|| Typeable)) (a -> b))+optimizeLet opts opt info ((v, ASTB e):t, bd)+    | Dict <- exprDict bd+    , Dict <- exprDict e+    = do+      e'  <- optimizeM opts e+      bd' <- localVar v (getInfo e') $ optimizeLet opts opt info (t, bd)+      bd'' <- constructFeatUnOpt opts (cLambda v) (bd' :* Nil)+      constructFeatUnOpt opts Let (e' :* bd'' :* Nil)+optimizeLet opts opt info ([], e) = optimizeFunction opts opt info e+ {- optimizeFunBody :: (Lambda TypeCtx :<: dom, Optimize dom dom, Typeable a)     => (ASTF dom a -> Opt (ASTF (Decor Info dom) a))  -- ^ Optimization of the body@@ -179,14 +211,13 @@               -- in very special cases.          constructFeatUnOpt (Lambda v `withContext` typeCtx) (body' :* Nil)- -}  instance ( (Variable :|| Type) :<: dom          , OptimizeSuper dom)       => Optimize (Variable :|| Type) dom   where-    constructFeatUnOpt var@(C' (Variable v)) Nil+    constructFeatUnOpt _ (C' (Variable v)) Nil         = reader $ \env -> case Prelude.lookup v (varEnv env) of             Nothing -> error $                 "optimizeFeat: can't get size of free variable: v" ++ show v@@ -201,51 +232,120 @@     -- | Assigns a 'universal' size to the bound variable. This only makes sense     -- for top-level lambdas. For other uses, use 'optimizeLambda' instead. -    optimizeFeat lam@(SubConstr2 (Lambda v))+    optimizeFeat opts lam@(SubConstr2 (Lambda _))         | Dict <- exprDict lam-        = optimizeLambda optimizeM (mkInfo universal) lam+        = optimizeLambda opts (optimizeM opts) (mkInfo universal) lam -    constructFeatUnOpt lam@(SubConstr2 (Lambda v)) (body :* Nil)+    constructFeatUnOpt _ lam@(SubConstr2 (Lambda v)) (body :* Nil)         | Dict <- exprDict lam         , Info t sz vars _ <- getInfo body         = do             src <- asks sourceEnv-            let info = Info (FunType typeRep t) sz (delete v vars) src+            let info = Info (FunType typeRep t) (universal, sz) (delete v vars) src             return $ (Sym $ Decor info $ C' $ inj lam) :$ body -instance SizeProp (Let :|| Type)+instance SizeProp Let   where-    sizeProp (C' Let) (_ :* WrapFull f :* Nil) = infoSize f+    sizeProp Let (_ :* WrapFull f :* Nil) = snd $ infoSize f  instance-    ( (Let      :|| Type) :<: dom+    ( Let                 :<: dom     , (Variable :|| Type) :<: dom     , CLambda Type        :<: dom     , OptimizeSuper dom     ) =>-      Optimize (Let :|| Type) dom+      Optimize Let dom   where-    optimizeFeat lt@(C' Let) (a :* f :* Nil) = do-        a' <- optimizeM a-        f' <- optimizeFunction optimizeM (getInfo a') f-        case getInfo f' of-          Info{} -> constructFeat lt (a' :* f' :* Nil)-            -- TODO Why is this pattern match needed?+    optimizeFeat opts lt@Let (a :* f :* Nil) = do+        a' <- optimizeM opts a+        f' <- optimizeFunction opts (optimizeM opts) (getInfo a') f+        constructFeat opts lt (a' :* f' :* Nil) -    constructFeatOpt (C' Let) (a :* (lam :$ var) :* Nil)+    constructFeatOpt _ Let (a :* (lam :$ var) :* Nil)         | Just (C' (Variable v2))       <- prjF var         , Just (SubConstr2 (Lambda v1)) <- prjLambda lam         , v1 == v2         = return $ fromJust $ gcast a -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts Let (var :* f :* Nil)+        | Just (C' (Variable _)) <- prjF var+        = optimizeM opts $ betaReduce (stripDecor var) (stripDecor f) -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+      -- (letBind (letBind e1 (\x -> e2)) (\y -> e3) ==>+      --           letBind e1 (\x -> letBind e2 (\y-> e3))+      --+      -- Test case:+      --+      -- stestL2 :: Data Index -> Data Length -> Data [[Index]]+      -- stestL2 m x = parallel x (\x1 -> let z = let y = x `mod` m in (y, y) in parallel 2 (\x -> fst z))+    constructFeatOpt opts lt1@Let ((lt2 :$ x :$ (lam :$ bd)) :* y :* Nil)+        | Just Let <- prj lt2+        , Just lam'@(SubConstr2 (Lambda _)) <- prjLambda lam+        , SICS `inTarget` opts+        = do+             bb <- constructFeat opts lt1 (bd :* y :* Nil)+             bd' <- constructFeat opts (reuseCLambda lam') (bb :* Nil)+             constructFeatUnOpt opts Let (x :* bd' :* Nil) +    -- Hoist let-bound constants upwards.+    --+    -- (letBind e1 (\x -> letBind v (\y -> e2)) ==>+    --           letBind v (\y -> letBind e1 (\x-> e2))+    constructFeatOpt opts lt1@Let (e :* (lam1 :$ (lt2 :$ v :$ (lam2 :$ bd))) :* Nil)+        | Just Let <- prj lt2+        , Nothing <- viewLiteral e+        , Just _ <- viewLiteral v+        , Just lam1'@(SubConstr2 (Lambda{})) <- prjLambda lam1+        , Just lam2'@(SubConstr2 (Lambda{})) <- prjLambda lam2+        , SICS `inTarget` opts+        = do+             bb  <- constructFeat opts (reuseCLambda lam1') (bd :* Nil)+             bb' <- constructFeat opts lt1 (e :* bb :* Nil)+             bd' <- constructFeat opts (reuseCLambda lam2') (bb' :* Nil)+             constructFeatUnOpt opts Let (v :* bd' :* Nil)++    constructFeatOpt opts a args = constructFeatUnOpt opts a args++    constructFeatUnOpt opts Let args@(_ :* (lam :$ body) :* Nil)+        | Just (SubConstr2 (Lambda _)) <- prjLambda lam+        , Info {infoType = t} <- getInfo body+        = constructFeatUnOptDefaultTyp opts t Let args+ prjLambda :: (Project (CLambda Type) dom)           => dom sig -> Maybe (CLambda Type sig) prjLambda = prj  cLambda :: Type a => VarId -> CLambda Type (b :-> Full (a -> b)) cLambda = SubConstr2 . Lambda++-- | Allow an existing binding to be used with a body of a different type+reuseCLambda :: CLambda Type (b :-> Full (a -> b)) -> CLambda Type (c :-> Full (a -> c))+reuseCLambda (SubConstr2 (Lambda v)) = SubConstr2 (Lambda v)++-- | Collects the immediate let bindings in a list and returns the first non-let expression+--+-- This function can be useful when let bindings get in the way of pattern matching on a+-- sub-expressions.+collectLetBinders :: forall dom a .+                   ( Project Let dom+                   , Project (CLambda Type) dom+                   , ConstrainedBy dom Typeable+                   ) => ASTF dom a ->+                   ( [(VarId, ASTB dom Type)]+                   , ASTF dom a+                   )+collectLetBinders = go []+  where+    go+      :: [(VarId, ASTB dom Type)]+      -> ASTF dom a+      -> ( [(VarId, ASTB dom Type)]+         , ASTF dom a+         )+    go bs (lt :$ e :$ (lam :$ body))+      | Just (SubConstr2 (Lambda v)) <- prjLambda lam+      , Just Let <- prj lt+      , Dict <- exprDict e+      = go ((v, ASTB e):bs) body+    go bs e = (reverse bs, e) 

@@ -1,8 +1,12 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,8 +37,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- -- | Implementation of constructs and operations on 'Bits' module Feldspar.Core.Constructs.Bits     ( BITS (..)@@ -53,7 +55,12 @@ import Feldspar.Core.Constructs.Eq import Feldspar.Core.Constructs.Ord +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 import Data.Bits+#else+import Data.Bits+type FiniteBits b = Bits b+#endif  -- | Bits constructs data BITS a@@ -82,8 +89,6 @@     BitScan       :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Index)     BitCount      :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Index) -    IsSigned      :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Bool)- instance Semantic BITS   where     semantics BAnd          = Sem "(.&.)"      (.&.)@@ -97,12 +102,12 @@     semantics ComplementBit = Sem "complementBit" (liftIntWord complementBit)     semantics TestBit       = Sem "testBit"       (liftIntWord testBit) -    semantics ShiftLU       = Sem "shiftL"      (liftIntWord shiftL)-    semantics ShiftRU       = Sem "shiftR"      (liftIntWord shiftR)+    semantics ShiftLU       = Sem "shiftLU"     (liftIntWord shiftL)+    semantics ShiftRU       = Sem "shiftRU"     (liftIntWord shiftR)     semantics ShiftL        = Sem "shiftL"      (liftInt shiftL)     semantics ShiftR        = Sem "shiftR"      (liftInt shiftR)-    semantics RotateLU      = Sem "rotateL"     (liftIntWord rotateL)-    semantics RotateRU      = Sem "rotateR"     (liftIntWord rotateR)+    semantics RotateLU      = Sem "rotateLU"    (liftIntWord rotateL)+    semantics RotateRU      = Sem "rotateRU"    (liftIntWord rotateR)     semantics RotateL       = Sem "rotateL"     (liftInt rotateL)     semantics RotateR       = Sem "rotateR"     (liftInt rotateR)     semantics ReverseBits   = Sem "reverseBits" evalReverseBits@@ -110,50 +115,56 @@     semantics BitScan       = Sem "bitScan"  evalBitScan     semantics BitCount      = Sem "bitCount" evalBitCount -    semantics IsSigned      = Sem "isSigned" isSigned- liftIntWord :: (a -> Int -> b) -> (a -> WordN -> b) liftIntWord f x = f x . fromIntegral  liftInt :: (a -> Int -> b) -> (a -> IntN -> b) liftInt f x = f x . fromIntegral -evalReverseBits :: (Num b, Bits b) => b -> b+evalReverseBits :: (Num b, FiniteBits b) => b -> b evalReverseBits b = revLoop b 0 (0 `asTypeOf` b)   where-    bSz = bitSize b+    bSz = finiteBitSize b     revLoop x i n | i >= bSz    = n                   | testBit x i = revLoop x (i+1) (setBit n (bSz - i - 1))                   | otherwise   = revLoop x (i+1) n -evalBitScan :: Bits b => b -> WordN+evalBitScan :: (FiniteBits b) => b -> WordN evalBitScan b =    if isSigned b-   then scanLoop b (testBit b (bitSize b - 1)) (bitSize b - 2) 0-   else scanLoop b False (bitSize b - 1) 0+   then scanLoop b (testBit b (finiteBitSize b - 1)) (finiteBitSize b - 2) 0+   else scanLoop b False (finiteBitSize b - 1) 0   where     scanLoop x t i n | i Prelude.< 0            = n                      | testBit x i Prelude./= t = n                      | otherwise                = scanLoop x t (i-1) (n+1) -evalBitCount :: Bits b => b -> WordN-evalBitCount b = loop b (bitSize b - 1) 0+evalBitCount :: (FiniteBits b) => b -> WordN+evalBitCount b = loop b (finiteBitSize b - 1) 0   where     loop x i n | i Prelude.< 0 = n                | testBit x i   = loop x (i-1) (n+1)                | otherwise     = loop x (i-1) n -instance Equality BITS where equal = equalDefault; exprHash = exprHashDefault-instance Render   BITS where renderArgs = renderArgsDefault-instance ToTree   BITS-instance Eval     BITS where evaluate = evaluateDefault+semanticInstances ''BITS+ instance EvalBind BITS where evalBindSym = evalBindSymDefault-instance Sharable BITS  instance AlphaEq dom dom dom env => AlphaEq BITS BITS dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable BITS++instance Monotonic BITS where+    monotonicInc _ _ = []++    monotonicDec ShiftRU (a :* b :* Nil)+        | RangeSet r <- infoRange $ getInfo b+        , isNatural r+        = [a]+    monotonicDec _ _ = []+ instance SizeProp (BITS :|| Type)   where     sizeProp (C' BAnd) (WrapFull a :* WrapFull b :* Nil) = rangeAnd (infoSize a) (infoSize b)@@ -172,55 +183,68 @@          , (Logic :|| Type) :<: dom          , (EQ    :|| Type) :<: dom          , (ORD   :|| Type) :<: dom+         , Monotonic dom          , OptimizeSuper dom          )       => Optimize (BITS :|| Type) dom   where-    constructFeatOpt (C' BAnd) (a :* b :* Nil)+    constructFeatOpt _ (C' BAnd) (a :* b :* Nil)         | Just 0 <- viewLiteral a              = return a         | Just x <- viewLiteral a, isAllOnes x = return b         | Just 0 <- viewLiteral b              = return b         | Just x <- viewLiteral b, isAllOnes x = return a -    constructFeatOpt (C' BOr) (a :* b :* Nil)+    constructFeatOpt _ (C' BOr) (a :* b :* Nil)         | Just 0 <- viewLiteral a              = return b         | Just x <- viewLiteral a, isAllOnes x = return a         | Just 0 <- viewLiteral b              = return a         | Just x <- viewLiteral b, isAllOnes x = return b -    constructFeatOpt (C' BXor) (a :* b :* Nil)+    constructFeatOpt opts (C' BXor) (a :* b :* Nil)         | Just 0 <- viewLiteral a              = return b-        | Just x <- viewLiteral a, isAllOnes x = constructFeat (c' Complement) (b :* Nil)+        | Just x <- viewLiteral a, isAllOnes x = constructFeat opts (c' Complement) (b :* Nil)         | Just 0 <- viewLiteral b              = return a-        | Just x <- viewLiteral b, isAllOnes x = constructFeat (c' Complement) (a :* Nil)+        | Just x <- viewLiteral b, isAllOnes x = constructFeat opts (c' Complement) (a :* Nil) -    constructFeatOpt (C' BXor) ((xo :$ v1 :$ v2) :* v3 :* Nil)+    constructFeatOpt _ (C' BXor) ((xo :$ v1 :$ v2) :* v3 :* Nil)         | Just (C' BXor) <- prjF xo         , alphaEq v2 v3         = return v1 -    constructFeatOpt (C' TestBit) ((xo :$ v1 :$ v2) :* v3 :* Nil)+    -- complement . complement ==> id+    constructFeatOpt _ (C' Complement) ((cmpl :$ a) :* Nil)+        | Just (C' Complement) <- prjF cmpl+        = return a++    constructFeatOpt opts (C' TestBit) ((xo :$ v1 :$ v2) :* v3 :* Nil)         | Just (C' BXor) <- prjF xo         , Just a <- viewLiteral v2         , Just b <- viewLiteral v3         , a == 2 ^ b-        = do tb <- constructFeat (c' TestBit) (v1 :* v3 :* Nil)-             constructFeat (c' Not) (tb :* Nil)+        = do tb <- constructFeat opts (c' TestBit) (v1 :* v3 :* Nil)+             constructFeat opts (c' Not) (tb :* Nil) -    constructFeatOpt x@(C' ShiftLU)  args = optZero x args-    constructFeatOpt x@(C' ShiftRU)  args = optZero x args-    constructFeatOpt x@(C' ShiftL)   args = optZero x args-    constructFeatOpt x@(C' ShiftR)   args = optZero x args-    constructFeatOpt x@(C' RotateLU) args = optZero x args-    constructFeatOpt x@(C' RotateRU) args = optZero x args-    constructFeatOpt x@(C' RotateL)  args = optZero x args-    constructFeatOpt x@(C' RotateR)  args = optZero x args+    -- shiftRU (shiftRU b i) j ==> shiftRU b (shiftRU i j)+    constructFeatOpt opts x@(C' ShiftRU) ((op :$ a :$ b) :* c :* Nil)+        | Just (C' ShiftRU) <- prjF op+        , Just i <- viewLiteral a+        , Just j <- viewLiteral c+        = constructFeat opts x (literalDecor (i `shiftR` fromIntegral j) :* b :* Nil) -    constructFeatOpt feat args = constructFeatUnOpt feat args+    constructFeatOpt opts x@(C' ShiftLU)  args = optZero opts x args+    constructFeatOpt opts x@(C' ShiftRU)  args = optZero opts x args+    constructFeatOpt opts x@(C' ShiftL)   args = optZero opts x args+    constructFeatOpt opts x@(C' ShiftR)   args = optZero opts x args+    constructFeatOpt opts x@(C' RotateLU) args = optZero opts x args+    constructFeatOpt opts x@(C' RotateRU) args = optZero opts x args+    constructFeatOpt opts x@(C' RotateL)  args = optZero opts x args+    constructFeatOpt opts x@(C' RotateR)  args = optZero opts x args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatOpt opts feat args = constructFeatUnOpt opts feat args +    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x + isAllOnes :: (Num a, Bits a) => a -> Bool isAllOnes x = x Prelude.== complement 0 @@ -229,10 +253,10 @@            , Typeable a            , Optimize feature dom            )-        => feature (a :-> (b :-> Full a))+        => FeldOpts -> feature (a :-> (b :-> Full a))         -> Args (AST (Decor Info (dom :|| Typeable))) (a :-> (b :-> Full a))         -> Opt (AST (Decor Info (dom :|| Typeable)) (Full a))-optZero f (a :* b :* Nil)+optZero opts f (a :* b :* Nil)     | Just 0 <- viewLiteral b = return a-    | otherwise               = constructFeatUnOpt f (a :* b :* Nil)+    | otherwise               = constructFeatUnOpt opts f (a :* b :* Nil) 

@@ -1,7 +1,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +34,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Complex where @@ -67,58 +67,59 @@     semantics Phase     = Sem "phase"     phase     semantics Cis       = Sem "cis"       cis -instance Equality COMPLEX where equal = equalDefault; exprHash = exprHashDefault-instance Render   COMPLEX where renderArgs = renderArgsDefault-instance ToTree   COMPLEX-instance Eval     COMPLEX where evaluate = evaluateDefault+semanticInstances ''COMPLEX+ instance EvalBind COMPLEX where evalBindSym = evalBindSymDefault++instance AlphaEq dom dom dom env => AlphaEq COMPLEX COMPLEX dom env+  where+    alphaEqSym = alphaEqSymDefault+ instance Sharable COMPLEX +instance Monotonic COMPLEX+ instance SizeProp (COMPLEX :|| Type)   where     sizeProp (C' s) = sizePropDefault s -instance AlphaEq dom dom dom env => AlphaEq COMPLEX COMPLEX dom env-  where-    alphaEqSym = alphaEqSymDefault- instance ( (COMPLEX :|| Type) :<: dom          , OptimizeSuper dom)       => Optimize (COMPLEX :|| Type) dom   where-    constructFeatOpt (C' MkComplex) ((rp :$ a) :* (ip :$ b) :* Nil)+    constructFeatOpt _ (C' MkComplex) ((rp :$ a) :* (ip :$ b) :* Nil)         | Just (C' RealPart) <- prjF rp         , Just (C' ImagPart) <- prjF ip         , alphaEq a b         = return a -    constructFeatOpt (C' RealPart) ((mkc :$ r :$ _) :* Nil)+    constructFeatOpt _ (C' RealPart) ((mkc :$ r :$ _) :* Nil)         | Just (C' MkComplex) <- prjF mkc         = return r -    constructFeatOpt (C' ImagPart) ((mkc :$ _ :$ i) :* Nil)+    constructFeatOpt _ (C' ImagPart) ((mkc :$ _ :$ i) :* Nil)         | Just (C' MkComplex) <- prjF mkc         = return i -    constructFeatOpt (C' MkPolar) ((mag :$ a) :* (ph :$ b) :* Nil)+    constructFeatOpt _ (C' MkPolar) ((mag :$ a) :* (ph :$ b) :* Nil)         | Just (C' Magnitude) <- prjF mag         , Just (C' Phase)     <- prjF ph         , alphaEq a b         = return a -    constructFeatOpt (C' Magnitude) ((mkp :$ m :$ _) :* Nil)+    constructFeatOpt _ (C' Magnitude) ((mkp :$ m :$ _) :* Nil)         | Just (C' MkPolar) <- prjF mkp         = return m -    constructFeatOpt (C' Phase) ((mkp :$ _ :$ p) :* Nil)+    constructFeatOpt _ (C' Phase) ((mkp :$ _ :$ p) :* Nil)         | Just (C' MkPolar) <- prjF mkp         = return p -    constructFeatOpt (C' Conjugate) ((conj :$ a) :* Nil)+    constructFeatOpt _ (C' Conjugate) ((conj :$ a) :* Nil)         | Just (C' Conjugate) <- prjF conj         = return a -    constructFeatOpt sym args = constructFeatUnOpt sym args+    constructFeatOpt opts sym args = constructFeatUnOpt opts sym args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -3,6 +3,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,23 +34,30 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Condition     ( module Language.Syntactic.Constructs.Condition     ) where  import Language.Syntactic-import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Binding hiding (subst)+import Language.Syntactic.Constructs.Binding.HigherOrder (CLambda(..))+import Language.Syntactic.Constructs.Literal import Language.Syntactic.Constructs.Condition  import Feldspar.Lattice import Feldspar.Core.Types import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Eq+import Feldspar.Core.Constructs.Ord import Feldspar.Core.Constructs.Logic+import Feldspar.Core.Constructs.Binding (subst) +import Data.Typeable (Typeable)+ instance Sharable Condition +instance Monotonic Condition+ instance SizeProp (Condition :|| Type)   where     sizeProp (C' Condition) (_ :* WrapFull t :* WrapFull f :* Nil)@@ -57,26 +65,70 @@  instance ( (Condition :|| Type) :<: dom          , (Logic     :|| Type) :<: dom+         , (EQ        :|| Type) :<: dom+         , (ORD       :|| Type) :<: dom+         , (Variable  :|| Type) :<: dom+         , CLambda Type :<: dom+         , Monotonic dom          , OptimizeSuper dom          )       => Optimize (Condition :|| Type) dom   where-    constructFeatOpt (C' Condition) (c :* t :* f :* Nil)-        | Just c' <- viewLiteral c = return $ if c' then t else f+    -- If the condition is a variable, substitute for True/False in each+    -- branch+    optimizeFeat opts s@(C' Condition) (c :* t :* f :* Nil)+        | Just (C' (Variable v)) <- prjF c+        = optimizeFeatDefault opts s $ c :* subst v (literal True) t+                                         :* subst v (literal False) f+                                         :* Nil -    constructFeatOpt (C' Condition) (_ :* t :* f :* Nil)+    -- If condition is (a == b) and either a or b is a variable,+    -- substitute for the other in the True branch+    optimizeFeat opts s@(C' Condition) (c@(op :$ a :$ b) :* t :* f :* Nil)+        | Just (C' Equal) <- prjF op+        , Just (C' (Variable v)) <- prjF b+        = optimizeFeatDefault opts s $ c :* subst v a t :* f :* Nil++        | Just (C' Equal) <- prjF op+        , Just (C' (Variable v)) <- prjF a+        = optimizeFeatDefault opts s $ c :* subst v b t :* f :* Nil++    -- If condition is (a /= b) and either a or b is a variable,+    -- substitute for the other in the False branch+    optimizeFeat opts s@(C' Condition) (c@(op :$ a :$ b) :* t :* f :* Nil)+        | Just (C' NotEqual) <- prjF op+        , Just (C' (Variable v)) <- prjF b+        = optimizeFeatDefault opts s $ c :* t :* subst v a f :* Nil++        | Just (C' NotEqual) <- prjF op+        , Just (C' (Variable v)) <- prjF a+        = optimizeFeatDefault opts s $ c :* t :* subst v b f :* Nil++    optimizeFeat opts sym args = optimizeFeatDefault opts sym args++    -- If the condition is a literal, shortcut the condition+    constructFeatOpt opts (C' Condition) (c :* t :* f :* Nil)+        | Just cl <- viewLiteral c = return $ if cl then t else f++    -- If the branches a Boolean literals, shortcut as a truth table+    constructFeatOpt opts (C' Condition) (c :* t :* f :* Nil)+        | BoolType <- infoType (getInfo t)+        , Just tl <- viewLiteral t+        , Just fl <- viewLiteral f+        = case (tl,fl) of+            (True,False) -> return c+            (False,True) -> constructFeat opts (c' Not) (c :* Nil)++    -- It the branches are equal, the choice doesn't matter+    constructFeatOpt _ (C' Condition) (_ :* t :* f :* Nil)         | alphaEq t f = return t -    constructFeatOpt cond@(C' Condition) ((op :$ c) :* t :* f :* Nil)+    -- Invert a negated condition+    constructFeatOpt opts cond@(C' Condition) ((op :$ c) :* t :* f :* Nil)         | Just (C' Not) <- prjF op-        = constructFeat cond (c :* f :* t :* Nil)--    constructFeatOpt a args = constructFeatUnOpt a args+        = constructFeat opts cond (c :* f :* t :* Nil) -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatOpt opts a args = constructFeatUnOpt opts a args -      -- TODO Propagate size information from the condition to the branches. For-      --      example-      ---      --        condition (x<10) (min x 20) x  ==>  x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +33,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.ConditionM     ( ConditionM (..)     ) where@@ -49,7 +48,6 @@   where     ConditionM :: (Monad m, Type a) =>                   ConditionM m (Bool :-> m a :-> m a :-> Full (m a))-    -- TODO Can't we just use `Condition` instead?  instance Semantic (ConditionM m)   where@@ -57,13 +55,14 @@       where         ifM cond e t = if cond then e else t -instance Equality (ConditionM m) where equal = equalDefault; exprHash = exprHashDefault-instance Render   (ConditionM m) where renderArgs = renderArgsDefault-instance ToTree   (ConditionM m)-instance Eval     (ConditionM m) where evaluate = evaluateDefault-instance EvalBind (ConditionM m) where evalBindSym = evalBindSymDefault-instance Sharable (ConditionM m)-  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'+instance Equality   (ConditionM m) where equal = equalDefault; exprHash = exprHashDefault+instance Render     (ConditionM m) where renderSym  = renderSymDefault+                                         renderArgs = renderArgsDefault+instance StringTree (ConditionM m)+instance Eval       (ConditionM m) where evaluate = evaluateDefault+instance EvalBind   (ConditionM m) where evalBindSym = evalBindSymDefault+instance Sharable   (ConditionM m)+instance Monotonic  (ConditionM m)  instance AlphaEq dom dom dom env =>     AlphaEq (ConditionM m) (ConditionM m) dom env@@ -82,24 +81,19 @@          )       => Optimize (ConditionM m) dom   where-    constructFeatOpt ConditionM (c :* t :* f :* Nil)-        | Just c' <- viewLiteral c = return $ if c' then t else f+    constructFeatOpt _ ConditionM (c :* t :* f :* Nil)+        | Just cl <- viewLiteral c = return $ if cl then t else f -    constructFeatOpt ConditionM (_ :* t :* f :* Nil)+    constructFeatOpt _ ConditionM (_ :* t :* f :* Nil)         | alphaEq t f = return t -    constructFeatOpt cond@ConditionM ((op :$ c) :* t :* f :* Nil)+    constructFeatOpt opts cond@ConditionM ((op :$ c) :* t :* f :* Nil)         | Just (C' Not) <- prjF op-        = constructFeat cond (c :* f :* t :* Nil)+        = constructFeat opts cond (c :* f :* t :* Nil) -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts a args = constructFeatUnOpt opts a args -    constructFeatUnOpt ConditionM args@(_ :* t :* _ :* Nil)+    constructFeatUnOpt opts ConditionM args@(_ :* t :* _ :* Nil)         | Info {infoType = tType} <- getInfo t-        = constructFeatUnOptDefaultTyp tType ConditionM args--      -- TODO Propagate size information from the condition to the branches. For-      --      example-      ---      --        condition (x<10) (min x 20) x  ==>  x+        = constructFeatUnOptDefaultTyp opts tType ConditionM args 

@@ -2,9 +2,11 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -35,8 +37,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Conversion     ( Conversion (..)     ) where@@ -51,15 +51,19 @@  data Conversion a   where-    F2I     :: (Type a, Integral a) => Conversion (Float :-> Full a)+    F2I     :: (Type a, Integral a, RealFloat b) => Conversion (b :-> Full a)     I2N     :: (Type a, Type b, Integral a, Num b                ,Size a ~ Range a                ) =>                Conversion (a :-> Full b)-    B2I     :: (Type a, Integral a) => Conversion (Bool  :-> Full a)-    Round   :: (Type a, Integral a) => Conversion (Float :-> Full a)-    Ceiling :: (Type a, Integral a) => Conversion (Float :-> Full a)-    Floor   :: (Type a, Integral a) => Conversion (Float :-> Full a)+    B2I     :: (Type a, Integral a)+            => Conversion (Bool  :-> Full a)+    Round   :: (Type a, Integral a, RealFloat b)+            => Conversion (b :-> Full a)+    Ceiling :: (Type a, Integral a, RealFloat b)+            => Conversion (b :-> Full a)+    Floor   :: (Type a, Integral a, RealFloat b)+            => Conversion (b :-> Full a)  rangeToSize :: Lattice (Size a) => TypeRep a -> Range Integer -> Size a rangeToSize (IntType _ _) r = rangeProp r@@ -82,23 +86,24 @@     semantics Ceiling = Sem "ceiling" ceiling     semantics Floor   = Sem "floor"   floor -instance Equality Conversion where equal = equalDefault; exprHash = exprHashDefault-instance Render   Conversion where renderArgs = renderArgsDefault-instance Eval     Conversion where evaluate = evaluateDefault-instance ToTree   Conversion+semanticInstances ''Conversion+ instance EvalBind Conversion where evalBindSym = evalBindSymDefault-instance Sharable Conversion  instance AlphaEq dom dom dom env => AlphaEq Conversion Conversion dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable Conversion++instance Monotonic Conversion+ instance SizeProp (Conversion :|| Type)   where     sizeProp (C' F2I)     _ = universal     sizeProp (C' i2n@I2N) (WrapFull a :* Nil)         = rangeToSize (resultType i2n) (mapMonotonic toInteger (infoSize a))-    sizeProp (C' B2I)     _ = universal+    sizeProp (C' b2i@B2I) _ = rangeToSize (resultType b2i) $ range 0 1     sizeProp (C' Round)   _ = universal     sizeProp (C' Ceiling) _ = universal     sizeProp (C' Floor)   _ = universal@@ -107,11 +112,11 @@          , OptimizeSuper dom)       => Optimize (Conversion :|| Type) dom   where-    constructFeatOpt (C' i2n@I2N) (a :* Nil)+    constructFeatOpt _ (C' i2n@I2N) (a :* Nil)         | Just TypeEq <- typeEq (resultType i2n) (infoType $ getInfo a)         = return a -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts a args = constructFeatUnOpt opts a args -    constructFeatUnOpt a@(C' _) = constructFeatUnOptDefault a+    constructFeatUnOpt opts a@(C' _) = constructFeatUnOptDefault opts a 

@@ -1,7 +1,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +34,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- -- | Implementation of Equality constructs  module Feldspar.Core.Constructs.Eq@@ -57,43 +57,44 @@     semantics Equal    = Sem "(==)" (==)     semantics NotEqual = Sem "(/=)" (/=) -instance Equality EQ where equal = equalDefault; exprHash = exprHashDefault-instance Render   EQ where renderArgs = renderArgsDefault-instance ToTree   EQ-instance Eval     EQ where evaluate = evaluateDefault+semanticInstances ''EQ+ instance EvalBind EQ where evalBindSym = evalBindSymDefault-instance Sharable EQ  instance AlphaEq dom dom dom env => AlphaEq EQ EQ dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable EQ++instance Monotonic EQ+ instance SizeProp (EQ :|| Type)   where sizeProp a@(C' _) = sizePropDefault a  instance ((EQ :|| Type) :<: dom, OptimizeSuper dom) => Optimize (EQ :|| Type) dom   where-    constructFeatOpt (C' Equal) (a :* b :* Nil)+    constructFeatOpt _ (C' Equal) (a :* b :* Nil)         | alphaEq a b         = return $ literalDecor True -    constructFeatOpt (C' Equal) (a :* b :* Nil)+    constructFeatOpt _ (C' Equal) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , ra `disjoint` rb         = return $ literalDecor False -    constructFeatOpt (C' NotEqual) (a :* b :* Nil)+    constructFeatOpt _ (C' NotEqual) (a :* b :* Nil)         | alphaEq a b         = return $ literalDecor False -    constructFeatOpt (C' NotEqual) (a :* b :* Nil)+    constructFeatOpt _ (C' NotEqual) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , ra `disjoint` rb         = return $ literalDecor True -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts a args = constructFeatUnOpt opts a args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +33,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Error where  import Language.Syntactic@@ -55,15 +54,15 @@  instance Render Error   where-    render Undefined    = "undefined"-    render (Assert msg) = "assert " ++ show msg+    renderSym Undefined    = "undefined"+    renderSym (Assert msg) = "assert " ++ show msg -instance Equality Error where equal = equalDefault; exprHash = exprHashDefault-instance ToTree   Error-instance Eval     Error where evaluate = evaluateDefault-instance EvalBind Error where evalBindSym = evalBindSymDefault---instance SizeProp Error where sizeProp = sizePropDefault-instance Sharable Error+instance Equality   Error where equal = equalDefault; exprHash = exprHashDefault+instance StringTree Error+instance Eval       Error where evaluate = evaluateDefault+instance EvalBind   Error where evalBindSym = evalBindSymDefault+instance Sharable   Error+instance Monotonic  Error  instance SizeProp (Error :|| Type)   where@@ -76,5 +75,5 @@ instance ((Error :|| Type) :<: dom, Optimize dom dom)     => Optimize (Error :|| Type) dom   where-    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,8 +35,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.FFI where  import Language.Syntactic@@ -52,17 +52,18 @@   where     semantics (ForeignImport name f) = Sem name f -instance Equality FFI where equal = equalDefault; exprHash = exprHashDefault-instance Render   FFI where renderArgs = renderArgsDefault-instance ToTree   FFI-instance Eval     FFI where evaluate = evaluateDefault+semanticInstances ''FFI+ instance EvalBind FFI where evalBindSym = evalBindSymDefault-instance Sharable FFI  instance AlphaEq dom dom dom env => AlphaEq FFI FFI dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable FFI++instance Monotonic FFI+ instance SizeProp (FFI :|| Type)   where     sizeProp (C' s) = sizePropDefault s@@ -72,5 +73,5 @@          )       => Optimize (FFI :|| Type) dom   where-    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -1,7 +1,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +34,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Floating     ( FLOATING (..)     ) where@@ -86,24 +86,25 @@     semantics Atanh   = Sem "atanh"   Prelude.atanh     semantics Acosh   = Sem "acosh"   Prelude.acosh -instance Equality FLOATING where equal = equalDefault; exprHash = exprHashDefault-instance Render   FLOATING where renderArgs = renderArgsDefault-instance ToTree   FLOATING-instance Eval     FLOATING where evaluate = evaluateDefault+semanticInstances ''FLOATING+ instance EvalBind FLOATING where evalBindSym = evalBindSymDefault++instance AlphaEq dom dom dom env => AlphaEq FLOATING FLOATING dom env+  where+    alphaEqSym = alphaEqSymDefault+ instance Sharable FLOATING +instance Monotonic FLOATING+ instance SizeProp (FLOATING :|| Type)   where     sizeProp (C' s) = sizePropDefault s -instance AlphaEq dom dom dom env => AlphaEq FLOATING FLOATING dom env-  where-    alphaEqSym = alphaEqSymDefault- instance ( (FLOATING :|| Type) :<: dom          , OptimizeSuper dom)       => Optimize (FLOATING :|| Type) dom   where-    constructFeatUnOpt a@(C' _) = constructFeatUnOptDefault a+    constructFeatUnOpt opts a@(C' _) = constructFeatUnOptDefault opts a 

@@ -1,7 +1,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +34,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Fractional     ( FRACTIONAL (..)     ) where@@ -53,17 +53,18 @@   where     semantics DivFrac = Sem "(/)" (/) -instance Equality FRACTIONAL where equal = equalDefault; exprHash = exprHashDefault-instance Render   FRACTIONAL where renderArgs = renderArgsDefault-instance ToTree   FRACTIONAL-instance Eval     FRACTIONAL where evaluate = evaluateDefault+semanticInstances ''FRACTIONAL+ instance EvalBind FRACTIONAL where evalBindSym = evalBindSymDefault-instance Sharable FRACTIONAL  instance SizeProp (FRACTIONAL :|| Type)   where     sizeProp (C' s) = sizePropDefault s +instance Sharable FRACTIONAL++instance Monotonic FRACTIONAL+ instance AlphaEq dom dom dom env => AlphaEq FRACTIONAL FRACTIONAL dom env   where     alphaEqSym = alphaEqSymDefault@@ -73,21 +74,21 @@          , OptimizeSuper dom)       => Optimize (FRACTIONAL :|| Type) dom   where-    constructFeatOpt (C' DivFrac) (a :* b :* Nil)+    constructFeatOpt _ (C' DivFrac) (a :* b :* Nil)         | Just 1 <- viewLiteral b = return a         | alphaEq a b = return $ literalDecor 1 -    constructFeatOpt (C' DivFrac) ((op :$ a :$ b) :* c :* Nil)+    constructFeatOpt _ (C' DivFrac) ((op :$ a :$ b) :* c :* Nil)         | Just (C' Mul) <- prjF op         , alphaEq b c         = return a -    constructFeatOpt (C' DivFrac) ((op :$ a :$ b) :* c :* Nil)+    constructFeatOpt _ (C' DivFrac) ((op :$ a :$ b) :* c :* Nil)         | Just (C' Mul) <- prjF op         , alphaEq a c         = return b -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts a args = constructFeatUnOpt opts a args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,8 +35,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Future where  import Language.Syntactic@@ -52,17 +52,21 @@     semantics MkFuture = Sem "future" FVal     semantics Await    = Sem "await"  unFVal -instance Equality FUTURE where equal = equalDefault; exprHash = exprHashDefault-instance Render   FUTURE where renderArgs = renderArgsDefault-instance ToTree   FUTURE-instance Eval     FUTURE where evaluate = evaluateDefault+semanticInstances ''FUTURE+ instance EvalBind FUTURE where evalBindSym = evalBindSymDefault-instance Sharable FUTURE  instance AlphaEq dom dom dom env => AlphaEq FUTURE FUTURE dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable FUTURE+  where+    hoistOver MkFuture = False+    hoistOver _        = True++instance Monotonic FUTURE+ instance SizeProp (FUTURE :|| Type)   where     sizeProp (C' MkFuture) (WrapFull a :* Nil) = infoSize a@@ -73,15 +77,15 @@          )       => Optimize (FUTURE :|| Type) dom   where-    constructFeatOpt (C' Await) ((op :$ a) :* Nil)+    constructFeatOpt _ (C' Await) ((op :$ a) :* Nil)       | Just (C' MkFuture) <- prjF op       = return a -    constructFeatOpt (C' MkFuture) ((op :$ a) :* Nil)+    constructFeatOpt _ (C' MkFuture) ((op :$ a) :* Nil)       | Just (C' Await) <- prjF op       = return a -    constructFeatOpt feature args = constructFeatUnOpt feature args+    constructFeatOpt opts feature args = constructFeatUnOpt opts feature args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -1,7 +1,11 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +36,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Integral     ( INTEGRAL (..)     ) where@@ -50,8 +52,8 @@ import Feldspar.Core.Constructs.Bits import Feldspar.Core.Constructs.Eq import Feldspar.Core.Constructs.Ord-import Feldspar.Core.Constructs.Num import Feldspar.Core.Constructs.Logic+import Feldspar.Core.Constructs.Complex  data INTEGRAL a   where@@ -69,17 +71,18 @@     semantics Mod  = Sem "mod"  mod     semantics Exp  = Sem "(^)"  (^) -instance Equality INTEGRAL where equal = equalDefault; exprHash = exprHashDefault-instance Render   INTEGRAL where renderArgs = renderArgsDefault-instance ToTree   INTEGRAL-instance Eval     INTEGRAL where evaluate = evaluateDefault+semanticInstances ''INTEGRAL+ instance EvalBind INTEGRAL where evalBindSym = evalBindSymDefault-instance Sharable INTEGRAL  instance AlphaEq dom dom dom env => AlphaEq INTEGRAL INTEGRAL dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable INTEGRAL++instance Monotonic INTEGRAL+ instance SizeProp (INTEGRAL :|| Type)   where     sizeProp (C' Quot) (WrapFull a :* WrapFull b :* Nil) = rangeQuot (infoSize a) (infoSize b)@@ -91,41 +94,43 @@ instance     ( (INTEGRAL  :||Type) :<: dom     , (BITS      :||Type) :<: dom-    , (NUM       :||Type) :<: dom     , (EQ        :||Type) :<: dom     , (ORD       :||Type) :<: dom+    , (COMPLEX :|| Type) :<: dom     , (Condition :||Type) :<: dom     , (Logic     :||Type) :<: dom+    , Monotonic dom     , OptimizeSuper dom     , Optimize (Condition :|| Type) dom     ) =>       Optimize (INTEGRAL :|| Type) dom   where-    constructFeatOpt (C' Quot) (a :* b :* Nil)+    constructFeatOpt _ (C' Quot) (a :* b :* Nil)         | Just 1 <- viewLiteral b = return a--    constructFeatOpt (C' Quot) (a :* b :* Nil)+{-+    -- TODO: Rule disabled because of cyclic imports.+    constructFeatOpt opts (C' Quot) (a :* b :* Nil)         | Just b' <- viewLiteral b         , b' > 0         , isPowerOfTwo b'         , let l    = log2 b'         , let lLit = literalDecor l         = if isNatural $ infoSize $ getInfo a-            then constructFeat (c' ShiftR) (a :* lLit :* Nil)+            then constructFeat opts (c' ShiftR) (a :* lLit :* Nil)             else do-                aIsNeg  <- constructFeat (c' LTH) (a :* literalDecor 0 :* Nil)-                a'      <- constructFeat (c' Add) (a :* literalDecor (2^l-1) :* Nil)-                negCase <- constructFeat (c' ShiftR) (a' :* lLit :* Nil)-                posCase <- constructFeat (c' ShiftR) (a :* lLit :* Nil)-                constructFeat (c' Condition)+                aIsNeg  <- constructFeat opts (c' LTH) (a :* literalDecor 0 :* Nil)+                a'      <- constructFeat opts (c' Add) (a :* literalDecor (2^l-1) :* Nil)+                negCase <- constructFeat opts (c' ShiftR) (a' :* lLit :* Nil)+                posCase <- constructFeat opts (c' ShiftR) (a :* lLit :* Nil)+                constructFeat opts (c' Condition)                     (aIsNeg :* negCase :* posCase :* Nil)       -- TODO This rule should also fire when `b` is `2^l` but not a literal.       -- TODO Make a case for `isNegative $ infoSize $ getInfo a`. Note that       --      `isNegative /= (not . isNatural)`-      -- TODO Or maybe both `isNegative` and ``isPositive` are handled by the+      -- TODO Or maybe both `isNegative` and `isPositive` are handled by the       --      size-based optimization of `Condition`?--    constructFeatOpt (C' Rem) (a :* b :* Nil)+-}+    constructFeatOpt _ (C' Rem) (a :* b :* Nil)         | rangeLess sza szb         , isNatural sza         = return a@@ -133,20 +138,21 @@         sza = infoSize $ getInfo a         szb = infoSize $ getInfo b -    constructFeatOpt (C' Div) (a :* b :* Nil)+    constructFeatOpt _ (C' Div) (a :* b :* Nil)         | Just 1 <- viewLiteral b = return a -    constructFeatOpt (C' Div) (a :* b :* Nil)-        | Just b' <- viewLiteral b+    constructFeatOpt opts (C' Div) (a :* b :* Nil)+        | IntType U _ <- infoType $ getInfo a+        , Just b' <- viewLiteral b         , b' > 0         , isPowerOfTwo b'-        = constructFeat (c' ShiftR) (a :* literalDecor (log2 b') :* Nil)+        = constructFeat opts (c' ShiftRU) (a :* literalDecor (log2 b') :* Nil) -    constructFeatOpt (C' Div) (a :* b :* Nil)+    constructFeatOpt opts (C' Div) (a :* b :* Nil)         | sameSign (infoSize (getInfo a)) (infoSize (getInfo b))-        = constructFeat (c' Quot) (a :* b :* Nil)+        = constructFeat opts (c' Quot) (a :* b :* Nil) -    constructFeatOpt (C' Mod) (a :* b :* Nil)+    constructFeatOpt _ (C' Mod) (a :* b :* Nil)         | rangeLess sza szb         , isNatural sza         = return a@@ -154,26 +160,26 @@         sza = infoSize $ getInfo a         szb = infoSize $ getInfo b -    constructFeatOpt (C' Mod) (a :* b :* Nil)+    constructFeatOpt opts (C' Mod) (a :* b :* Nil)         | sameSign (infoSize (getInfo a)) (infoSize (getInfo b))-        = constructFeat (c' Rem) (a :* b :* Nil)+        = constructFeat opts (c' Rem) (a :* b :* Nil) -    constructFeatOpt (C' Exp) (a :* b :* Nil)+    constructFeatOpt _ (C' Exp) (a :* b :* Nil)         | Just 1 <- viewLiteral a = return $ literalDecor 1         | Just 0 <- viewLiteral a = return $ literalDecor 0         | Just 1 <- viewLiteral b = return a         | Just 0 <- viewLiteral b = return $ literalDecor 1 -    constructFeatOpt (C' Exp) (a :* b :* Nil)+    constructFeatOpt opts (C' Exp) (a :* b :* Nil)         | Just (-1) <- viewLiteral a = do-            bLSB    <- constructFeat (c' BAnd) (b :* literalDecor 1 :* Nil)-            bIsEven <- constructFeat (c' Equal) (bLSB :* literalDecor 0 :* Nil)  -- TODO Use testBit? (remove EQ :<: dom and import)-            constructFeat (c' Condition)+            bLSB    <- constructFeat opts (c' BAnd) (b :* literalDecor 1 :* Nil)+            bIsEven <- constructFeat opts (c' Equal) (bLSB :* literalDecor 0 :* Nil)  -- TODO Use testBit? (remove EQ :<: dom and import)+            constructFeat opts (c' Condition)                 (bIsEven :* literalDecor 1 :* literalDecor (-1) :* Nil) -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts a args = constructFeatUnOpt opts a args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x  -- Auxiliary functions 

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +33,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- -- | Interpretation of basic syntactic constructs  module Feldspar.Core.Constructs.Literal@@ -47,18 +46,19 @@ import Feldspar.Core.Interpretation  import Data.Typeable-import Debug.Trace  instance Sharable Literal   where     sharable (Literal a) = typeRepTyCon (typeOf a) == typeRepTyCon (typeOf [()]) +instance Monotonic Literal+ instance SizeProp (Literal :|| Type)   where-    sizeProp lit@(C' (Literal a)) Nil = sizeOf a+    sizeProp (C' (Literal a)) Nil = sizeOf a  instance ((Literal :|| Type) :<: dom, OptimizeSuper dom) =>     Optimize (Literal :|| Type) dom   where-    constructFeatUnOpt l@(C' _) = constructFeatUnOptDefault l+    constructFeatUnOpt opts l@(C' _) = constructFeatUnOptDefault opts l 

@@ -1,7 +1,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +34,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- -- | Implementation of Logic constructs -- module Feldspar.Core.Constructs.Logic@@ -64,18 +64,18 @@     semantics Or  = Sem "(||)" (||)     semantics Not = Sem "not"  not -instance Equality Logic where equal = equalDefault; exprHash = exprHashDefault-instance Render   Logic where renderArgs = renderArgsDefault-instance ToTree   Logic-instance Eval     Logic where evaluate = evaluateDefault+semanticInstances ''Logic+ instance EvalBind Logic where evalBindSym = evalBindSymDefault---instance SizeProp Logic where sizeProp = sizePropDefault-instance Sharable Logic  instance AlphaEq dom dom dom env => AlphaEq Logic Logic dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable Logic++instance Monotonic Logic+ instance SizeProp (Logic :|| Type)   where     sizeProp a@(C' _) args = sizePropDefault a args@@ -83,36 +83,37 @@ instance ( (Logic :|| Type) :<: dom          , (EQ    :|| Type) :<: dom          , (ORD   :|| Type) :<: dom+         , Monotonic dom          , OptimizeSuper dom          )       => Optimize (Logic :|| Type) dom   where-    constructFeatOpt (C' And) (a :* b :* Nil)+    constructFeatOpt _ (C' And) (a :* b :* Nil)         | Just True  <- viewLiteral a = return b         | Just False <- viewLiteral a = return a         | Just True  <- viewLiteral b = return a         | Just False <- viewLiteral b = return b         | a `alphaEq` b               = return a -    constructFeatOpt (C' Or) (a :* b :* Nil)+    constructFeatOpt _ (C' Or) (a :* b :* Nil)         | Just True  <- viewLiteral a = return a         | Just False <- viewLiteral a = return b         | Just True  <- viewLiteral b = return b         | Just False <- viewLiteral b = return a         | a `alphaEq` b               = return a -    constructFeatOpt (C' Not) ((op :$ a) :* Nil)+    constructFeatOpt _ (C' Not) ((op :$ a) :* Nil)         | Just (C' Not) <- prjF op = return a -    constructFeatOpt (C' Not) ((op :$ a :$ b) :* Nil)-        | Just (C' Equal)    <- prjF op = constructFeat (c' NotEqual) (a :* b :* Nil)-        | Just (C' NotEqual) <- prjF op = constructFeat (c' Equal)    (a :* b :* Nil)-        | Just (C' LTH)      <- prjF op = constructFeat (c' GTE)      (a :* b :* Nil)-        | Just (C' GTH)      <- prjF op = constructFeat (c' LTE)      (a :* b :* Nil)-        | Just (C' LTE)      <- prjF op = constructFeat (c' GTH)      (a :* b :* Nil)-        | Just (C' GTE)      <- prjF op = constructFeat (c' LTH)      (a :* b :* Nil)+    constructFeatOpt opts (C' Not) ((op :$ a :$ b) :* Nil)+        | Just (C' Equal)    <- prjF op = constructFeat opts (c' NotEqual) (a :* b :* Nil)+        | Just (C' NotEqual) <- prjF op = constructFeat opts (c' Equal)    (a :* b :* Nil)+        | Just (C' LTH)      <- prjF op = constructFeat opts (c' GTE)      (a :* b :* Nil)+        | Just (C' GTH)      <- prjF op = constructFeat opts (c' LTE)      (a :* b :* Nil)+        | Just (C' LTE)      <- prjF op = constructFeat opts (c' GTH)      (a :* b :* Nil)+        | Just (C' GTE)      <- prjF op = constructFeat opts (c' LTH)      (a :* b :* Nil) -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts a args = constructFeatUnOpt opts a args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,12 +35,10 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Loop where -import Data.Typeable+import Data.Map (notMember)  import Control.Monad (forM_, when) @@ -51,7 +51,10 @@ import Feldspar.Core.Interpretation import Feldspar.Core.Constructs.Binding import Feldspar.Core.Constructs.Literal+import Feldspar.Core.Constructs.Mutable+import Feldspar.Core.Constructs.MutableReference + data LoopM m a   where     While :: (Size (m ()) ~ AnySize) => LoopM m (m Bool :-> m a :-> Full (m ()))@@ -87,20 +90,18 @@             go st | cond st   = go $ body st                   | otherwise = st -instance Monad m => Equality (LoopM m) where equal = equalDefault; exprHash = exprHashDefault-instance Monad m => Render   (LoopM m) where renderArgs = renderArgsDefault-instance Monad m => ToTree   (LoopM m)-instance Monad m => Eval     (LoopM m) where evaluate = evaluateDefault-instance Monad m => EvalBind (LoopM m) where evalBindSym = evalBindSymDefault-instance Sharable (LoopM m)-  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'+instance Monad m => Equality   (LoopM m) where equal = equalDefault; exprHash = exprHashDefault+instance Monad m => Render     (LoopM m) where renderSym  = renderSymDefault+                                               renderArgs = renderArgsDefault+instance Monad m => StringTree (LoopM m)+instance Monad m => Eval       (LoopM m) where evaluate = evaluateDefault+instance Monad m => EvalBind   (LoopM m) where evalBindSym = evalBindSymDefault+instance            Sharable   (LoopM m)+instance            Monotonic  (LoopM m) -instance Equality Loop where equal = equalDefault; exprHash = exprHashDefault-instance Render   Loop where renderArgs = renderArgsDefault-instance ToTree   Loop-instance Eval     Loop where evaluate = evaluateDefault+semanticInstances ''Loop+ instance EvalBind Loop where evalBindSym = evalBindSymDefault-instance Sharable Loop  instance (AlphaEq dom dom dom env, Monad m) =>     AlphaEq (LoopM m) (LoopM m) dom env@@ -111,6 +112,10 @@   where     alphaEqSym = alphaEqSymDefault +instance Sharable Loop++instance Monotonic Loop+ instance SizeProp (LoopM m)   where     sizeProp While _ = AnySize@@ -118,45 +123,69 @@  instance SizeProp (Loop :|| Type)   where-    sizeProp (C' ForLoop)   (_ :* _ :* WrapFull step :* Nil) = infoSize step-    sizeProp (C' WhileLoop) (_ :* _ :* WrapFull step :* Nil) = infoSize step+    sizeProp (C' ForLoop)   (_ :* _ :* WrapFull step :* Nil) = snd $ snd $ infoSize step+    sizeProp (C' WhileLoop) (_ :* _ :* WrapFull step :* Nil) = snd $ infoSize step  -instance ( MonadType m-         , LoopM m :<: dom+instance ( LoopM Mut :<: dom+         , (Variable :|| Type) :<: dom          , CLambda Type :<: dom+         , MONAD Mut :<: dom+         , MutableReference :<: dom+         , Let :<: dom+         , Optimize (CLambda Type) dom+         , Optimize (MONAD Mut) dom          , Optimize dom dom          )-      => Optimize (LoopM m) dom+      => Optimize (LoopM Mut) dom   where-    optimizeFeat for@For (len :* step :* Nil) = do-        len' <- optimizeM len+    optimizeFeat opts for@For (len :* step :* Nil) = do+        len' <- optimizeM opts len         let szI     = infoSize (getInfo len')-            ixRange = rangeByRange 0 (szI-1)-        step' <- optimizeFunction optimizeM (mkInfo ixRange) step+            ixRange = rangeByRange 0 (rangeSubSat szI 1)+        step' <- optimizeFunction opts (optimizeM opts) (mkInfo ixRange) step         case getInfo step' of-          Info{} -> constructFeat for (len' :* step' :* Nil)+          Info{} -> constructFeat opts for (len' :* step' :* Nil) -    optimizeFeat a args = optimizeFeatDefault a args+    optimizeFeat opts a args = optimizeFeatDefault opts a args -    constructFeatUnOpt While args = constructFeatUnOptDefaultTyp voidTypeRep While args-    constructFeatUnOpt For   args = constructFeatUnOptDefaultTyp voidTypeRep For   args+    constructFeatOpt opts For (len :* (lam1 :$ (bnd :$ getRefV2@(grf :$ ref) :$ bd@(lam3 :$ body))) :* Nil)+      | Just (SubConstr2 (Lambda v1)) <- prjLambda lam1+      , Just lam3'@(SubConstr2 (Lambda v3)) <- prjLambda lam3+      , Just Bind <- prjMonad monadProxy bnd+      , Just GetRef <- prj grf+      , Just (C' (Variable v2)) <- prjF ref+      , v1 /= v2+      , v2 `notMember` fvars+      = do+          loop      <- constructFeat opts For (len :* (lam1 :$ body) :* Nil)+          hoistedV3 <- constructFeat opts (reuseCLambda lam3') (loop :* Nil)+          -- Do not optimize right now; the v3 binding gets lost.+          constructFeatUnOpt opts Bind (getRefV2 :* hoistedV3 :* Nil)+     where+      fvars = infoVars $ getInfo bd +    constructFeatOpt opts feat args = constructFeatUnOpt opts feat args++    constructFeatUnOpt opts While args = constructFeatUnOptDefaultTyp opts voidTypeRep While args+    constructFeatUnOpt opts For   args = constructFeatUnOptDefaultTyp opts voidTypeRep For   args+ instance ( (Literal  :|| Type) :<: dom          , (Loop     :|| Type) :<: dom          , (Variable :|| Type) :<: dom          , CLambda Type :<: dom+         , Let :<: dom          , OptimizeSuper dom          )       => Optimize (Loop :|| Type) dom   where-    optimizeFeat sym@(C' ForLoop) (len :* initial :* step :* Nil) = do-        len'  <- optimizeM len-        init' <- optimizeM initial+    optimizeFeat opts sym@(C' ForLoop) (len :* initial :* step :* Nil) = do+        len'  <- optimizeM opts len+        init' <- optimizeM opts initial         let szI     = infoSize (getInfo len')             ixRange = Range 0 (upperBound szI-1)-        step' <- optimizeFunction-            (optimizeFunction optimizeM (mkInfoTy typeRep))+        step' <- optimizeFunction opts+            (optimizeFunction opts (optimizeM opts) (mkInfoTy typeRep))             -- (optimizeFunctionFix optimizeM (getInfo init'))             -- TODO The above optimization is unsound, as shown by the following             --      program:@@ -164,18 +193,18 @@             --        drawAST $ fold max (value minBound) -:: tVec1 tWordN >-> id             (mkInfo ixRange)             step-        constructFeat sym (len' :* init' :* step' :* Nil)+        constructFeat opts sym (len' :* init' :* step' :* Nil) -    optimizeFeat sym@(C' WhileLoop) (initial :* cond :* body :* Nil) = do-        init' <- optimizeM initial-        body' <- optimizeFunction optimizeM (mkInfoTy typeRep) body+    optimizeFeat opts sym@(C' WhileLoop) (initial :* cond :* body :* Nil) = do+        init' <- optimizeM opts initial+        body' <- optimizeFunction opts (optimizeM opts) (mkInfoTy typeRep) body         -- body' <- optimizeFunctionFix optimizeM info body         -- TODO See comment above          let info  = getInfo init'-        let info' = info { infoSize = infoSize (getInfo body') }-        cond' <- optimizeFunction optimizeM info' cond-        constructFeat sym (init' :* cond' :* body' :* Nil)+        let info' = info { infoSize = snd $ infoSize (getInfo body') }+        cond' <- optimizeFunction opts (optimizeM opts) info' cond+        constructFeat opts sym (init' :* cond' :* body' :* Nil)  {-     constructFeatOpt (C' ForLoop) (len :* initial :* step :* Nil)@@ -197,7 +226,7 @@       -- TODO ForLoop len init (flip (const f)) ==> step (len - 1) init       -- This optimization requires that the len > 0 -    constructFeatOpt feat args = constructFeatUnOpt feat args+    constructFeatOpt opts feat args = constructFeatUnOpt opts feat args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -2,8 +2,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -34,8 +36,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Mutable     ( module Feldspar.Core.Constructs.Mutable     , module Language.Syntactic.Constructs.Monad@@ -63,30 +63,33 @@   where     semantics Run = Sem "runMutable" unsafePerformIO -instance Equality Mutable where equal = equalDefault; exprHash = exprHashDefault-instance Render   Mutable where renderArgs = renderArgsDefault-instance ToTree   Mutable-instance Eval     Mutable where evaluate = evaluateDefault-instance EvalBind Mutable where evalBindSym = evalBindSymDefault-instance Sharable Mutable- instance Typed Mutable   where     typeDictSym Run = Just Dict +semanticInstances ''Mutable++instance EvalBind Mutable where evalBindSym = evalBindSymDefault+ instance AlphaEq dom dom dom env => AlphaEq Mutable Mutable dom env   where     alphaEqSym = alphaEqSymDefault  instance Sharable (MONAD Mut) +instance Monotonic (MONAD Mut)+ instance SizeProp (MONAD Mut)   where     sizeProp Return (WrapFull a :* Nil)      = infoSize a-    sizeProp Bind   (_ :* WrapFull f :* Nil) = infoSize f+    sizeProp Bind   (_ :* WrapFull f :* Nil) = snd $ infoSize f     sizeProp Then   (_ :* WrapFull b :* Nil) = infoSize b     sizeProp When   _                        = AnySize +instance Sharable Mutable++instance Monotonic Mutable+ instance SizeProp Mutable   where     sizeProp Run (WrapFull a :* Nil) = infoSize a@@ -97,20 +100,21 @@ instance ( MONAD Mut :<: dom          , (Variable :|| Type) :<: dom          , CLambda Type :<: dom+         , Let :<: dom          , OptimizeSuper dom)       => Optimize (MONAD Mut) dom   where-    optimizeFeat bnd@Bind (ma :* f :* Nil) = do-        ma' <- optimizeM ma+    optimizeFeat opts bnd@Bind (ma :* f :* Nil) = do+        ma' <- optimizeM opts ma         case getInfo ma' of           Info (MutType ty) sz vs src -> do-            f' <- optimizeFunction optimizeM (Info ty sz vs src) f+            f' <- optimizeFunction opts (optimizeM opts) (Info ty sz vs src) f             case getInfo f' of-              Info{} -> constructFeat bnd (ma' :* f' :* Nil)+              Info{} -> constructFeat opts bnd (ma' :* f' :* Nil) -    optimizeFeat a args = optimizeFeatDefault a args+    optimizeFeat opts a args = optimizeFeatDefault opts a args -    constructFeatOpt Bind (ma :* (lam :$ (Sym (Decor _ ret) :$ var)) :* Nil)+    constructFeatOpt _ Bind (ma :* (lam :$ (ret :$ var)) :* Nil)       | Just (SubConstr2 (Lambda v1)) <- prjLambda lam       , Just Return                   <- prjMonad monadProxy ret       , Just (C' (Variable v2))       <- prjF var@@ -118,50 +122,65 @@       , Just ma' <- gcast ma       = return ma' -    constructFeatOpt Bind (ma :* (lam :$ body) :* Nil)+    constructFeatOpt opts Bind (ma :* (lam :$ body) :* Nil)         | Just (SubConstr2 (Lambda v)) <- prjLambda lam         , v `notMember` vars-        = constructFeat Then (ma :* body :* Nil)+        = constructFeat opts Then (ma :* body :* Nil)       where         vars = infoVars $ getInfo body +       -- (bind e1 (\x -> e2) >> e3 ==> bind e1 (\x -> e2 >> e3)+    constructFeatOpt opts Then ((bnd :$ x :$ (lam :$ bd)) :* y :* Nil)+        | Just Bind <- prjMonad monadProxy bnd+        , Just lam'@(SubConstr2 (Lambda _)) <- prjLambda lam+        = do+             bb <- constructFeat opts Then (bd :* y :* Nil)+             bd' <- constructFeat opts (reuseCLambda lam') (bb :* Nil)+             constructFeatUnOpt opts Bind (x :* bd' :* Nil)++      -- (bind (bind e1 (\x -> e2)) (\y -> e3) => bind e1 (\x -> bind e2 (\y-> e3))+    constructFeatOpt opts Bind ((bnd :$ x :$ (lam :$ bd)) :* y :* Nil)+        | Just Bind <- prjMonad monadProxy bnd+        , Just lam'@(SubConstr2 (Lambda _)) <- prjLambda lam+        = do+             bb <- constructFeat opts Bind (bd :* y :* Nil)+             bd' <- constructFeat opts (reuseCLambda lam') (bb :* Nil)+             constructFeatUnOpt opts Bind (x :* bd' :* Nil)+       -- return x >> mb ==> mb-    constructFeatOpt Then ((Sym (Decor _ ret) :$ _) :* mb :* Nil)+    constructFeatOpt _ Then ((ret :$ _) :* mb :* Nil)         | Just Return <- prjMonad monadProxy ret         = return mb        -- ma >> return () ==> ma-    constructFeatOpt Then (ma :* (Sym (Decor info ret) :$ u) :* Nil)+    constructFeatOpt _ Then (ma :* (ret :$ u) :* Nil)         | Just Return <- prjMonad monadProxy ret-        , Just TypeEq <- typeEq (infoType $ getInfo ma) (MutType UnitType)-        , Just TypeEq <- typeEq (infoType info)         (MutType UnitType)+        , Just TypeEq <- typeEq (infoType $ getInfo ma)  (MutType UnitType)+        , Just TypeEq <- typeEq (infoType $ getInfo ret) (MutType UnitType)         , Just ()     <- viewLiteral u         = return ma -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts a args = constructFeatUnOpt opts a args -    constructFeatUnOpt Return args@(a :* Nil)+    constructFeatUnOpt opts Return args@(a :* Nil)         | Info {infoType = t} <- getInfo a-        = constructFeatUnOptDefaultTyp (MutType t) Return args+        = constructFeatUnOptDefaultTyp opts (MutType t) Return args -    constructFeatUnOpt Bind args@(_ :* f :* Nil)-        | Info {infoType = FunType _ t} <- getInfo f-        = constructFeatUnOptDefaultTyp t Bind args-      -- TODO The match on `FunType` is total with the current definition of-      --      `TypeRep`, but there's no guarantee this will remain true in the-      --      future. One way around that would be to match `f` against-      --      `Lambda`, but that is also a partial match (at least possibly, in-      --      the future). Another option would be to add a context parameter to-      --      `MONAD` to be able to add the constraint `Type a`.+    constructFeatUnOpt opts Bind args@(_ :* (lam :$ body) :* Nil)+        | Just (SubConstr2 (Lambda _))  <- prjLambda lam+        , Info {infoType = t} <- getInfo body+        = constructFeatUnOptDefaultTyp opts t Bind args -    constructFeatUnOpt Then args@(_ :* mb :* Nil)+    constructFeatUnOpt opts Then args@(_ :* mb :* Nil)         | Info {infoType = t} <- getInfo mb-        = constructFeatUnOptDefaultTyp t Then args+        = constructFeatUnOptDefaultTyp opts t Then args -    constructFeatUnOpt When args =-        constructFeatUnOptDefaultTyp voidTypeRep When args+    constructFeatUnOpt opts When args =+        constructFeatUnOptDefaultTyp opts voidTypeRep When args -instance (Mutable :<: dom, OptimizeSuper dom) => Optimize Mutable dom+instance (Mutable :<: dom, MONAD Mut :<: dom, OptimizeSuper dom) => Optimize Mutable dom   where-    constructFeatUnOpt Run args = constructFeatUnOptDefault Run args+    constructFeatUnOpt _ Run ((ret :$ a) :* Nil)+        | Just Return <- prjMonad monadProxy ret = return a+    constructFeatUnOpt opts Run args = constructFeatUnOptDefault opts Run args 

@@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,9 +35,8 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.MutableArray+  (MutableArray(..)) where  import Control.Monad@@ -59,24 +60,31 @@  instance Semantic MutableArray   where-    semantics NewArr    = Sem "newMArr"   (\l -> newArray  (0,l-1))-    semantics NewArr_   = Sem "newMArr_"  (\l -> newArray_ (0,l-1))+    semantics NewArr    = Sem "newMArr"  $ \l -> newArray (mkBounds l)+    semantics NewArr_   = Sem "newMArr_" $ \l -> newListArray (mkBounds l)+        [error $ "Undefined element at index " ++ show (i::Index) | i <- [0..]]     semantics GetArr    = Sem "getMArr"   readArray     semantics SetArr    = Sem "setMArr"   writeArray     semantics ArrLength = Sem "arrLength" (getBounds >=> \(l,u) -> return (u-l+1)) -instance Equality MutableArray where equal = equalDefault; exprHash = exprHashDefault-instance Render   MutableArray where renderArgs = renderArgsDefault-instance ToTree   MutableArray-instance Eval     MutableArray where evaluate = evaluateDefault+-- | Calculate array bounds. If the length is zero, flip the arguments to+-- make an empty range+mkBounds :: Length -> (Length,Length)+mkBounds 0 = (pred 0, 0)+mkBounds l = (0, pred l)++semanticInstances ''MutableArray+ instance EvalBind MutableArray where evalBindSym = evalBindSymDefault-instance Sharable MutableArray-  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'  instance AlphaEq dom dom dom env => AlphaEq MutableArray MutableArray dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable MutableArray++instance Monotonic MutableArray+ instance SizeProp MutableArray   where     sizeProp NewArr  (WrapFull len :* _ :* Nil) = infoSize len :> universal@@ -89,9 +97,9 @@  instance (MutableArray :<: dom, Optimize dom dom) => Optimize MutableArray dom   where-    constructFeatUnOpt NewArr    args = constructFeatUnOptDefaultTyp (MutType $ MArrType typeRep) NewArr args-    constructFeatUnOpt NewArr_   args = constructFeatUnOptDefaultTyp (MutType $ MArrType typeRep) NewArr_ args-    constructFeatUnOpt GetArr    args = constructFeatUnOptDefaultTyp (MutType typeRep) GetArr args-    constructFeatUnOpt SetArr    args = constructFeatUnOptDefaultTyp (MutType typeRep) SetArr args-    constructFeatUnOpt ArrLength args = constructFeatUnOptDefaultTyp (MutType typeRep) ArrLength args+    constructFeatUnOpt opts NewArr    args = constructFeatUnOptDefaultTyp opts (MutType $ MArrType typeRep) NewArr args+    constructFeatUnOpt opts NewArr_   args = constructFeatUnOptDefaultTyp opts (MutType $ MArrType typeRep) NewArr_ args+    constructFeatUnOpt opts GetArr    args = constructFeatUnOptDefaultTyp opts (MutType typeRep) GetArr args+    constructFeatUnOpt opts SetArr    args = constructFeatUnOptDefaultTyp opts (MutType typeRep) SetArr args+    constructFeatUnOpt opts ArrLength args = constructFeatUnOptDefaultTyp opts (MutType typeRep) ArrLength args 

@@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,8 +35,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.MutableReference where @@ -42,46 +42,66 @@  import Language.Syntactic import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Binding.HigherOrder  import Feldspar.Lattice import Feldspar.Core.Types import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Binding+import Feldspar.Core.Constructs.Mutable + data MutableReference a   where     NewRef :: Type a => MutableReference (a :-> Full (Mut (IORef a)))     GetRef :: Type a => MutableReference (IORef a :-> Full (Mut a))     SetRef :: Type a => MutableReference (IORef a :-> a :-> Full (Mut ()))+    ModRef :: Type a => MutableReference (IORef a :-> (a -> a) :-> Full (Mut ()))  instance Semantic MutableReference   where     semantics NewRef = Sem "newRef" newIORef     semantics GetRef = Sem "getRef" readIORef     semantics SetRef = Sem "setRef" writeIORef+    semantics ModRef = Sem "modRef" (\r f -> readIORef r >>= writeIORef r . f) -instance Equality MutableReference where equal = equalDefault; exprHash = exprHashDefault-instance Render   MutableReference where renderArgs = renderArgsDefault-instance ToTree   MutableReference-instance Eval     MutableReference where evaluate = evaluateDefault+semanticInstances ''MutableReference+ instance EvalBind MutableReference where evalBindSym = evalBindSymDefault-instance Sharable MutableReference-  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'  instance AlphaEq dom dom dom env =>     AlphaEq MutableReference MutableReference dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable MutableReference++instance Monotonic MutableReference+ instance SizeProp MutableReference   where     sizeProp NewRef _ = universal     sizeProp GetRef _ = universal     sizeProp SetRef _ = universal+    sizeProp ModRef _ = universal -instance (MutableReference :<: dom, Optimize dom dom) =>-    Optimize MutableReference dom+instance ( MutableReference :<: dom+         , MONAD Mut :<: dom+         , Project (CLambda Type) dom+         , Project (Variable :|| Type) dom+         , OptimizeSuper dom+         )+      => Optimize MutableReference dom   where-    constructFeatUnOpt NewRef args = constructFeatUnOptDefaultTyp (MutType $ RefType typeRep) NewRef args-    constructFeatUnOpt GetRef args = constructFeatUnOptDefaultTyp (MutType typeRep) GetRef args-    constructFeatUnOpt SetRef args = constructFeatUnOptDefaultTyp (MutType typeRep) SetRef args+    -- modifyRef _ id ==> return ()+    constructFeatUnOpt opts ModRef (_ :* (lam :$ body) :* Nil)+       | Just (SubConstr2 (Lambda v1)) <- prjLambda lam+       , Just (C' (Variable v2)) <- prjF body+       , v1 == v2+       = constructFeatUnOptDefaultTyp opts (MutType UnitType) Return (literalDecor () :* Nil)++    constructFeatUnOpt opts NewRef args = constructFeatUnOptDefaultTyp opts (MutType $ RefType typeRep) NewRef args+    constructFeatUnOpt opts GetRef args = constructFeatUnOptDefaultTyp opts (MutType typeRep) GetRef args+    constructFeatUnOpt opts SetRef args = constructFeatUnOptDefaultTyp opts (MutType typeRep) SetRef args+    constructFeatUnOpt opts ModRef args = constructFeatUnOptDefaultTyp opts (MutType typeRep) ModRef args 

@@ -2,9 +2,11 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -35,21 +37,14 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-}- module Feldspar.Core.Constructs.MutableToPure     ( MutableToPure (..)     ) where  import qualified Control.Exception as C import Data.Array.IArray-#if __GLASGOW_HASKELL__>=704 import Data.Array.MArray (freeze) import Data.Array.Unsafe (unsafeFreeze)-#else-import Data.Array.MArray (freeze, unsafeFreeze)-#endif import System.IO.Unsafe  import Language.Syntactic@@ -79,30 +74,30 @@     = do a <- f (elems (unsafePerformIO $ freeze ma :: Array WordN a))          C.evaluate a -instance Equality MutableToPure where equal = equalDefault; exprHash = exprHashDefault-instance Render   MutableToPure where renderArgs = renderArgsDefault-instance ToTree   MutableToPure-instance Eval     MutableToPure where evaluate = evaluateDefault-instance EvalBind MutableToPure where evalBindSym = evalBindSymDefault-instance Sharable MutableToPure- instance Typed MutableToPure   where     typeDictSym RunMutableArray = Just Dict     typeDictSym _ = Nothing +semanticInstances ''MutableToPure +instance EvalBind MutableToPure where evalBindSym = evalBindSymDefault+ instance AlphaEq dom dom dom env => AlphaEq MutableToPure MutableToPure dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable MutableToPure++instance Monotonic MutableToPure+ instance SizeProp MutableToPure   where-    sizeProp RunMutableArray _ = universal-    sizeProp WithArray       _ = universal+    sizeProp RunMutableArray (WrapFull arr :* Nil) = infoSize arr+    sizeProp WithArray _ = universal  instance (MutableToPure :<: dom, Optimize dom dom) => Optimize MutableToPure dom   where-    constructFeatUnOpt RunMutableArray args = constructFeatUnOptDefaultTyp typeRep RunMutableArray args-    constructFeatUnOpt WithArray args       = constructFeatUnOptDefaultTyp (MutType typeRep) WithArray args+    constructFeatUnOpt opts RunMutableArray args = constructFeatUnOptDefaultTyp opts typeRep RunMutableArray args+    constructFeatUnOpt opts WithArray args       = constructFeatUnOptDefaultTyp opts (MutType typeRep) WithArray args 

@@ -1,7 +1,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +34,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.NoInline where  import Language.Syntactic@@ -50,24 +50,25 @@   where     semantics NoInline  = Sem "NoInline" id -instance Equality NoInline where equal = equalDefault; exprHash = exprHashDefault-instance Render   NoInline where renderArgs = renderArgsDefault-instance ToTree   NoInline-instance Eval     NoInline where evaluate = evaluateDefault+semanticInstances ''NoInline+ instance EvalBind NoInline where evalBindSym = evalBindSymDefault++instance AlphaEq dom dom dom env => AlphaEq NoInline NoInline dom env+  where+    alphaEqSym = alphaEqSymDefault+ instance Sharable NoInline +instance Monotonic NoInline+ instance SizeProp (NoInline :|| Type)   where     sizeProp (C' s) = sizePropDefault s -instance AlphaEq dom dom dom env => AlphaEq NoInline NoInline dom env-  where-    alphaEqSym = alphaEqSymDefault- instance ( (NoInline :|| Type) :<: dom          , OptimizeSuper dom)       => Optimize (NoInline :|| Type) dom   where-    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,8 +35,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Num     ( NUM (..)     ) where@@ -44,10 +44,14 @@ import Language.Syntactic import Language.Syntactic.Constructs.Binding +import Data.Complex (Complex(..))+ import Feldspar.Range import Feldspar.Core.Types import Feldspar.Core.Interpretation import Feldspar.Core.Constructs.Literal+import Feldspar.Core.Constructs.Integral+import Feldspar.Core.Constructs.Complex   data NUM a@@ -66,17 +70,18 @@     semantics Sub  = Sem "(-)" (-)     semantics Mul  = Sem "(*)" (*) -instance Equality NUM where equal = equalDefault; exprHash = exprHashDefault-instance Render   NUM where renderArgs = renderArgsDefault-instance ToTree   NUM-instance Eval     NUM where evaluate = evaluateDefault+semanticInstances ''NUM+ instance EvalBind NUM where evalBindSym = evalBindSymDefault-instance Sharable NUM  instance AlphaEq dom dom dom env => AlphaEq NUM NUM dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable NUM++instance Monotonic NUM+ instance SizeProp (NUM :|| Type)   where     sizeProp (C' Abs)  (WrapFull a :* Nil)               = abs (infoSize a)@@ -88,115 +93,170 @@  instance ( (NUM     :|| Type) :<: dom          , (Literal :|| Type) :<: dom+         , (INTEGRAL :|| Type) :<: dom+         , (COMPLEX :|| Type) :<: dom          , OptimizeSuper dom          )       => Optimize (NUM :|| Type) dom   where-    constructFeatOpt (C' Abs) (a :* Nil)+    constructFeatOpt _ (C' Abs) (a :* Nil)         | RangeSet r <- infoRange (getInfo a)         , isNatural r         = return a -    constructFeatOpt (C' Sign) (a :* Nil)+    constructFeatOpt _ (C' Sign) (a :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , 0 `rangeLess` ra         = return (literalDecor 1) -    constructFeatOpt (C' Sign) (a :* Nil)+    constructFeatOpt _ (C' Sign) (a :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , ra `rangeLess` 0         = return (literalDecor (-1)) -    constructFeatOpt (C' Add) (a :* b :* Nil)+    constructFeatOpt opts (C' Add) (a :* b :* Nil)         | Just 0 <- viewLiteral b = return a         | Just 0 <- viewLiteral a = return b-        | alphaEq a b = constructFeatOpt (c' Mul) (a :* literalDecor 2 :* Nil)+        | alphaEq a b = constructFeatOpt opts (c' Mul) (a :* literalDecor 2 :* Nil) -    constructFeatOpt s@(C' Add) (a :* (op :$ b :$ c) :* Nil)-        | Just a'      <- viewLiteral a+    constructFeatOpt opts s@(C' Add) (a :* (op :$ b :$ c) :* Nil)+        | Just al       <- viewLiteral a         , Just (C' Add) <- prjF op-        , Just c'      <- viewLiteral c-        = constructFeat s (b :* literalDecor (a'+c') :* Nil)+        , Just cl       <- viewLiteral c+        = constructFeat opts s (b :* literalDecor (al+cl) :* Nil) -    constructFeatOpt s@(C' Add) (a :* (op :$ b :$ c) :* Nil)-        | Just a'      <- viewLiteral a+    constructFeatOpt opts s@(C' Add) (a :* (op :$ b :$ c) :* Nil)+        | Just al       <- viewLiteral a         , Just (C' Sub) <- prjF op-        , Just c'      <- viewLiteral c-        = constructFeat s (b :* literalDecor (a'-c') :* Nil)+        , Just cl       <- viewLiteral c+        = constructFeat opts s (b :* literalDecor (al-cl) :* Nil) -    constructFeatOpt s@(C' Add) ((op :$ a :$ b) :* c :* Nil)-        | Just c'      <- viewLiteral c+    constructFeatOpt opts s@(C' Add) ((op :$ a :$ b) :* c :* Nil)+        | Just cl       <- viewLiteral c         , Just (C' Add) <- prjF op-        , Just b'      <- viewLiteral b-        = constructFeat s (a :* literalDecor (b'+c') :* Nil)+        , Just bl       <- viewLiteral b+        = constructFeat opts s (a :* literalDecor (bl+cl) :* Nil) -    constructFeatOpt s@(C' Add) ((op :$ a :$ b) :* c :* Nil)-        | Just c'      <- viewLiteral c+    constructFeatOpt opts s@(C' Add) ((op :$ a :$ b) :* c :* Nil)+        | Just cl       <- viewLiteral c         , Just (C' Sub) <- prjF op-        , Just b'      <- viewLiteral b-        = constructFeat s (a :* literalDecor (c'-b') :* Nil)+        , Just bl       <- viewLiteral b+        = constructFeat opts s (a :* literalDecor (cl-bl) :* Nil) -    constructFeatOpt (C' Add) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)+    constructFeatOpt opts (C' Add) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)         | Just (C' Add) <- prjF op1         , Just (C' Add) <- prjF op2-        , Just b'      <- viewLiteral b-        , Just d'      <- viewLiteral d+        , Just bl       <- viewLiteral b+        , Just dl       <- viewLiteral d         = do-            ac <- constructFeat (c' Add) (a :* c :* Nil)-            constructFeat (c' Add) (ac :* literalDecor (b'+d') :* Nil)+            ac <- constructFeat opts (c' Add) (a :* c :* Nil)+            constructFeat opts (c' Add) (ac :* literalDecor (bl+dl) :* Nil) -    constructFeatOpt (C' Add) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)+    constructFeatOpt opts (C' Add) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)         | Just (C' Add) <- prjF op1         , Just (C' Sub) <- prjF op2         , alphaEq a c         , alphaEq b d-        = constructFeat (c' Add) (a :* c :* Nil)+        = constructFeat opts (c' Add) (a :* c :* Nil) -    constructFeatOpt (C' Sub) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)+    -- x `mod` y + y * (x `div` y) ==> x+    -- Partial index calculations materialized from contractT . expandT 2+    -- in MultiDim.hs, which is a no-op.+    constructFeatOpt opts (C' Add) ((rem :$ a :$ b) :* (mul :$ c :$ (quot :$ d :$ e)) :* Nil)+        | Just (C' Rem)  <- prjF rem+        , Just (C' Mul)  <- prjF mul+        , Just (C' Quot) <- prjF quot+        , alphaEq a d+        , alphaEq c e+        , alphaEq b e+        = return a++    -- literal a - (b + literal c) ==> literal (a-c) - b+    -- constructFeatOpt opts s@(C' Sub) (a :* (op :$ b :$ c) :* Nil)+    --     | Just a'      <- viewLiteral a+    --     , Just (C' Add) <- prjF op+    --     , Just c'      <- viewLiteral c+    --     = constructFeat opts s (literalDecor (a'-c') :* b :* Nil)++    -- literal a - (b - literal c) ==> literal (a+c) - b+    -- constructFeatOpt opts s@(C' Sub) (a :* (op :$ b :$ c) :* Nil)+    --     | Just a'      <- viewLiteral a+    --     , Just (C' Sub) <- prjF op+    --     , Just c'      <- viewLiteral c+    --     = constructFeat opts s (literalDecor (a'+c') :* b :* Nil)++    -- (a + literal b) - literal c ==> a + literal (b - c)+    constructFeatOpt opts (C' Sub) ((op :$ a :$ b) :* c :* Nil)+        | Just cl         <- viewLiteral c+        , Just s@(C' Add) <- prjF op+        , Just bl         <- viewLiteral b+        = constructFeat opts s (a :* literalDecor (bl-cl) :* Nil)++    -- (a - literal b) - literal c ==> a - literal (b + c)+    constructFeatOpt opts s@(C' Sub) ((op :$ a :$ b) :* c :* Nil)+        | Just cl       <- viewLiteral c+        , Just (C' Sub) <- prjF op+        , Just bl       <- viewLiteral b+        = constructFeat opts s (a :* literalDecor (bl+cl) :* Nil)++    constructFeatOpt opts (C' Sub) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)         | Just (C' Add) <- prjF op1         , Just (C' Sub) <- prjF op2         , alphaEq a c         , alphaEq b d-        = constructFeat (c' Add) (b :* d :* Nil)+        = constructFeat opts (c' Add) (b :* d :* Nil) -    constructFeatOpt (C' Sub) (a :* b :* Nil)+    constructFeatOpt _ (C' Sub) (a :* b :* Nil)         | Just 0 <- viewLiteral b = return a         | alphaEq a b             = return $ literalDecor 0 -    constructFeatOpt (C' Mul) (a :* b :* Nil)+    -- (x + yi) * i ==> -y + xi; (x + yi) * (-i) ==> y - xi+    constructFeatOpt opts (C' Mul) (a :* iunit :* Nil)+        | ComplexType FloatType <- infoType (getInfo iunit)+        , Just (0 :+ k)         <- viewLiteral iunit+        , abs k == 1+        = do+             ra <- constructFeat opts (c' RealPart) (a :* Nil)+             ia <- constructFeat opts (c' ImagPart) (a :* Nil)+             iainv <- constructFeatOpt opts (c' Mul) (literalDecor (-k) :* ia :* Nil)+             rainv <- constructFeatOpt opts (c' Mul) (literalDecor k :* ra :* Nil)+             constructFeatOpt opts (c' MkComplex) (iainv :* rainv :* Nil)+++    constructFeatOpt _ (C' Mul) (a :* b :* Nil)         | Just 0 <- viewLiteral a = return a         | Just 1 <- viewLiteral a = return b         | Just 0 <- viewLiteral b = return b         | Just 1 <- viewLiteral b = return a -    constructFeatOpt s@(C' Mul) (a :* (op :$ b :$ c) :* Nil)-        | Just a'      <- viewLiteral a+    constructFeatOpt opts s@(C' Mul) (a :* (op :$ b :$ c) :* Nil)+        | Just al       <- viewLiteral a         , Just (C' Mul) <- prjF op-        , Just c'      <- viewLiteral c-        = constructFeat s (b :* literalDecor (a'*c') :* Nil)+        , Just cl       <- viewLiteral c+        = constructFeat opts s (b :* literalDecor (al*cl) :* Nil) -    constructFeatOpt s@(C' Mul) ((op :$ a :$ b) :* c :* Nil)-        | Just c'      <- viewLiteral c+    constructFeatOpt opts s@(C' Mul) ((op :$ a :$ b) :* c :* Nil)+        | Just cl       <- viewLiteral c         , Just (C' Mul) <- prjF op-        , Just b'      <- viewLiteral b-        = constructFeat s (a :* literalDecor (b'*c') :* Nil)+        , Just bl       <- viewLiteral b+        = constructFeat opts s (a :* literalDecor (bl*cl) :* Nil) -    constructFeatOpt (C' Mul) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)+    constructFeatOpt opts (C' Mul) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)         | Just (C' Mul) <- prjF op1         , Just (C' Mul) <- prjF op2         , Just b'      <- viewLiteral b         , Just d'      <- viewLiteral d         = do-            ac <- constructFeat (c' Mul) (a :* c :* Nil)-            constructFeat (c' Mul) (ac :* literalDecor (b'*d') :* Nil)+            ac <- constructFeat opts (c' Mul) (a :* c :* Nil)+            constructFeat opts (c' Mul) (ac :* literalDecor (b'*d') :* Nil)      -- Cases to make sure literals end up to the right:-    constructFeatOpt (C' Add) (a :* b :* Nil)-        | Just _ <- viewLiteral a = constructFeatUnOpt (c' Add) (b :* a :* Nil)+    constructFeatOpt opts (C' Add) (a :* b :* Nil)+        | Just _ <- viewLiteral a = constructFeatUnOpt opts (c' Add) (b :* a :* Nil) -    constructFeatOpt (C' Mul) (a :* b :* Nil)-        | Just _ <- viewLiteral a = constructFeatUnOpt (c' Mul) (b :* a :* Nil)+    constructFeatOpt opts (C' Mul) (a :* b :* Nil)+        | Just _ <- viewLiteral a = constructFeatUnOpt opts (c' Mul) (b :* a :* Nil) -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts a args = constructFeatUnOpt opts a args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x

@@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,8 +35,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- -- | Implementation of ordering constructs  module Feldspar.Core.Constructs.Ord@@ -70,17 +70,18 @@     semantics Min = Sem "min"  min     semantics Max = Sem "max"  max -instance Equality ORD where equal = equalDefault; exprHash = exprHashDefault-instance Render   ORD where renderArgs = renderArgsDefault-instance ToTree   ORD-instance Eval     ORD where evaluate = evaluateDefault+semanticInstances ''ORD+ instance EvalBind ORD where evalBindSym = evalBindSymDefault-instance Sharable ORD  instance AlphaEq dom dom dom env => AlphaEq ORD ORD dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable ORD++instance Monotonic ORD+ instance SizeProp (ORD :|| Type)   where     sizeProp (C' Min) (WrapFull a :* WrapFull b :* Nil) = min (infoSize a) (infoSize b)@@ -89,99 +90,132 @@   instance ( (ORD :|| Type) :<: dom+         , Monotonic dom          , OptimizeSuper dom          )       => Optimize (ORD :|| Type) dom   where-    constructFeatOpt (C' LTH) (a :* b :* Nil)+    constructFeatOpt _ (C' LTH) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , ra `rangeLess` rb         = return (literalDecor True) -    constructFeatOpt (C' LTH) (a :* b :* Nil)+    constructFeatOpt _ (C' LTH) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , rb `rangeLessEq` ra         = return (literalDecor False) -    constructFeatOpt (C' GTH) (a :* b :* Nil)+    constructFeatOpt _ (C' GTH) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , rb `rangeLess` ra         = return (literalDecor True) -    constructFeatOpt (C' GTH) (a :* b :* Nil)+    constructFeatOpt _ (C' GTH) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , ra `rangeLessEq` rb         = return (literalDecor False) -    constructFeatOpt (C' LTE) (a :* b :* Nil)+    constructFeatOpt _ (C' LTE) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , ra `rangeLessEq` rb         = return (literalDecor True) -    constructFeatOpt (C' LTE) (a :* b :* Nil)+    constructFeatOpt _ (C' LTE) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , rb `rangeLess` ra         = return (literalDecor False) -    constructFeatOpt (C' LTE) (a :* b :* Nil)+    constructFeatOpt _ (C' LTE) (a :* b :* Nil)         | alphaEq a b         = return $ literalDecor True -    constructFeatOpt (C' GTE) (a :* b :* Nil)+    constructFeatOpt _ (C' GTE) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , rb `rangeLessEq` ra         = return (literalDecor True) -    constructFeatOpt (C' GTE) (a :* b :* Nil)+    constructFeatOpt _ (C' GTE) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , ra `rangeLess` rb         = return (literalDecor False) -    constructFeatOpt (C' GTE) (a :* b :* Nil)+    constructFeatOpt _ (C' GTE) (a :* b :* Nil)         | alphaEq a b         = return $ literalDecor True -    constructFeatOpt (C' Min) (a :* b :* Nil)+    constructFeatOpt _ (C' Min) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , ra `rangeLessEq` rb         = return a -    constructFeatOpt (C' Min) (a :* b :* Nil)+    constructFeatOpt _ (C' Min) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , rb `rangeLessEq` ra         = return b -    constructFeatOpt (C' Min) (a :* b :* Nil)+    constructFeatOpt _ (C' Min) (a :* b :* Nil)         | alphaEq a b         = return a -    constructFeatOpt (C' Max) (a :* b :* Nil)+    constructFeatOpt _ (C' Min) (a :* b :* Nil)+        | as <- viewMonotonicDec a+        , any (alphaEq b) as = return a++        | bs <- viewMonotonicDec b+        , any (alphaEq a) bs = return b+++    constructFeatOpt opts s@(C' Min) (a :* (op :$ b :$ c) :* Nil)+        | Just (C' Min) <- prjF op+        , alphaEq a b = constructFeat opts s (a :* c :* Nil)+        | Just (C' Min) <- prjF op+        , alphaEq a c = constructFeat opts s (a :* b :* Nil)++    constructFeatOpt opts s@(C' Min) ((op :$ b :$ c) :* a :* Nil)+        | Just (C' Min) <- prjF op+        , alphaEq a b = constructFeat opts s (c :* a :* Nil)+        | Just (C' Min) <- prjF op+        , alphaEq a c = constructFeat opts s (b :* a :* Nil)++    constructFeatOpt _ (C' Max) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , ra `rangeLessEq` rb         = return b -    constructFeatOpt (C' Max) (a :* b :* Nil)+    constructFeatOpt _ (C' Max) (a :* b :* Nil)         | RangeSet ra <- infoRange (getInfo a)         , RangeSet rb <- infoRange (getInfo b)         , rb `rangeLessEq` ra         = return a -    constructFeatOpt (C' Max) (a :* b :* Nil)+    constructFeatOpt _ (C' Max) (a :* b :* Nil)         | alphaEq a b         = return a -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts s@(C' Max) (a :* (op :$ b :$ c) :* Nil)+        | Just (C' Max) <- prjF op+        , alphaEq a b = constructFeat opts s (a :* c :* Nil)+        | Just (C' Max) <- prjF op+        , alphaEq a c = constructFeat opts s (a :* b :* Nil) -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatOpt opts s@(C' Max) ((op :$ b :$ c) :* a :* Nil)+        | Just (C' Max) <- prjF op+        , alphaEq a b = constructFeat opts s (c :* a :* Nil)+        | Just (C' Max) <- prjF op+        , alphaEq a c = constructFeat opts s (b :* a :* Nil)++    constructFeatOpt opts a args = constructFeatUnOpt opts a args++    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,13 +35,10 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Par where  import Language.Syntactic import Language.Syntactic.Constructs.Monad-import Language.Syntactic.Constructs.Binding import Language.Syntactic.Constructs.Binding.HigherOrder  import qualified Control.Monad.Par as CMP@@ -50,8 +49,8 @@ import Feldspar.Core.Interpretation import Feldspar.Core.Constructs.Binding -import Data.Map-import Data.Typeable+import Data.Map (notMember)+import Data.Typeable (gcast)  data ParFeature a   where@@ -71,21 +70,22 @@     semantics ParFork   = Sem "fork" CMP.fork     semantics ParYield  = Sem "yield" yield -instance Equality ParFeature where equal = equalDefault; exprHash = exprHashDefault-instance Render   ParFeature where renderArgs = renderArgsDefault-instance ToTree   ParFeature-instance Eval     ParFeature where evaluate = evaluateDefault+semanticInstances ''ParFeature+ instance EvalBind ParFeature where evalBindSym = evalBindSymDefault-instance Sharable ParFeature-  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'  instance AlphaEq dom dom dom env => AlphaEq ParFeature ParFeature dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable ParFeature+ instance Sharable (MONAD Par)-  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing' +instance Monotonic ParFeature++instance Monotonic (MONAD Par)+ instance SizeProp ParFeature   where     sizeProp ParRun   (WrapFull a :* Nil) = infoSize a@@ -101,12 +101,12 @@          )       => Optimize ParFeature dom   where-    constructFeatUnOpt ParRun args   = constructFeatUnOptDefault ParRun args-    constructFeatUnOpt ParNew args   = constructFeatUnOptDefaultTyp (ParType $ IVarType typeRep) ParNew args-    constructFeatUnOpt ParGet args   = constructFeatUnOptDefaultTyp (ParType typeRep) ParGet args-    constructFeatUnOpt ParPut args   = constructFeatUnOptDefaultTyp (ParType typeRep) ParPut args-    constructFeatUnOpt ParFork args  = constructFeatUnOptDefaultTyp (ParType typeRep) ParFork args-    constructFeatUnOpt ParYield args = constructFeatUnOptDefaultTyp (ParType typeRep) ParYield args+    constructFeatUnOpt opts ParRun args   = constructFeatUnOptDefault opts ParRun args+    constructFeatUnOpt opts ParNew args   = constructFeatUnOptDefaultTyp opts (ParType $ IVarType typeRep) ParNew args+    constructFeatUnOpt opts ParGet args   = constructFeatUnOptDefaultTyp opts (ParType typeRep) ParGet args+    constructFeatUnOpt opts ParPut args   = constructFeatUnOptDefaultTyp opts (ParType typeRep) ParPut args+    constructFeatUnOpt opts ParFork args  = constructFeatUnOptDefaultTyp opts (ParType typeRep) ParFork args+    constructFeatUnOpt opts ParYield args = constructFeatUnOptDefaultTyp opts (ParType typeRep) ParYield args  monadProxy :: P Par monadProxy = P@@ -114,28 +114,29 @@ instance SizeProp (MONAD Par)   where     sizeProp Return (WrapFull a :* Nil)      = infoSize a-    sizeProp Bind   (_ :* WrapFull f :* Nil) = infoSize f+    sizeProp Bind   (_ :* WrapFull f :* Nil) = snd $ infoSize f     sizeProp Then   (_ :* WrapFull b :* Nil) = infoSize b     sizeProp When   _                        = AnySize  instance ( MONAD Par :<: dom          , (Variable :|| Type) :<: dom          , CLambda Type :<: dom+         , Let :<: dom          , OptimizeSuper dom          )       => Optimize (MONAD Par) dom   where-    optimizeFeat bnd@Bind (ma :* f :* Nil) = do-        ma' <- optimizeM ma+    optimizeFeat opts bnd@Bind (ma :* f :* Nil) = do+        ma' <- optimizeM opts ma         case getInfo ma' of           Info (ParType ty) sz vs src -> do-            f' <- optimizeFunction optimizeM (Info ty sz vs src) f+            f' <- optimizeFunction opts (optimizeM opts) (Info ty sz vs src) f             case getInfo f' of-              Info{} -> constructFeat bnd (ma' :* f' :* Nil)+              Info{} -> constructFeat opts bnd (ma' :* f' :* Nil) -    optimizeFeat a args = optimizeFeatDefault a args+    optimizeFeat opts a args = optimizeFeatDefault opts a args -    constructFeatOpt Bind (ma :* (lam :$ (Sym (Decor _ ret) :$ var)) :* Nil)+    constructFeatOpt _ Bind (ma :* (lam :$ (ret :$ var)) :* Nil)       | Just (SubConstr2 (Lambda v1)) <- prjLambda lam       , Just Return                   <- prjMonad monadProxy ret       , Just (C' (Variable v2))       <- prjF var@@ -143,46 +144,41 @@       , Just ma' <- gcast ma       = return ma' -    constructFeatOpt Bind (ma :* (lam :$ body) :* Nil)+    constructFeatOpt opts Bind (ma :* (lam :$ body) :* Nil)         | Just (SubConstr2 (Lambda v)) <- prjLambda lam         , v `notMember` vars-        = constructFeat Then (ma :* body :* Nil)+        = constructFeat opts Then (ma :* body :* Nil)       where         vars = infoVars $ getInfo body        -- return x >> mb ==> mb-    constructFeatOpt Then ((Sym (Decor _ ret) :$ _) :* mb :* Nil)+    constructFeatOpt _ Then ((ret :$ _) :* mb :* Nil)         | Just Return <- prjMonad monadProxy ret         = return mb        -- ma >> return () ==> ma-    constructFeatOpt Then (ma :* (Sym (Decor info ret) :$ u) :* Nil)+    constructFeatOpt _ Then (ma :* (ret :$ u) :* Nil)         | Just Return <- prjMonad monadProxy ret-        , Just TypeEq <- typeEq (infoType $ getInfo ma) (ParType UnitType)-        , Just TypeEq <- typeEq (infoType info)         (ParType UnitType)+        , Just TypeEq <- typeEq (infoType $ getInfo ma)  (ParType UnitType)+        , Just TypeEq <- typeEq (infoType $ getInfo ret) (ParType UnitType)         , Just ()     <- viewLiteral u         = return ma -    constructFeatOpt a args = constructFeatUnOpt a args+    constructFeatOpt opts a args = constructFeatUnOpt opts a args -    constructFeatUnOpt Return args@(a :* Nil)+    constructFeatUnOpt opts Return args@(a :* Nil)         | Info {infoType = t} <- getInfo a-        = constructFeatUnOptDefaultTyp (ParType t) Return args+        = constructFeatUnOptDefaultTyp opts (ParType t) Return args -    constructFeatUnOpt Bind args@(_ :* f :* Nil)-        | Info {infoType = FunType _ t} <- getInfo f-        = constructFeatUnOptDefaultTyp t Bind args-      -- TODO The match on `FunType` is total with the current definition of-      --      `TypeRep`, but there's no guarantee this will remain true in the-      --      future. One way around that would be to match `f` against-      --      `Lambda`, but that is also a partial match (at least possibly, in-      --      the future). Another option would be to add a context parameter to-      --      `MONAD` to be able to add the constraint `Type a`.+    constructFeatUnOpt opts Bind args@(_ :* (lam :$ body) :* Nil)+        | Just (SubConstr2 (Lambda _))  <- prjLambda lam+        , Info {infoType = t} <- getInfo body+        = constructFeatUnOptDefaultTyp opts t Bind args -    constructFeatUnOpt Then args@(_ :* mb :* Nil)+    constructFeatUnOpt opts Then args@(_ :* mb :* Nil)         | Info {infoType = t} <- getInfo mb-        = constructFeatUnOptDefaultTyp t Then args+        = constructFeatUnOptDefaultTyp opts t Then args -    constructFeatUnOpt When args =-        constructFeatUnOptDefaultTyp voidTypeRep When args+    constructFeatUnOpt opts When args =+        constructFeatUnOptDefaultTyp opts voidTypeRep When args 

@@ -0,0 +1,47 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Feldspar.Core.Constructs.RealFloat+    ( REALFLOAT (..)+    ) where++import Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data REALFLOAT a+  where+    Atan2   :: (Type a, RealFloat a) => REALFLOAT (a :-> a :-> Full a)++instance Semantic REALFLOAT+  where+    semantics Atan2   = Sem "atan2" Prelude.atan2++semanticInstances ''REALFLOAT++instance EvalBind REALFLOAT where evalBindSym = evalBindSymDefault++instance AlphaEq dom dom dom env => AlphaEq REALFLOAT REALFLOAT dom env+  where+    alphaEqSym = alphaEqSymDefault++instance Sharable REALFLOAT++instance Monotonic REALFLOAT++instance SizeProp (REALFLOAT :|| Type)+  where+    sizeProp (C' s) = sizePropDefault s++instance ( (REALFLOAT :|| Type) :<: dom+         , OptimizeSuper dom)+      => Optimize (REALFLOAT :|| Type) dom+  where+    constructFeatUnOpt opts a@(C' _) = constructFeatUnOptDefault opts a+

@@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,8 +35,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Save where  import Language.Syntactic@@ -51,17 +51,18 @@   where     semantics Save = Sem "save" id -instance Equality Save where equal = equalDefault; exprHash = exprHashDefault-instance Render   Save where renderArgs = renderArgsDefault-instance ToTree   Save-instance Eval     Save where evaluate = evaluateDefault+semanticInstances ''Save+ instance EvalBind Save where evalBindSym = evalBindSymDefault-instance Sharable Save  instance AlphaEq dom dom dom env => AlphaEq Save Save dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable Save++instance Monotonic Save+ instance SizeProp (Save :|| Type)   where     sizeProp (C' Save) (WrapFull a :* Nil) = infoSize a@@ -70,5 +71,5 @@          , OptimizeSuper dom)       => Optimize (Save :|| Type) dom   where-    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -1,8 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -33,8 +35,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.SizeProp where  import Language.Syntactic@@ -53,18 +53,19 @@   where     semantics (PropSize _) = Sem "propSize" (const id) -instance Equality PropSize where equal = equalDefault; exprHash = exprHashDefault-instance Render   PropSize where renderArgs = renderArgsDefault-instance ToTree   PropSize-instance Eval     PropSize where evaluate = evaluateDefault+semanticInstances ''PropSize+ instance EvalBind PropSize where evalBindSym = evalBindSymDefault-instance Sharable PropSize  instance SizeProp (PropSize :|| Type)   where     sizeProp (C' (PropSize prop)) (WrapFull a :* WrapFull b :* Nil) =         prop (infoSize a) /\ infoSize b +instance Sharable PropSize++instance Monotonic PropSize+ instance AlphaEq dom dom dom env => AlphaEq PropSize PropSize dom env   where     alphaEqSym = alphaEqSymDefault@@ -73,11 +74,11 @@          , OptimizeSuper dom)       => Optimize (PropSize :|| Type) dom   where-    constructFeatOpt (C' (PropSize prop)) (a :* b :* Nil) =+    constructFeatOpt _ (C' (PropSize prop)) (a :* b :* Nil) =         return $ updateDecor (f (prop (infoSize $ getInfo a))) b       where         f :: Lattice (Size b) => Size b -> Info b -> Info b         f newSize info = info {infoSize = infoSize info /\ newSize} -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +33,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.SourceInfo     ( module Language.Syntactic.Constructs.Identity     , module Language.Syntactic.Constructs.Decoration@@ -41,7 +40,6 @@     ) where  import Language.Syntactic-import Language.Syntactic.Constructs.Binding import Language.Syntactic.Constructs.Decoration import Language.Syntactic.Constructs.Identity @@ -51,21 +49,14 @@ -- | Kind @* -> *@ version of 'SourceInfo' data SourceInfo1 a = SourceInfo1 SourceInfo -{--instance AlphaEq dom dom dom env =>-    AlphaEq-        (Decor SourceInfo1 Identity)-        (Decor SourceInfo1 Identity)-        dom-        env-  where-    alphaEqSym = alphaEqSymDefault--}- instance Sharable (Decor SourceInfo1 Identity)   where     sharable _ = True +instance Monotonic (Decor SourceInfo1 Identity)++instance Monotonic Identity+ instance SizeProp Identity   where     sizeProp Id (WrapFull a :* Nil) = infoSize a@@ -77,11 +68,11 @@ instance ((Decor SourceInfo1 Identity :|| Type) :<: dom, Optimize dom dom) =>     Optimize ((Decor SourceInfo1 Identity) :|| Type) dom   where-    optimizeFeat (C' (Decor (SourceInfo1 src) Id)) (a :* Nil) =-        localSource src $ optimizeM a+    optimizeFeat opts (C' (Decor (SourceInfo1 src) Id)) (a :* Nil) =+        localSource src $ optimizeM opts a -    constructFeatOpt (C' (Decor (SourceInfo1 _) Id)) (a :* Nil) = return a+    constructFeatOpt _ (C' (Decor (SourceInfo1 _) Id)) (a :* Nil) = return a -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x  

@@ -0,0 +1,74 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Feldspar.Core.Constructs.Switch where++import Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Eq+import Feldspar.Core.Constructs.Condition++import Data.Typeable++data Switch a+  where+    Switch :: (Type b) => Switch (b :-> Full b)++instance Semantic Switch+  where+    semantics Switch = Sem "switch" id++semanticInstances ''Switch++instance EvalBind Switch where evalBindSym = evalBindSymDefault++instance AlphaEq dom dom dom env => AlphaEq Switch Switch dom env+  where+    alphaEqSym = alphaEqSymDefault++instance Sharable Switch++instance Monotonic Switch++instance SizeProp (Switch :|| Type)+  where+    sizeProp (C' Switch) (WrapFull sz :* Nil) = infoSize sz++instance+    ( (Switch    :|| Type) :<: dom+    , (EQ        :|| Type) :<: dom+    , (Condition :|| Type) :<: dom+    , OptimizeSuper dom+    ) =>+      Optimize (Switch :|| Type) dom+  where+    -- If the arguments still have the shape of a condition tree (right+    -- spine), keep it as a Switch otherwise just return the expressions within+    constructFeatOpt opts sym@(C' Switch) args@((cond :$ (op :$ _ :$ s) :$ _ :$ f ) :* Nil)+        | Just (C' Condition) <- prjF cond+        , Just (C' Equal)     <- prjF op+        , isTree s f+        = constructFeatUnOptDefault opts sym args++    constructFeatOpt _ (C' Switch) (a :* Nil) = return a++    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x++isTree :: ( (EQ        :|| Type) :<: dom+          , (Condition :|| Type) :<: dom+          , AlphaEq dom dom (Decor Info (dom :|| Typeable)) [(VarId,VarId)]+          )+       => ASTF (Decor Info (dom :|| Typeable)) a -> ASTF (Decor Info (dom :|| Typeable)) b -> Bool+isTree s (cond :$ (op :$ c :$ a) :$ t :$ f)+    | Just (C' Condition) <- prjF cond+    , Just (C' Equal)     <- prjF op+    = alphaEq s a && isTree s f+isTree _ _ = True

@@ -1,7 +1,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +34,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Trace     ( Trace (..)     ) where@@ -64,17 +64,17 @@       type Sat Trace = Type       exprDict Trace = Dict -instance Equality Trace where equal = equalDefault; exprHash = exprHashDefault-instance Render   Trace where renderArgs = renderArgsDefault-instance ToTree   Trace-instance Eval     Trace where evaluate = evaluateDefault+semanticInstances ''Trace+ instance EvalBind Trace where evalBindSym = evalBindSymDefault-instance Sharable Trace  instance AlphaEq dom dom dom env => AlphaEq Trace Trace dom env   where     alphaEqSym = alphaEqSymDefault +instance Sharable Trace+instance Monotonic Trace+ instance SizeProp (Trace :|| Type)   where     sizeProp (C' Trace) (WrapFull _ :* WrapFull a :* Nil) = infoSize a@@ -83,5 +83,5 @@          , OptimizeSuper dom)       => Optimize (Trace :|| Type) dom   where-    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -1,9 +1,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -34,8 +34,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Constructs.Tuple     ( module Language.Syntactic.Constructs.Tuple     ) where@@ -44,13 +42,17 @@  import Language.Syntactic import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Binding.HigherOrder (CLambda) import Language.Syntactic.Constructs.Tuple  import Feldspar.Core.Types import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Binding  instance Sharable Tuple +instance Monotonic Tuple+ instance SizeProp (Tuple :|| Type)   where     sizeProp (C' Tup2) (a :* b :* Nil)@@ -122,6 +124,8 @@   where     sharable _ = False +instance Monotonic Select+ sel1Size :: (Sel1' a ~ b) => TypeRep a -> Size a -> Size b sel1Size Tup2Type{} = sel1 sel1Size Tup3Type{} = sel1@@ -192,14 +196,14 @@     ) =>       Optimize (Tuple :|| Type) dom   where-    constructFeatOpt (C' tup@Tup2) (s1 :* s2 :* Nil)+    constructFeatOpt _ (C' tup@Tup2) (s1 :* s2 :* Nil)         | (prjF -> Just (C' Sel1)) :$ a <- s1         , (prjF -> Just (C' Sel2)) :$ b <- s2         , alphaEq a b         , Just TypeEq <- tupEq tup a         = return a -    constructFeatOpt (C' tup@Tup3) (s1 :* s2 :* s3 :* Nil)+    constructFeatOpt _ (C' tup@Tup3) (s1 :* s2 :* s3 :* Nil)         | (prjF -> Just (C' Sel1)) :$ a <- s1         , (prjF -> Just (C' Sel2)) :$ b <- s2         , (prjF -> Just (C' Sel3)) :$ c <- s3@@ -208,7 +212,7 @@         , Just TypeEq <- tupEq tup a         = return a -    constructFeatOpt (C' tup@Tup4) (s1 :* s2 :* s3 :* s4 :* Nil)+    constructFeatOpt _ (C' tup@Tup4) (s1 :* s2 :* s3 :* s4 :* Nil)         | (prjF -> Just (C' Sel1)) :$ a <- s1         , (prjF -> Just (C' Sel2)) :$ b <- s2         , (prjF -> Just (C' Sel3)) :$ c <- s3@@ -219,7 +223,7 @@         , Just TypeEq <- tupEq tup a         = return a -    constructFeatOpt (C' tup@Tup5) (s1 :* s2 :* s3 :* s4 :* s5 :* Nil)+    constructFeatOpt _ (C' tup@Tup5) (s1 :* s2 :* s3 :* s4 :* s5 :* Nil)         | (prjF -> Just (C' Sel1)) :$ a <- s1         , (prjF -> Just (C' Sel2)) :$ b <- s2         , (prjF -> Just (C' Sel3)) :$ c <- s3@@ -232,7 +236,7 @@         , Just TypeEq <- tupEq tup a         = return a -    constructFeatOpt (C' tup@Tup6) (s1 :* s2 :* s3 :* s4 :* s5 :* s6 :* Nil)+    constructFeatOpt _ (C' tup@Tup6) (s1 :* s2 :* s3 :* s4 :* s5 :* s6 :* Nil)         | (prjF -> Just (C' Sel1)) :$ a <- s1         , (prjF -> Just (C' Sel2)) :$ b <- s2         , (prjF -> Just (C' Sel3)) :$ c <- s3@@ -247,7 +251,7 @@         , Just TypeEq <- tupEq tup a         = return a -    constructFeatOpt (C' tup@Tup7) (s1 :* s2 :* s3 :* s4 :* s5 :* s6 :* s7 :* Nil)+    constructFeatOpt _ (C' tup@Tup7) (s1 :* s2 :* s3 :* s4 :* s5 :* s6 :* s7 :* Nil)         | (prjF -> Just (C' Sel1)) :$ a <- s1         , (prjF -> Just (C' Sel2)) :$ b <- s2         , (prjF -> Just (C' Sel3)) :$ c <- s3@@ -264,60 +268,100 @@         , Just TypeEq <- tupEq tup a         = return a -    constructFeatOpt feat args = constructFeatUnOpt feat args+    constructFeatOpt opts feat args = constructFeatUnOpt opts feat args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x   instance     ( (Select :|| Type) :<: dom+    , CLambda Type :<: dom     , (Tuple  :|| Type) :<: dom-    , Optimize dom dom+    , Let :<: dom+    , (Variable :|| Type) :<: dom+    , OptimizeSuper dom     ) =>       Optimize (Select :|| Type) dom   where-    constructFeatOpt (C' Sel1) (t :* Nil)+    constructFeatOpt opts s@(C' Sel1) (t :* Nil)         | ((prjF -> Just (C' Tup2)) :$ a :$ _) <- t                          = return a         | ((prjF -> Just (C' Tup3)) :$ a :$ _ :$ _) <- t                     = return a         | ((prjF -> Just (C' Tup4)) :$ a :$ _ :$ _ :$ _) <- t                = return a         | ((prjF -> Just (C' Tup5)) :$ a :$ _ :$ _ :$ _ :$ _) <- t           = return a         | ((prjF -> Just (C' Tup6)) :$ a :$ _ :$ _ :$ _ :$ _ :$ _) <- t      = return a         | ((prjF -> Just (C' Tup7)) :$ a :$ _ :$ _ :$ _ :$ _ :$ _ :$ _) <- t = return a+        | ((prj  -> Just Let) :$ a :$ (lam :$ b)) <- t+        , (Just v@(SubConstr2 (Lambda {}))) <- prjLambda lam+         = do s' <- constructFeatOpt opts s (b :* Nil)+              b' <- constructFeatOpt opts (reuseCLambda v) (s' :* Nil)+              constructFeatOpt opts Let (a :* b' :* Nil) -    constructFeatOpt (C' Sel2) (t :* Nil)++    constructFeatOpt opts s@(C' Sel2) (t :* Nil)         | ((prjF -> Just (C' Tup2)) :$ _ :$ a) <- t                          = return a         | ((prjF -> Just (C' Tup3)) :$ _ :$ a :$ _) <- t                     = return a         | ((prjF -> Just (C' Tup4)) :$ _ :$ a :$ _ :$ _) <- t                = return a         | ((prjF -> Just (C' Tup5)) :$ _ :$ a :$ _ :$ _ :$ _) <- t           = return a         | ((prjF -> Just (C' Tup6)) :$ _ :$ a :$ _ :$ _ :$ _ :$ _) <- t      = return a         | ((prjF -> Just (C' Tup7)) :$ _ :$ a :$ _ :$ _ :$ _ :$ _ :$ _) <- t = return a+        | ((prj  -> Just Let) :$ a :$ (lam :$ b)) <- t+        , (Just v@(SubConstr2 (Lambda {}))) <- prjLambda lam+         = do s' <- constructFeatOpt opts s (b :* Nil)+              b' <- constructFeatOpt opts (reuseCLambda v) (s' :* Nil)+              constructFeatOpt opts Let (a :* b' :* Nil) -    constructFeatOpt (C' Sel3) (t :* Nil)+    constructFeatOpt opts s@(C' Sel3) (t :* Nil)         | ((prjF -> Just (C' Tup3)) :$ _ :$ _ :$ a) <- t                     = return a         | ((prjF -> Just (C' Tup4)) :$ _ :$ _ :$ a :$ _) <- t                = return a         | ((prjF -> Just (C' Tup5)) :$ _ :$ _ :$ a :$ _ :$ _) <- t           = return a         | ((prjF -> Just (C' Tup6)) :$ _ :$ _ :$ a :$ _ :$ _ :$ _) <- t      = return a         | ((prjF -> Just (C' Tup7)) :$ _ :$ _ :$ a :$ _ :$ _ :$ _ :$ _) <- t = return a+        | ((prj  -> Just Let) :$ a :$ (lam :$ b)) <- t+        , (Just v@(SubConstr2 (Lambda {}))) <- prjLambda lam+         = do s' <- constructFeatOpt opts s (b :* Nil)+              b' <- constructFeatOpt opts (reuseCLambda v) (s' :* Nil)+              constructFeatOpt opts Let (a :* b' :* Nil) -    constructFeatOpt (C' Sel4) (t :* Nil)+    constructFeatOpt opts s@(C' Sel4) (t :* Nil)         | ((prjF -> Just (C' Tup4)) :$ _ :$ _ :$ _ :$ a) <- t                = return a         | ((prjF -> Just (C' Tup5)) :$ _ :$ _ :$ _ :$ a :$ _) <- t           = return a         | ((prjF -> Just (C' Tup6)) :$ _ :$ _ :$ _ :$ a :$ _ :$ _) <- t      = return a         | ((prjF -> Just (C' Tup7)) :$ _ :$ _ :$ _ :$ a :$ _ :$ _ :$ _) <- t = return a+        | ((prj  -> Just Let) :$ a :$ (lam :$ b)) <- t+        , (Just v@(SubConstr2 (Lambda {}))) <- prjLambda lam+         = do s' <- constructFeatOpt opts s (b :* Nil)+              b' <- constructFeatOpt opts (reuseCLambda v) (s' :* Nil)+              constructFeatOpt opts Let (a :* b' :* Nil) -    constructFeatOpt (C' Sel5) (t :* Nil)+    constructFeatOpt opts s@(C' Sel5) (t :* Nil)         | ((prjF -> Just (C' Tup5)) :$ _ :$ _ :$ _ :$ _ :$ a) <- t           = return a         | ((prjF -> Just (C' Tup6)) :$ _ :$ _ :$ _ :$ _ :$ a :$ _) <- t      = return a         | ((prjF -> Just (C' Tup7)) :$ _ :$ _ :$ _ :$ _ :$ a :$ _ :$ _) <- t = return a+        | ((prj  -> Just Let) :$ a :$ (lam :$ b)) <- t+        , (Just v@(SubConstr2 (Lambda {}))) <- prjLambda lam+         = do s' <- constructFeatOpt opts s (b :* Nil)+              b' <- constructFeatOpt opts (reuseCLambda v) (s' :* Nil)+              constructFeatOpt opts Let (a :* b' :* Nil) -    constructFeatOpt (C' Sel6) (t :* Nil)+    constructFeatOpt opts s@(C' Sel6) (t :* Nil)         | ((prjF -> Just (C' Tup6)) :$ _ :$ _ :$ _ :$ _ :$ _ :$ a) <- t      = return a         | ((prjF -> Just (C' Tup7)) :$ _ :$ _ :$ _ :$ _ :$ _ :$ a :$ _) <- t = return a+        | ((prj  -> Just Let) :$ a :$ (lam :$ b)) <- t+        , (Just v@(SubConstr2 (Lambda {}))) <- prjLambda lam+         = do s' <- constructFeatOpt opts s (b :* Nil)+              b' <- constructFeatOpt opts (reuseCLambda v) (s' :* Nil)+              constructFeatOpt opts Let (a :* b' :* Nil) -    constructFeatOpt (C' Sel7) (t :* Nil)++    constructFeatOpt opts s@(C' Sel7) (t :* Nil)         | ((prjF -> Just (C' Tup7)) :$ _ :$ _ :$ _ :$ _ :$ _ :$ _ :$ a) <- t = return a+        | ((prj  -> Just Let) :$ a :$ (lam :$ b)) <- t+        , (Just v@(SubConstr2 (Lambda {}))) <- prjLambda lam+         = do s' <- constructFeatOpt opts s (b :* Nil)+              b' <- constructFeatOpt opts (reuseCLambda v) (s' :* Nil)+              constructFeatOpt opts Let (a :* b' :* Nil) -    constructFeatOpt feat args = constructFeatUnOpt feat args+    constructFeatOpt opts feat args = constructFeatUnOpt opts feat args -    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+    constructFeatUnOpt opts x@(C' _) = constructFeatUnOptDefault opts x 

@@ -42,20 +42,25 @@ module Feldspar.Core.Frontend     ( module Data.Patch     , Syntactic-    , SyntacticFeld     , Internal -    , FeldDomainAll+    , FeldDomain     , Data     , Syntax      , module Frontend +    , FeldOpts+    , defaultFeldOpts     , reifyFeld+    , reifyFeldUnOpt     , showExpr     , printExpr+    , printExprWith+    , printExprUnOpt     , showAST     , drawAST+    , writeHtmlAST     , showDecor     , drawDecor     , eval@@ -66,7 +71,7 @@      -- * QuickCheck     , (===>)-    , (===)+    , (====)      -- * Type constraints     , tData@@ -85,10 +90,9 @@ import Test.QuickCheck  import Data.Patch-import Data.Typeable  import Language.Syntactic hiding-    (desugar, sugar, resugar, printExpr, showAST, drawAST)+    (desugar, sugar, resugar, showAST, drawAST, writeHtmlAST) import qualified Language.Syntactic as Syntactic import qualified Language.Syntactic.Constructs.Decoration as Syntactic import Language.Syntactic.Constructs.Binding@@ -97,7 +101,7 @@  import Feldspar.Range import Feldspar.Core.Types-import Feldspar.Core.Interpretation hiding (showDecor, drawDecor)+import Feldspar.Core.Interpretation import Feldspar.Core.Constructs import Feldspar.Core.Constructs.Binding (cLambda) import Feldspar.Core.Frontend.Array            as Frontend@@ -126,45 +130,52 @@ import Feldspar.Core.Frontend.Ord              as Frontend import Feldspar.Core.Frontend.Par              as Frontend import Feldspar.Core.Frontend.Save             as Frontend-import Feldspar.Core.Frontend.Select           as Frontend import Feldspar.Core.Frontend.SizeProp         as Frontend import Feldspar.Core.Frontend.SourceInfo       as Frontend+import Feldspar.Core.Frontend.Switch           as Frontend+import Feldspar.Core.Frontend.RealFloat        as Frontend import Feldspar.Core.Frontend.Trace            as Frontend import Feldspar.Core.Frontend.Tuple            as Frontend  -prjDict :: PrjDict (Decor Info FeldDomain)++prjDict :: PrjDict (Decor Info FeldDom) prjDict = PrjDict     (prjVariable prjDictFO . decorExpr)     (prjLambda   prjDictFO . decorExpr) -mkId :: MkInjDict (Decor Info FeldDomain)-mkId a b | simpleMatch (const . sharable) a-         , Just Dict <- typeDict b-         , Just Dict <- typeDict a-         = Just InjDict-             { injVariable = Decor (getInfo a) . injC . c' . Variable-             , injLambda   = let info = ((mkInfoTy (FunType typeRep typeRep)) { infoSize = infoSize (getInfo b)})-                             in Decor info . injC . cLambda-             , injLet      = Decor (getInfo b) $ injC $ c' Let-             }-mkId _ _ = Nothing+mkId :: FeldOpts -> MkInjDict (Decor Info FeldDom)+mkId opts a b+  | simpleMatch (const . sharable) a+  , Just Dict <- typeDict a+  , Dict <- exprDictSub pTypeable b+  , Info {infoType = bType} <- getInfo b+  = case bType of+      FunType{} | P.not (SICS `inTarget` opts) -> Nothing+      _         -> Just InjDict+                            { injVariable = Decor (getInfo a) . injC . c' . Variable+                            , injLambda   = let info = ((mkInfoTy (FunType typeRep bType)) {infoSize = (infoSize (getInfo a), infoSize (getInfo b))})+                                            in Decor info . injC . cLambda+                            , injLet      = Decor (getInfo b) $ injC Let+                            }+mkId _ _ _ = Nothing  -type SyntacticFeld a = (Syntactic a, Domain a ~  FeldDomainAll, Typeable (Internal a))-  -- TODO Typeable needed?- -- | Reification and optimization of a Feldspar program reifyFeld :: SyntacticFeld a-    => BitWidth n+    => FeldOpts+    -> BitWidth n     -> a-    -> ASTF (Decor Info FeldDomain) (Internal a)-reifyFeld n = flip evalState 0 .+    -> ASTF (Decor Info FeldDom) (Internal a)+reifyFeld opts n = flip evalState 0 .     (   return-    <=< codeMotion prjDict mkId-    .   optimize+    .   optimize opts+    .   stripDecor+    <=< codeMotion (simpleMatch (const . hoistOver)) prjDict (mkId opts)+    .   optimize opts     .   targetSpecialization n     <=< reifyM+    .   fromFeld     .   Syntactic.desugar     )   -- Note that it's important to do 'codeMotion' after 'optimize'. There may be@@ -173,28 +184,56 @@   -- first, these sub-expressions would be let bound, preventing subsequent   -- optimizations. +-- | Reification of a Feldspar program+reifyFeldUnOpt :: SyntacticFeld a+    => FeldOpts -> BitWidth n+    -> a+    -> ASTF FeldDom (Internal a)+reifyFeldUnOpt _ n = flip evalState 0 .+    (   return+    .   targetSpecialization n+    <=< reifyM+    .   fromFeld+    .   Syntactic.desugar+    )+ showExpr :: SyntacticFeld a => a -> String-showExpr = render . reifyFeld N32+showExpr = render . reifyFeld defaultFeldOpts N32 +-- | Print an optimized expression printExpr :: SyntacticFeld a => a -> IO ()-printExpr = Syntactic.printExpr . reifyFeld N32+printExpr = print . reifyFeld defaultFeldOpts N32 +-- | Print an optimized expression with options+printExprWith :: SyntacticFeld a => FeldOpts -> a -> IO ()+printExprWith opts = print . reifyFeld opts N32++-- | Print an unoptimized expression+printExprUnOpt :: SyntacticFeld a => a -> IO ()+printExprUnOpt = print . reifyFeldUnOpt defaultFeldOpts N32++-- | Show the syntax tree using Unicode art showAST :: SyntacticFeld a => a -> String-showAST = Syntactic.showAST . reifyFeld N32+showAST = Syntactic.showAST . reifyFeld defaultFeldOpts N32 +-- | Draw the syntax tree on the terminal using Unicode art drawAST :: SyntacticFeld a => a -> IO ()-drawAST = Syntactic.drawAST . reifyFeld N32+drawAST = Syntactic.drawAST . reifyFeld defaultFeldOpts N32 +-- | Convert the syntax tree to an HTML file with foldable nodes+writeHtmlAST :: SyntacticFeld a => FilePath -> a -> IO ()+writeHtmlAST file = Syntactic.writeHtmlAST file . reifyFeld defaultFeldOpts N32+ -- | Draw a syntax tree decorated with type and size information showDecor :: SyntacticFeld a => a -> String-showDecor = Syntactic.showDecor . reifyFeld N32+showDecor = Syntactic.showDecorWith show . reifyFeld defaultFeldOpts N32  -- | Draw a syntax tree decorated with type and size information drawDecor :: SyntacticFeld a => a -> IO ()-drawDecor = Syntactic.drawDecor . reifyFeld N32+drawDecor = Syntactic.drawDecorWith show . reifyFeld defaultFeldOpts N32  eval :: SyntacticFeld a => a -> Internal a-eval = evalBind . reifyFeld N32+eval = evalBind . reifyFeld defaultFeldOpts N32  evalTarget     :: ( SyntacticFeld a@@ -202,9 +241,8 @@        , BoundedInt (GenericInt S n)        )     => BitWidth n -> a -> Internal a-evalTarget n = evalBind . reifyFeld n-  -- TODO This doesn't work yet, because 'targetSpecialization' is not-  --      implemented+evalTarget n = evalBind . reifyFeld defaultFeldOpts n+  -- TODO This doesn't work yet, because 'targetSpecialization' is not implemented  desugar :: Syntax a => a -> Data (Internal a) desugar = Syntactic.resugar@@ -233,18 +271,19 @@ a ===> b = eval a ==> b  +-- | Test that two function of the same arity have the same semantics class Equal a   where-    (===) :: a -> a -> Property+    (====) :: a -> a -> Property  instance (P.Eq a, Show a) => Equal a   where-    x === y = printTestCase ("Evaluated property: " ++ show x ++ " === " ++ show y)-            $ property (x P.== y)+    x ==== y = printTestCase ("Evaluated property: " ++ show x ++ " ==== " ++ show y)+             $ property (x P.== y)  instance (Show a, Arbitrary a, Equal b) => Equal (a -> b)   where-    f === g = property (\x -> f x === g x)+    f ==== g = property (\x -> f x ==== g x)   --------------------------------------------------------------------------------@@ -278,5 +317,6 @@ nlz :: (Bits a) => Data a -> Data Index nlz x = bitCount $ complement $ foldl go x $ takeWhile (P.< bitSize' x) $ P.map (2 P.^) [(0::Integer)..]   where-    go b s = b .|. (b .>>. value s)+    go b s = share b $ \b' -> b' .|. (b' .>>. value s)+      -- TODO share is probably not needed when observable sharing is implemented 

@@ -43,8 +43,6 @@ import Feldspar.Core.Constructs.Array import Feldspar.Core.Frontend.Tuple () -import Language.Syntactic- parallel :: Type a => Data Length -> (Data Index -> Data a) -> Data [a] parallel = sugarSymF Parallel 

@@ -30,19 +30,22 @@  import Language.Syntactic -import Feldspar.Core.Types import Feldspar.Core.Constructs.Binding import Feldspar.Core.Constructs  -- | Share an expression in the scope of a function share :: (Syntax a, Syntax b) => a -> (a -> b) -> b-share = sugarSymF Let+share = sugarSymC Let  -- | Share the intermediate result when composing functions (.<) :: (Syntax b, Syntax c) => (b -> c) -> (a -> b) -> a -> c (.<) f g a = share (g a) f +infixr 9 .<+ -- | Share an expression in the scope of a function ($<) :: (Syntax a, Syntax b) => (a -> b) -> a -> b ($<) = flip share++infixr 0 $< 

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}@@ -41,9 +42,7 @@ import Data.Int import Data.Word -import Language.Syntactic--import Feldspar.Range+import Feldspar.Range (Range(..)) import Feldspar.Core.Types import Feldspar.Core.Constructs import Feldspar.Core.Constructs.Bits@@ -57,7 +56,7 @@  class (Type a, B.Bits a, Integral a, Bounded a, Size a ~ Range a) => Bits a   where-    -- Logical operations+    -- * Logical operations     (.&.)         :: Data a -> Data a -> Data a     (.&.)         = sugarSymF BAnd     (.|.)         :: Data a -> Data a -> Data a@@ -67,7 +66,7 @@     complement    :: Data a -> Data a     complement    = sugarSymF Complement -    -- Bitwise operations+    -- * Bitwise operations     bit           :: Data Index -> Data a     bit           = sugarSymF Bit     setBit        :: Data a -> Data Index -> Data a@@ -79,7 +78,7 @@     testBit       :: Data a -> Data Index -> Data Bool     testBit       = sugarSymF TestBit -    -- Movement operations+    -- * Movement operations     shiftLU       :: Data a -> Data Index -> Data a     shiftLU       = sugarSymF ShiftLU     shiftRU       :: Data a -> Data Index -> Data a@@ -99,6 +98,7 @@     reverseBits   :: Data a -> Data a     reverseBits   = sugarSymF ReverseBits +    -- * Query operations     bitScan       :: Data a -> Data Index     bitScan       = sugarSymF BitScan     bitCount      :: Data a -> Data Index@@ -106,18 +106,21 @@      bitSize       :: Data a -> Data Index     bitSize       = value . bitSize'-     bitSize'      :: Data a -> Index-    bitSize'      = const $ fromIntegral $ B.bitSize (undefined :: a)+    bitSize'      = const $ fromIntegral $ finiteBitSize (undefined :: a)+     isSigned      :: Data a -> Data Bool-    isSigned      = sugarSymF IsSigned+    isSigned      = value . isSigned'+    isSigned'     :: Data a -> Bool+    isSigned'     = const $ B.isSigned (undefined :: a) -(⊕)    :: (Bits a) => Data a -> Data a -> Data a-(⊕)    =  xor-(.<<.) :: (Bits a) => Data a -> Data Index -> Data a-(.<<.) =  shiftLU-(.>>.) :: (Bits a) => Data a -> Data Index -> Data a-(.>>.) =  shiftRU+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+finiteBitSize :: (B.FiniteBits b) => b -> Int+finiteBitSize = B.finiteBitSize+#else+finiteBitSize :: (B.Bits b) => b -> Int+finiteBitSize = B.bitSize+#endif  instance Bits Word8 instance Bits Word16@@ -129,4 +132,25 @@ instance Bits Int32 instance Bits Int64 instance Bits IntN++-- * Combinators++(⊕)    :: (Bits a) => Data a -> Data a -> Data a+(⊕)    =  xor+(.<<.) :: (Bits a) => Data a -> Data Index -> Data a+(.<<.) =  shiftLU+(.>>.) :: (Bits a) => Data a -> Data Index -> Data a+(.>>.) =  shiftRU++-- | Set all bits to one+allOnes :: Bits a => Data a+allOnes = complement 0++-- | Set the `n` lowest bits to one+oneBits :: Bits a => Data Index -> Data a+oneBits n = complement (allOnes .<<. n)++-- | Extract the `k` lowest bits+lsbs :: Bits a => Data Index -> Data a -> Data a+lsbs k i = i .&. oneBits k 

@@ -35,8 +35,6 @@ import Feldspar.Core.Constructs.Complex import Feldspar.Core.Frontend.Num -import Language.Syntactic- complex :: (Numeric a, RealFloat a) => Data a -> Data a -> Data (Complex a) complex = sugarSymF MkComplex 

@@ -28,16 +28,20 @@  module Feldspar.Core.Frontend.Condition where -import Language.Syntactic- import Feldspar.Core.Constructs.Condition import Feldspar.Core.Constructs  condition :: (Syntax a) => Data Bool -> a -> a -> a condition c t f = sugarSymF Condition c t f -(?) :: (Syntax a) => Data Bool -> (a, a) -> a-c ? (t, e) = condition c t e+-- | Condition operator. Use as follows:+--+-- > cond1 ? ex1 $+-- > cond2 ? ex2 $+-- > cond3 ? ex3 $+-- >   exDefault+(?) :: (Syntax a) => Data Bool -> a -> a -> a+(?) = condition -infix 1 ?+infixl 1 ? 

@@ -38,3 +38,9 @@ ifM :: Syntax a => Data Bool -> M a -> M a -> M a ifM = sugarSymC ConditionM +whenM :: Data Bool -> M () -> M ()+whenM c ma = ifM c ma (return ())++unlessM :: Data Bool -> M () -> M ()+unlessM c mb = ifM c (return ()) mb+

@@ -37,19 +37,15 @@  import Prelude hiding (Integral) -import Language.Syntactic--import Feldspar.Range-import Feldspar.Core.Types import Feldspar.Core.Constructs import Feldspar.Core.Constructs.Conversion import Feldspar.Core.Frontend.Integral import Feldspar.Core.Frontend.Num -i2f :: (Integral a) => Data a -> Data Float+i2f :: (Integral a, Numeric b, RealFloat b) => Data a -> Data b i2f = i2n -f2i :: Integral a => Data Float -> Data a+f2i :: (Integral a, Numeric b, RealFloat b) => Data b -> Data a f2i = sugarSymF F2I  i2n :: (Integral a, Numeric b) => Data a -> Data b@@ -58,15 +54,15 @@ b2i :: Integral a => Data Bool -> Data a b2i = sugarSymF B2I -truncate :: Integral a => Data Float -> Data a+truncate :: (Integral a, Numeric b, RealFloat b) => Data b -> Data a truncate = f2i -round :: Integral a => Data Float -> Data a+round :: (Integral a, Numeric b, RealFloat b) => Data b -> Data a round = sugarSymF Round -ceiling :: Integral a => Data Float -> Data a+ceiling :: (Integral a, Numeric b, RealFloat b) => Data b -> Data a ceiling = sugarSymF Ceiling -floor :: Integral a => Data Float -> Data a+floor :: (Integral a, Numeric b, RealFloat b) => Data b -> Data a floor = sugarSymF Floor 

@@ -35,8 +35,6 @@ import Data.Word import Data.Complex -import Language.Syntactic- import Feldspar.Prelude import Feldspar.Core.Types import Feldspar.Core.Constructs@@ -56,6 +54,7 @@ instance Eq () instance Eq Bool instance Eq Float+instance Eq Double instance Eq Word8 instance Eq Word16 instance Eq Word32@@ -74,5 +73,5 @@ instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f)       => Eq (a,b,c,d,e,f) instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Eq (a,b,c,d,e,f,g) -instance (Eq a, RealFloat a) => Eq (Complex a)+instance (Eq a, P.RealFloat a) => Eq (Complex a) 

@@ -28,8 +28,6 @@  module Feldspar.Core.Frontend.Error where -import Language.Syntactic- import Feldspar.Core.Constructs import Feldspar.Core.Constructs.Error import Feldspar.Core.Frontend.Literal

@@ -1,6 +1,4 @@-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}  -- -- Copyright (c) 2009-2011, ERICSSON AB@@ -36,13 +34,12 @@  import Feldspar.Core.Types import Feldspar.Core.Constructs.FFI+import Feldspar.Core.Constructs  foreignImport :: ( Type (DenResult a)---                 , Signature a                  , SyntacticN c b-                 , ApplySym a b dom-                 , FFI :<: dom+                 , ApplySym a b FeldDomain                  )               => String -> Denotation a -> c-foreignImport name f = sugarSym (ForeignImport name f)+foreignImport name f = sugarSymF (ForeignImport name f) 

@@ -29,11 +29,9 @@ module Feldspar.Core.Frontend.Floating where  import qualified Prelude-import Prelude (Float)+import Prelude (Float,Double) import Data.Complex -import Language.Syntactic- import Feldspar.Core.Constructs import Feldspar.Core.Constructs.Floating import Feldspar.Core.Frontend.Fractional@@ -81,5 +79,9 @@   acosh     =  sugarSymF Acosh  instance Floating Float+instance Floating Double+ instance (Fraction a, Prelude.RealFloat a) => Floating (Complex a) +π :: Floating a => Data a+π = pi

@@ -31,8 +31,6 @@  import Data.Complex -import Language.Syntactic- import Feldspar.Core.Constructs import Feldspar.Core.Constructs.Fractional @@ -51,6 +49,7 @@     divFrac = sugarSymF DivFrac  instance Fraction Float+instance Fraction Double  instance (Fraction a, RealFloat a) => Fraction (Complex a) 

@@ -51,12 +51,10 @@  instance Syntax a => Syntactic (Future a)   where-    type Domain (Future a)   = FeldDomainAll+    type Domain (Future a)   = FeldDomain     type Internal (Future a) = FVal (Internal a)     desugar = desugar . unFuture     sugar   = Future . sugar--instance Syntax a => Syntax (Future a)  future :: Syntax a => a -> Future a future = sugarSymF MkFuture

@@ -1,5 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -40,8 +42,6 @@ import Data.Int import Data.Word -import Language.Syntactic- import Feldspar.Range import Feldspar.Core.Types import Feldspar.Core.Constructs@@ -60,21 +60,16 @@     rem  :: Data a -> Data a -> Data a     rem  = sugarSymF Rem     div  :: Data a -> Data a -> Data a-    div  = divSem+    div  = sugarSymF Div     mod  :: Data a -> Data a -> Data a     mod  = sugarSymF Mod     (^)  :: Data a -> Data a -> Data a     (^)  = sugarSymF Exp --- TODO: This is a short-term hack because the compiler doesn't compile--- the Div construct correctly. So we give the semantics of div in terms of--- quot directly, and never use the Div construct. In the long term the--- compiler should be fixed, but it involves writing type corrector plugins--- and this solution was quicker. divSem :: (Integral a)        => Data a -> Data a -> Data a-divSem x y = (x > 0 && y < 0 || x < 0 && y > 0) && rem x y /= 0 ?-             (quot x y P.- 1,quot x y)+divSem x y = (x > 0 && y < 0 || x < 0 && y > 0) && rem x y /= 0 ?   quot x y P.- 1+                                                                P.$ quot x y  instance Integral Word8 instance Integral Word16

@@ -34,7 +34,6 @@ module Feldspar.Core.Frontend.Literal where  import Language.Syntactic-import Feldspar.Core.Types import Feldspar.Core.Constructs.Literal import Feldspar.Core.Constructs import Feldspar.Core.Interpretation@@ -50,10 +49,8 @@  instance Syntactic ()   where-    type Domain ()   = FeldDomainAll+    type Domain ()   = FeldDomain     type Internal () = ()     desugar = appSymC . c' . Literal     sugar _ = ()--instance Syntax () 

@@ -35,8 +35,6 @@ import Feldspar.Core.Frontend.Literal import Feldspar.Core.Frontend.Condition -import Language.Syntactic- infixr 3 && infixr 3 &&* infixr 2 ||@@ -54,9 +52,9 @@  -- | Lazy conjunction, second argument only evaluated if necessary (&&*) :: Data Bool -> Data Bool -> Data Bool-a &&* b =  a ? (b,false)+a &&* b =  a ? b $ false  -- | Lazy disjunction, second argument only evaluated if necessary (||*) :: Data Bool -> Data Bool -> Data Bool-a ||* b = a ? (true,b)+a ||* b = a ? true $ b 

@@ -47,12 +47,14 @@ import Feldspar.Core.Frontend.Logic import qualified Feldspar.Core.Constructs.Mutable as Feature -newtype M a = M { unM :: Mon FeldSymbols Type Mut a }-  deriving (Functor, Monad)+import Control.Applicative +newtype M a = M { unM :: Mon FeldDomain Mut a }+  deriving (Functor, Applicative, Monad)+ instance Syntax a => Syntactic (M a)   where-    type Domain (M a)   = FeldDomainAll+    type Domain (M a)   = FeldDomain     type Internal (M a) = Mut (Internal a)     desugar = desugar . unM     sugar   = M . sugar

@@ -1,3 +1,6 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- -- Copyright (c) 2009-2011, ERICSSON AB -- All rights reserved.@@ -31,34 +34,49 @@  import Language.Syntactic +import Data.List (genericLength)+import Control.Monad (zipWithM_)+ import Feldspar.Core.Types import Feldspar.Core.Constructs import Feldspar.Core.Constructs.Loop import Feldspar.Core.Constructs.MutableArray import Feldspar.Core.Frontend.Mutable+import Feldspar.Core.Frontend.Literal (value) +-- | Create a new 'Mutable' Array and intialize all elements newArr :: Type a => Data Length -> Data a -> M (Data (MArr a)) newArr = sugarSymC NewArr +-- | Create a new 'Mutable' Array but leave the elements un-initialized newArr_ :: Type a => Data Length -> M (Data (MArr a)) newArr_ = sugarSymC NewArr_ -newListArr :: Type a => [Data a] -> M (Data (MArr a))-newListArr _ = error "newListArr: unimplemented" -- TODO+-- | Create a new 'Mutable' Array and initialize with elements from the+-- list+newListArr :: forall a. Type a => [Data a] -> M (Data (MArr a))+newListArr xs = do arr <- newArr_ (value $ genericLength xs)+                   zipWithM_ (setArr arr . value) [0..] xs+                   return arr +-- | Extract the element at index getArr :: Type a => Data (MArr a) -> Data Index -> M (Data a) getArr = sugarSymC GetArr +-- | Replace the value at index setArr :: Type a => Data (MArr a) -> Data Index -> Data a -> M () setArr = sugarSymC SetArr +-- | Modify the element at index modifyArr :: Type a           => Data (MArr a) -> Data Index -> (Data a -> Data a) -> M () modifyArr arr i f = getArr arr i >>= setArr arr i . f +-- | Query the length of the array arrLength :: Type a => Data (MArr a) -> M (Data Length) arrLength = sugarSymC ArrLength +-- | Modify all elements mapArray :: Type a => (Data a -> Data a) -> Data (MArr a) -> M (Data (MArr a)) mapArray f arr = do     len <- arrLength arr@@ -68,11 +86,11 @@ forArr :: Syntax a => Data Length -> (Data Index -> M a) -> M () forArr = sugarSymC For -swap :: Syntax a-     => Data (MArr (Internal a)) -> Data Index -> Data Index -> M ()+-- | Swap two elements+swap :: Type a+     => Data (MArr a) -> Data Index -> Data Index -> M () swap a i1 i2 = do-    tmp1 <- getArr a i1-    tmp2 <- getArr a i2-    setArr a i1 tmp2 :: M ()-    setArr a i2 tmp1 :: M ()+    tmp <- getArr a i1+    getArr a i2 >>= setArr a i1+    setArr a i2 tmp 

@@ -47,13 +47,11 @@  instance Syntax a => Syntactic (Ref a)   where-    type Domain (Ref a)   = FeldDomainAll+    type Domain (Ref a)   = FeldDomain     type Internal (Ref a) = IORef (Internal a)     desugar = desugar . unRef     sugar   = Ref . sugar -instance Syntax a => Syntax (Ref a)- newRef :: Syntax a => a -> M (Ref a) newRef = sugarSymC NewRef @@ -64,5 +62,5 @@ setRef = sugarSymC SetRef  modifyRef :: Syntax a => Ref a -> (a -> a) -> M ()-modifyRef r f = getRef r >>= setRef r . f+modifyRef = sugarSymC ModRef 

@@ -28,8 +28,6 @@  module Feldspar.Core.Frontend.NoInline where -import Language.Syntactic- import Feldspar.Core.Constructs import Feldspar.Core.Constructs.NoInline 

@@ -38,8 +38,6 @@ import Data.Int import Data.Word -import Language.Syntactic- import Feldspar.Core.Types import Feldspar.Core.Constructs import Feldspar.Core.Constructs.Num@@ -72,6 +70,7 @@ instance Numeric IntN  instance Numeric Float+instance Numeric Double  instance (Type a, RealFloat a) => Numeric (Complex a) 

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,8 +33,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Frontend.Ord where  import qualified Prelude@@ -41,8 +40,6 @@ import Data.Int import Data.Word -import Language.Syntactic- import Feldspar.Prelude import Feldspar.Core.Types import Feldspar.Core.Constructs@@ -84,6 +81,4 @@ instance Ord WordN instance Ord IntN instance Ord Float---- TODO Should there be more instances?-+instance Ord Double

@@ -43,12 +43,14 @@ import Feldspar.Core.Constructs import Feldspar.Core.Frontend.Literal () -newtype P a = P { unP :: Mon FeldSymbols Type Par a }-  deriving (Functor, Monad)+import Control.Applicative +newtype P a = P { unP :: Mon FeldDomain Par a }+  deriving (Functor, Applicative, Monad)+ instance Syntax a => Syntactic (P a)   where-    type Domain (P a)   = FeldDomainAll+    type Domain (P a)   = FeldDomain     type Internal (P a) = Par (Internal a)     desugar = desugar . unP     sugar   = P . sugar@@ -57,10 +59,8 @@  instance Syntax a => Syntactic (IVar a)   where-    type Domain (IVar a)   = FeldDomainAll+    type Domain (IVar a)   = FeldDomain     type Internal (IVar a) = IV (Internal a)     desugar = desugar . unIVar     sugar   = IVar . sugar--instance Syntax a => Syntax (IVar a) 

@@ -0,0 +1,17 @@+module Feldspar.Core.Frontend.RealFloat where++import qualified Prelude+import Prelude (Float,Double)++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.RealFloat++-- Make new class, with "Data" in all the types++class (Type a, Prelude.RealFloat a) => RealFloat a where+  atan2 :: Data a -> Data a -> Data a+  atan2 = sugarSymF Atan2++instance RealFloat Float+instance RealFloat Double

@@ -34,8 +34,6 @@  module Feldspar.Core.Frontend.Save where -import Language.Syntactic- import Feldspar.Core.Constructs import Feldspar.Core.Constructs.Save @@ -46,12 +44,6 @@ -- Exception: Currently constant folding does not respect 'save'. save :: Syntax a => a -> a save = sugarSymF Save-  -- TODO Make constant folding respect `save`. This could be done by adding a-  --      field to `Info` saying whether or not each node contains `save`.--  -- TODO It would be nice if `save` could take a `String` argument that would-  --      be used in the back-end to identify the saved value (e.g. used as the-  --      variable name).  -- | Equivalent to 'save'. When applied to a lazy data structure, 'force' (and -- 'save') has the effect of forcing evaluation of the whole structure.

@@ -1,41 +0,0 @@------ 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 Feldspar.Core.Frontend.Select where--import qualified Prelude as P--import Feldspar.Core.Frontend.Eq-import Feldspar.Core.Frontend.Condition-import Feldspar.Core.Constructs---- | Select between the cases based on the value of the scrutinee.--- TODO: This implementation should be replaces by a proper construct-select :: (Eq a, Syntax b) => Data a -> [(Data a, b)] -> b -> b-select scrutinee cases fallback = P.foldr (\(c,a) b -> c == scrutinee ? (a,b)) fallback cases-

@@ -33,10 +33,6 @@ module Feldspar.Core.Frontend.SourceInfo where  -import QuickAnnotate--import Language.Syntactic- import Feldspar.Core.Types import Feldspar.Core.Constructs.SourceInfo import Feldspar.Core.Constructs@@ -44,8 +40,3 @@ -- | Annotate an expression with information about its source code sourceData :: Type a => SourceInfo1 a -> Data a -> Data a sourceData info = sugarSymF (Decor info Id)--instance Type a => Annotatable (Data a)-  where-    annotate = sourceData . SourceInfo1-

@@ -0,0 +1,56 @@+--+-- 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.+--++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}++module Feldspar.Core.Frontend.Switch where++import Prelude (($),foldr)++import Language.Syntactic (resugar,Syntactic(..))++import Feldspar.Core.Frontend.Eq (Eq((==)))+import Feldspar.Core.Frontend.Condition ((?))+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Switch++-- | Select between the cases based on the value of the scrutinee.+select :: (Eq a, Syntax b) => Data a -> [(Data a, b)] -> b -> b+select s cs def = foldr (\(c,a) b -> c == s ? a $ b) def cs++{-# DEPRECATED select "select will generate a tree of if-statements. Use switch instead" #-}++-- | Select between the cases based on the value of the scrutinee.+-- If no match is found return the first argument+switch :: (Eq (Internal a), Syntax a, Syntax b)+       => b -> [(a, b)] -> a -> b+switch def [] _ = def+switch def cs s = let s' = resugar s+                  in sugarSymF Switch (foldr (\(c,a) b -> resugar c == s' ? a $ b) def cs)+

@@ -30,8 +30,6 @@  module Feldspar.Core.Frontend.Trace where -import Language.Syntactic- import Feldspar.Core.Types import Feldspar.Core.Constructs import Feldspar.Core.Constructs.Trace

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -32,121 +33,13 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- module Feldspar.Core.Frontend.Tuple where -import QuickAnnotate--import Language.Syntactic import Language.Syntactic.Frontend.TupleConstrained  import Feldspar.Core.Types import Feldspar.Core.Constructs import Feldspar.Core.Constructs.Tuple () -instance (Syntax a, Syntax b)                                                   => Syntax (a,b)-instance (Syntax a, Syntax b, Syntax c)                                         => Syntax (a,b,c)-instance (Syntax a, Syntax b, Syntax c, Syntax d)                               => Syntax (a,b,c,d)-instance (Syntax a, Syntax b, Syntax c, Syntax d, Syntax e)                     => Syntax (a,b,c,d,e)-instance (Syntax a, Syntax b, Syntax c, Syntax d, Syntax e, Syntax f)           => Syntax (a,b,c,d,e,f)-instance (Syntax a, Syntax b, Syntax c, Syntax d, Syntax e, Syntax f, Syntax g) => Syntax (a,b,c,d,e,f,g)----instance-    ( Annotatable a-    , Annotatable b-    ) =>-      Annotatable (a,b)-  where-    annotate info (a,b) =-        ( annotate (info ++ " (tuple element 1)") a-        , annotate (info ++ " (tuple element 2)") b-        )--instance-    ( Annotatable a-    , Annotatable b-    , Annotatable c-    ) =>-      Annotatable (a,b,c)-  where-    annotate info (a,b,c) =-        ( annotate (info ++ " (tuple element 1)") a-        , annotate (info ++ " (tuple element 2)") b-        , annotate (info ++ " (tuple element 3)") c-        )--instance-    ( Annotatable a-    , Annotatable b-    , Annotatable c-    , Annotatable d-    ) =>-      Annotatable (a,b,c,d)-  where-    annotate info (a,b,c,d) =-        ( annotate (info ++ " (tuple element 1)") a-        , annotate (info ++ " (tuple element 2)") b-        , annotate (info ++ " (tuple element 3)") c-        , annotate (info ++ " (tuple element 4)") d-        )--instance-    ( Annotatable a-    , Annotatable b-    , Annotatable c-    , Annotatable d-    , Annotatable e-    ) =>-      Annotatable (a,b,c,d,e)-  where-    annotate info (a,b,c,d,e) =-        ( annotate (info ++ " (tuple element 1)") a-        , annotate (info ++ " (tuple element 2)") b-        , annotate (info ++ " (tuple element 3)") c-        , annotate (info ++ " (tuple element 4)") d-        , annotate (info ++ " (tuple element 5)") e-        )--instance-    ( Annotatable a-    , Annotatable b-    , Annotatable c-    , Annotatable d-    , Annotatable e-    , Annotatable f-    ) =>-      Annotatable (a,b,c,d,e,f)-  where-    annotate info (a,b,c,d,e,f) =-        ( annotate (info ++ " (tuple element 1)") a-        , annotate (info ++ " (tuple element 2)") b-        , annotate (info ++ " (tuple element 3)") c-        , annotate (info ++ " (tuple element 4)") d-        , annotate (info ++ " (tuple element 5)") e-        , annotate (info ++ " (tuple element 6)") f-        )--instance-    ( Annotatable a-    , Annotatable b-    , Annotatable c-    , Annotatable d-    , Annotatable e-    , Annotatable f-    , Annotatable g-    ) =>-      Annotatable (a,b,c,d,e,f,g)-  where-    annotate info (a,b,c,d,e,f,g) =-        ( annotate (info ++ " (tuple element 1)") a-        , annotate (info ++ " (tuple element 2)") b-        , annotate (info ++ " (tuple element 3)") c-        , annotate (info ++ " (tuple element 4)") d-        , annotate (info ++ " (tuple element 5)") e-        , annotate (info ++ " (tuple element 6)") f-        , annotate (info ++ " (tuple element 7)") g-        )+instance TupleSat FeldDomain Type 

@@ -3,11 +3,12 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ConstraintKinds #-}  -- -- Copyright (c) 2009-2011, ERICSSON AB@@ -37,8 +38,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-}- -- | Defines different interpretations of Feldspar programs  module Feldspar.Core.Interpretation@@ -57,11 +56,16 @@     , infoRange     , LatticeSize1 (..)     , viewLiteral+    , literal     , literalDecor     , constFold     , SomeInfo (..)     , SomeType (..)     , Env (..)+    , FeldOpts (..)+    , Target (..)+    , inTarget+    , defaultFeldOpts     , localVar     , localSource     , Opt@@ -75,6 +79,9 @@     , optimizeFeatDefault     , prjF     , c'+    , Monotonic (..)+    , viewMonotonicInc+    , viewMonotonicDec     ) where  @@ -87,7 +94,6 @@ import Language.Syntactic.Constructs.Decoration import Language.Syntactic.Constructs.Literal import Language.Syntactic.Constructs.Binding-import Language.Syntactic.Constructs.Binding.HigherOrder  import Feldspar.Lattice import Feldspar.Core.Types@@ -116,23 +122,35 @@     sharable :: dom a -> Bool     sharable _ = True +    hoistOver :: dom a -> Bool+    hoistOver _ = True+ instance (Sharable sub1, Sharable sub2) => Sharable (sub1 :+: sub2)   where     sharable (InjL a) = sharable a     sharable (InjR a) = sharable a +    hoistOver (InjL a) = hoistOver a+    hoistOver (InjR a) = hoistOver a+ instance Sharable sym => Sharable (sym :|| pred)   where     sharable (C' s) = sharable s +    hoistOver (C' s) = hoistOver s+ instance Sharable sym => Sharable (SubConstr2 c sym p1 p2)   where     sharable (SubConstr2 s) = sharable s +    hoistOver (SubConstr2 s) = hoistOver s+ instance Sharable dom => Sharable (Decor Info dom)   where     sharable = sharable . decorExpr +    hoistOver = hoistOver . decorExpr+ instance Sharable Empty  @@ -173,7 +191,7 @@ data Info a   where     Info-      :: Show (Size a)+      :: (Show (Size a), Lattice (Size a))       => { infoType   :: TypeRep a          , infoSize   :: Size a          , infoVars   :: VarInfo@@ -181,23 +199,18 @@          }       -> Info a -instance Render Info+instance Show (Info a)   where-    render i@(Info {}) = show (infoType i) ++ szStr ++ srcStr+    show i@(Info {}) = show (infoType i) ++ szStr ++ srcStr       where         szStr = case show (infoSize i) of-          "()" -> ""  -- TODO AnySize+          "AnySize" -> ""           str  -> " | " ++ str          srcStr = case infoSource i of           ""  -> ""           src -> " | " ++ src -instance Eq (Size a) => Eq (Info a)-  where-    ia == ib = infoSize ia == infoSize ib-      -- TODO- mkInfo :: Type a => Size a -> Info a mkInfo sz = Info typeRep sz Map.empty "" @@ -229,6 +242,23 @@     , sourceEnv :: SourceInfo     } +-- | Possible compilation targets.+data Target = RegionInf | SICS+  deriving Eq++-- | A record with options for explicit passing in rewrite rules.+data FeldOpts = FeldOpts+    { targets    :: [Target]+    }++-- | Default options.+defaultFeldOpts :: FeldOpts+defaultFeldOpts = FeldOpts { targets = [] }++-- | Decide whether a Target is enabled in FeldOpts.+inTarget :: Target -> FeldOpts -> Bool+inTarget t opts = t `elem` (targets opts)+ -- | Initial environment initEnv :: Env initEnv = Env [] ""@@ -250,6 +280,11 @@ prjF :: Project (sub :|| Type) sup => sup sig -> Maybe ((sub :|| Type) sig) prjF = prj +-- | Construct a 'Literal'+literal :: (Type a, (Literal :|| Type) :<: dom) =>+    a -> ASTF (dom :|| Typeable) a+literal a = Sym $ C' $ inj $ c' $ Literal a+ -- | Construct a 'Literal' decorated with 'Info' literalDecorSrc :: (Type a, (Literal :|| Type) :<: dom) =>     SourceInfo -> a -> ASTF (Decor Info (dom :|| Typeable)) a@@ -270,8 +305,10 @@  -- | Replaces an expression with a literal if the type permits, otherwise -- returns the expression unchanged.-constFold :: (Typed dom, (Literal :|| Type) :<: dom) =>-    SourceInfo -> ASTF (Decor Info (dom :|| Typeable)) a -> a -> ASTF (Decor Info (dom :|| Typeable)) a+constFold :: (Typed dom, (Literal :|| Type) :<: dom)+    => SourceInfo -> ASTF (Decor Info (dom :|| Typeable)) a+    -> a+    -> ASTF (Decor Info (dom :|| Typeable)) a constFold src expr a     | Just Dict <- typeDict expr     = literalDecorSrc src a@@ -293,7 +330,7 @@         :: ( Typeable (DenResult a)            , OptimizeSuper dom            )-        => feature a+        => FeldOpts -> feature a         -> Args (AST (dom :|| Typeable)) a         -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))     optimizeFeat = optimizeFeatDefault@@ -305,7 +342,7 @@     -- 'constructFeat' which has more accurate propagation of 'Info'.     constructFeatOpt         :: ( Typeable (DenResult a))-        => feature a+        => FeldOpts -> feature a         -> Args (AST (Decor Info (dom :|| Typeable))) a         -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))     constructFeatOpt = constructFeatUnOpt@@ -314,11 +351,10 @@     -- optimized arguments     constructFeatUnOpt         :: ( Typeable (DenResult a))-        => feature a+        => FeldOpts -> feature a         -> Args (AST (Decor Info (dom :|| Typeable))) a         -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a)) - instance Optimize Empty dom   where     constructFeatUnOpt = error "Not implemented: constructFeatUnOpt for Empty"@@ -350,6 +386,7 @@     , EvalBind dom     , (Literal :|| Type) :<: dom     , Typed dom+    , Render dom -- For debug     , Constrained dom     , Optimize dom dom     ) =>@@ -361,29 +398,22 @@     , EvalBind dom     , (Literal  :|| Type) :<: dom     , Typed dom+    , Render dom     , Constrained dom     , Optimize dom dom     ) =>       OptimizeSuper dom ----- TODO Optimization should throw an error when the size of a node is---      over-constrained. It can only happen if there's a bug in the general---      size inference, or if the user has stated invalid size constraints. In---      both cases it may lead to incorrect optimizations, so throwing an error---      seems preferable.- -- | Optimized construction of an expression from a symbol and its optimized -- arguments constructFeat :: ( Typeable (DenResult a)                  , Optimize feature dom)-    => feature a+    => FeldOpts -> feature a     -> Args (AST (Decor Info (dom :|| Typeable))) a     -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))-constructFeat a args = do-    aUnOpt <- constructFeatUnOpt a args-    aOpt   <- constructFeatOpt a args+constructFeat opts a args = do+    aUnOpt <- constructFeatUnOpt opts a args+    aOpt   <- constructFeatOpt opts a args     return $ updateDecor         (\info -> info {infoSize = infoSize (getInfo aUnOpt)})         aOpt@@ -392,24 +422,20 @@   -- `constructFeatOpt` may produce less accurate size information than   -- `constructFeatUnOpt`. -  -- TODO It might be better to use `sizeProp` instead of `constructFeatUnOpt`-  --      (but this changes class dependencies a bit). Is there any other use of-  --      `constructFeatUnOpt`?- instance     ( Optimize sub1 dom     , Optimize sub2 dom     ) =>       Optimize (sub1 :+: sub2) dom   where-    optimizeFeat (InjL a) = optimizeFeat a-    optimizeFeat (InjR a) = optimizeFeat a+    optimizeFeat opts (InjL a) = optimizeFeat opts a+    optimizeFeat opts (InjR a) = optimizeFeat opts a -    constructFeatOpt (InjL a) = constructFeatOpt a-    constructFeatOpt (InjR a) = constructFeatOpt a+    constructFeatOpt opts (InjL a) = constructFeatOpt opts a+    constructFeatOpt opts (InjR a) = constructFeatOpt opts a -    constructFeatUnOpt (InjL a) = constructFeatUnOpt a-    constructFeatUnOpt (InjR a) = constructFeatUnOpt a+    constructFeatUnOpt opts (InjL a) = constructFeatUnOpt opts a+    constructFeatUnOpt opts (InjR a) = constructFeatUnOpt opts a  -- | Optimization of an expression --@@ -417,28 +443,25 @@ -- folding on all closed expressions, provided that the type permits making a -- literal. optimizeM :: (OptimizeSuper dom)-          => ASTF (dom :|| Typeable) a -> Opt (ASTF (Decor Info (dom :|| Typeable)) a)-optimizeM a+          => FeldOpts -> ASTF (dom :|| Typeable) a -> Opt (ASTF (Decor Info (dom :|| Typeable)) a)+optimizeM opts a     | Dict <- exprDict a     = do-        aOpt <- matchTrans (\(C' x) -> optimizeFeat x) a+        aOpt <- matchTrans (\(C' x) -> optimizeFeat opts x) a         let vars  = infoVars $ getInfo aOpt             value = evalBind aOpt             src   = infoSource $ getInfo aOpt-    --    return aOpt         if Map.null vars            then return $ constFold src aOpt value            else return aOpt-      -- TODO singleton range --> literal-      --      literal         --> singleton range  -- | Optimization of an expression. This function runs 'optimizeM' and extracts -- the result. optimize :: ( Typeable a             , OptimizeSuper dom             )-         => ASTF (dom :|| Typeable) a -> ASTF (Decor Info (dom :|| Typeable)) a-optimize = flip runReader initEnv . optimizeM+         => FeldOpts -> ASTF (dom :|| Typeable) a -> ASTF (Decor Info (dom :|| Typeable)) a+optimize opts = flip runReader initEnv . optimizeM opts  -- | Convenient default implementation of 'constructFeatUnOpt'. Uses 'sizeProp' -- to propagate size.@@ -447,12 +470,13 @@        , SizeProp feature        , Typeable (DenResult a)        , Show (Size (DenResult a))+       , Lattice (Size (DenResult a))        )-    => TypeRep (DenResult a)+    => FeldOpts -> TypeRep (DenResult a)     -> feature a     -> Args (AST (Decor Info (dom :|| Typeable))) a     -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))-constructFeatUnOptDefaultTyp typ feat args+constructFeatUnOptDefaultTyp _ typ feat args     = do         src <- asks sourceEnv         let sz   = sizeProp feat $ mapArgs (WrapFull . getInfo) args@@ -465,10 +489,10 @@        , SizeProp feature        , Type (DenResult a)        )-    => feature a+    => FeldOpts -> feature a     -> Args (AST (Decor Info (dom :|| Typeable))) a     -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))-constructFeatUnOptDefault feat args+constructFeatUnOptDefault _ feat args     = do         src <- asks sourceEnv         let sz   = sizeProp feat $ mapArgs (WrapFull . getInfo) args@@ -481,9 +505,63 @@        , Typeable (DenResult a)        , OptimizeSuper dom        )-    => feature a+    => FeldOpts -> feature a     -> Args (AST (dom :|| Typeable)) a     -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))-optimizeFeatDefault feat args-    = constructFeat feat =<< mapArgsM optimizeM args+optimizeFeatDefault opts feat args+    = constructFeat opts feat =<< mapArgsM (optimizeM opts) args ++-- | The 'Monotonic' class represents (weak) monotonicity+class Monotonic feature where+    -- | Return the arguments for which the symbol is monotonic increasing+    --+    -- prop> forAll a. [a] = monotonicInc (f a) ==> f a >= a+    --+    monotonicInc :: feature a+                 -> Args (AST (Decor Info (dom :|| Typeable))) a+                 -> [ASTF (Decor Info (dom :|| Typeable)) (DenResult a)]+    monotonicInc _ _ = []++    -- | Return the arguments for which the symbol is monotonic decreasing+    --+    -- prop> forAll a. [a] = monotonicDec (f a) ==> f a <= a+    --+    monotonicDec :: feature a+                 -> Args (AST (Decor Info (dom :|| Typeable))) a+                 -> [ASTF (Decor Info (dom :|| Typeable)) (DenResult a)]+    monotonicDec _ _ = []++instance (Monotonic sub1, Monotonic sub2) => Monotonic (sub1 :+: sub2) where+    monotonicInc (InjL a) = monotonicInc a+    monotonicInc (InjR a) = monotonicInc a+    monotonicDec (InjL a) = monotonicDec a+    monotonicDec (InjR a) = monotonicDec a++instance (Monotonic sym) => Monotonic (sym :|| pred) where+    monotonicInc (C' s) = monotonicInc s+    monotonicDec (C' s) = monotonicDec s++instance (Monotonic sym) => Monotonic (SubConstr2 c sym p1 p2) where+    monotonicInc (SubConstr2 s) = monotonicInc s+    monotonicDec (SubConstr2 s) = monotonicDec s++instance (Monotonic dom) => Monotonic (Decor Info dom) where+    monotonicInc = monotonicInc . decorExpr+    monotonicDec = monotonicDec . decorExpr++instance Monotonic Empty++-- | Extract sub-expressions for which the expression is (weak) monotonic+-- increasing+viewMonotonicInc :: (Monotonic dom)+                 => ASTF (Decor Info (dom :|| Typeable)) a+                 -> [ASTF (Decor Info (dom :|| Typeable)) a]+viewMonotonicInc = simpleMatch monotonicInc++-- | Extract sub-expressions for which the expression is (weak) monotonic+-- decreasing+viewMonotonicDec :: (Monotonic dom)+                 => ASTF (Decor Info (dom :|| Typeable)) a+                 -> [ASTF (Decor Info (dom :|| Typeable)) a]+viewMonotonicDec = simpleMatch monotonicDec

@@ -15,7 +15,6 @@ where  import Language.Syntactic-import Language.Syntactic.Constructs.Binding.HigherOrder import Language.Syntactic.Constructs.Decoration  import Feldspar.Core.Types (Type)@@ -37,7 +36,7 @@   where typeDictSym (C s) = typeDictSym s  instance Typed (SubConstr2 c sub Type Top)-  where typeDictSym (SubConstr2 s) = Nothing+  where typeDictSym (SubConstr2 _) = Nothing  instance (Typed sub, Typed sup) => Typed (sub :+: sup)   where typeDictSym (InjL s) = typeDictSym s

@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -50,22 +52,27 @@ import Data.Int import Data.IORef import Data.List-import Data.Typeable (Typeable, Typeable1)+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+import Data.Typeable (Typeable)+#else+import Data.Typeable (Typeable,Typeable1)+#endif import Data.Word+import Data.Default import Test.QuickCheck+import System.Random (Random(..)) import qualified Control.Monad.Par as MonadPar  import Data.Patch- import Data.Proxy -import Language.Syntactic+import Control.DeepSeq (NFData(..))+import Foreign.Storable (Storable)  import Feldspar.Lattice import Feldspar.Range  - -------------------------------------------------------------------------------- -- * Heterogenous lists --------------------------------------------------------------------------------@@ -78,8 +85,8 @@  instance (Lattice a, Lattice b) => Lattice (a :> b)   where-    empty     = empty :> empty-    universal = universal :> universal+    bot = bot :> bot+    top = top :> top     (a1:>a2) \/ (b1:>b2) = (a1 \/ b1) :> (a2 \/ b2)     (a1:>a2) /\ (b1:>b2) = (a1 /\ b1) :> (a2 /\ b2) @@ -93,14 +100,26 @@ newtype WordN = WordN Word32   deriving     ( Eq, Ord, Num, Enum, Ix, Real, Integral, Bits, Bounded, Typeable-    , Arbitrary )+    , Arbitrary, Random, Storable, NFData, Default+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+    , FiniteBits+#endif+    ) +type instance UnsignedRep WordN = Word32+ -- | Target-dependent signed integers newtype IntN = IntN Int32   deriving     ( Eq, Ord, Num, Enum, Ix, Real, Integral, Bits, Bounded, Typeable-    , Arbitrary )+    , Arbitrary, Random, Storable, NFData, Default+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+    , FiniteBits+#endif+    ) +type instance UnsignedRep IntN = Word32+ instance Show WordN   where     show (WordN a) = show a@@ -277,21 +296,24 @@ -- | Monad for parallel constructs type Par = MonadPar.Par +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Par+#else deriving instance Typeable1 Par+#endif  -- | Immutable references type IV = MonadPar.IVar +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+#else deriving instance Typeable1 IV+#endif  instance Show (IV a)   where     show _ = "IVar" -instance Eq (IV a)-  where-    _ == _ = False- instance MonadType Par   where     voidTypeRep = ParType UnitType@@ -302,7 +324,12 @@  newtype FVal a = FVal {unFVal :: a} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+deriving instance Typeable IV+deriving instance Typeable FVal+#else deriving instance Typeable1 FVal+#endif  instance Show (FVal a)   where@@ -327,6 +354,7 @@                      ) =>                        Signedness s -> BitWidth n -> TypeRep (GenericInt s n)     FloatType     :: TypeRep Float+    DoubleType    :: TypeRep Double     ComplexType   :: RealFloat a => TypeRep a -> TypeRep (Complex a)     ArrayType     :: TypeRep a -> TypeRep [a]     TargetArrType :: BitWidth n -> TypeRep a -> TypeRep (TargetArr n a)@@ -353,6 +381,7 @@     show BoolType            = "Bool"     show (IntType s n)       = signedness s ++ bitWidth n     show FloatType           = "Float"+    show DoubleType          = "Double"     show (ComplexType t)     = "(Complex " ++ show t ++ ")"     show (ArrayType t)       = "[" ++ show t ++ "]"     show (TargetArrType _ t) = "[" ++ show t ++ "]"@@ -386,6 +415,7 @@ defaultSize BoolType = universal defaultSize (IntType _ _) = universal defaultSize FloatType = universal+defaultSize DoubleType = universal defaultSize (ComplexType _) = universal defaultSize (ArrayType t) = universal :> defaultSize t --defaultSize (TargetArrType n t) = universal :> defaultSize t -- TODO@@ -422,7 +452,7 @@                                               , defaultSize tf                                               , defaultSize tg                                               )-defaultSize (FunType _ tb) = defaultSize tb+defaultSize (FunType ta tb) = (defaultSize ta, defaultSize tb) defaultSize (MutType ta) = defaultSize ta defaultSize (RefType ta) = defaultSize ta defaultSize (MArrType ta) = universal :> defaultSize ta@@ -454,6 +484,7 @@     TypeEq <- widthEq n1 n2     return TypeEq typeEq FloatType FloatType = Just TypeEq+typeEq DoubleType DoubleType = Just TypeEq typeEq (ComplexType t1) (ComplexType t2) = do     TypeEq <- typeEq t1 t2     return TypeEq@@ -545,6 +576,7 @@ type instance TargetType n WordN           = GenericInt U n type instance TargetType n IntN            = GenericInt S n type instance TargetType n Float           = Float+type instance TargetType n Double          = Double type instance TargetType n (Complex a)     = Complex (TargetType n a) type instance TargetType n [a]             = TargetArr n (TargetType n a) type instance TargetType n (a,b)           = (TargetType n a, TargetType n b)@@ -565,7 +597,6 @@     typeRep  :: TypeRep a     sizeOf   :: a -> Size a     toTarget :: BitWidth n -> a -> TargetType n a-  -- TODO Typeable needed?  instance Type ()      where typeRep = UnitType;          sizeOf _ = AnySize;      toTarget _ = id instance Type Bool    where typeRep = BoolType;          sizeOf _ = AnySize;      toTarget _ = id@@ -580,6 +611,7 @@ instance Type WordN   where typeRep = IntType U NNative; sizeOf = singletonRange; toTarget = fromWordN instance Type IntN    where typeRep = IntType S NNative; sizeOf = singletonRange; toTarget = fromIntN instance Type Float   where typeRep = FloatType;         sizeOf _ = AnySize;      toTarget _ = id+instance Type Double  where typeRep = DoubleType;        sizeOf _ = AnySize;      toTarget _ = id  instance (Type a, RealFloat a) => Type (Complex a)   where@@ -770,10 +802,10 @@  instance Lattice AnySize   where-    empty     = AnySize-    universal = AnySize-    (\/)      = anySizeFun2-    (/\)      = anySizeFun2+    bot  = AnySize+    top  = AnySize+    (\/) = anySizeFun2+    (/\) = anySizeFun2  type family Size a @@ -790,6 +822,7 @@ type instance Size WordN           = Range WordN type instance Size IntN            = Range IntN type instance Size Float           = AnySize+type instance Size Double          = AnySize type instance Size (Complex a)     = AnySize type instance Size [a]             = Range Length :> Size a type instance Size (TargetArr n a) = Range (GenericInt U n) :> Size a@@ -799,7 +832,7 @@ type instance Size (a,b,c,d,e)     = (Size a, Size b, Size c, Size d, Size e) type instance Size (a,b,c,d,e,f)   = (Size a, Size b, Size c, Size d, Size e, Size f) type instance Size (a,b,c,d,e,f,g) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g)-type instance Size (a -> b)        = Size b+type instance Size (a -> b)        = (Size a, Size b) type instance Size (Mut a)         = Size a type instance Size (IORef a)       = Size a type instance Size (MArr a)        = Range Length :> Size a@@ -807,28 +840,7 @@ type instance Size (IV a)          = Size a type instance Size (FVal a)        = Size a --- Note: The instance------     Size (a -> b) = Size b------ might seem strange. In general, the size of a function result depends on the--- size of the argument, so it might be more natural to have------     Size (a -> b) = Size a -> Size b------ However, this doesn't really work with the `optimize` function, since--- optimization is done simultaneously with size inference, and the two--- influence each other. The result of optimization is an optimized expression--- decorated with a size. If the expression is of function type, the size of the--- argument has to be provided before optimizing the function body. Yet, the--- result will be decorated by a value of type `Size a -> Size b`, which--- suggests that we do not yet know the size of the argument.------ So instead, we represent the size of a function as the size of its result,--- which means that the size of a function is only valid in a given context. -- -- | A generalization of 'Range' that serves two purposes: (1) Adding an extra -- 'Universal' constructor to support unbounded types ('Range' can only -- represent bounded ranges), and (2) pack a 'BoundedInt' constraint with the@@ -838,6 +850,8 @@   where     RangeSet  :: BoundedInt a => Range a -> RangeSet a     Universal :: RangeSet a++deriving instance (Show a) => Show (RangeSet a)  -- | Cast a 'Size' to a 'RangeSet' sizeToRange :: forall a . Type a => Size a -> RangeSet a

@@ -1,9 +1,11 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  --@@ -34,7 +36,6 @@ -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -{-# LANGUAGE UndecidableInstances #-} module Feldspar.FixedPoint     ( Fix(..), Fixable(..)     , freezeFix, freezeFix', unfreezeFix, unfreezeFix'@@ -43,11 +44,13 @@ where  import qualified Prelude+ import Feldspar hiding (sugar,desugar) import Feldspar.Vector  import Language.Syntactic hiding (fold) + -- | Abstract real number type with exponent and mantissa data Fix a =     Fix@@ -59,49 +62,48 @@ instance     ( Integral a     , Bits a-    , Prelude.Real a     ) => Num (Fix a)   where     fromInteger n = Fix 0 (Prelude.fromInteger n)-    (+) = fixAddition-    (*) = fixMultiplication-    negate = fixNegate-    abs = fixAbsolute-    signum = fixSignum+    (+)           = fixAddition+    (*)           = fixMultiplication+    negate        = fixNegate+    abs           = fixAbsolute+    signum        = fixSignum  instance     ( Integral a     , Bits a-    , Prelude.Real a+    , Prelude.Floating a     ) => Fractional (Fix a)   where     (/) = fixDiv'     recip = fixRecip'     fromRational = fixfromRational -fixAddition :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a -> Fix a+fixAddition :: (Integral a, Bits a) => Fix a -> Fix a -> Fix a fixAddition f1@(Fix e1 _) f2@(Fix e2 _) = Fix e m    where      e = max e1 e2      m = mantissa (fix e f1) + mantissa (fix e f2) -fixMultiplication :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a -> Fix a+fixMultiplication :: (Integral a) => Fix a -> Fix a -> Fix a fixMultiplication (Fix e1 m1) (Fix e2 m2) = Fix e m    where      e =  e1 + e2      m =  m1 * m2 -fixNegate :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a+fixNegate :: (Integral a) => Fix a -> Fix a fixNegate (Fix e1 m1)  = Fix e1 m    where      m = negate m1 -fixAbsolute :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a+fixAbsolute :: (Integral a) => Fix a -> Fix a fixAbsolute (Fix e1 m1)  = Fix e1 m    where      m = abs m1 -fixSignum :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a+fixSignum :: (Integral a) => Fix a -> Fix a fixSignum (Fix _ m1)  = Fix 0 m    where      m = signum m1@@ -113,21 +115,21 @@      e = e1 - e2      m = div m1 m2 -fixRecip' :: forall a . (Integral a, Bits a, Prelude.Real a)+fixRecip' :: forall a . (Integral a, Bits a, Prelude.Floating a)              => Fix a -> Fix a fixRecip' (Fix e m) = Fix (e + value (wordLength (T :: T a) - 1)) (div sh m)    where      sh  :: Data a      sh  = (1::Data a) .<<. value (fromInteger $ toInteger $ wordLength (T :: T a) - 1) -fixfromRational :: forall a . (Integral a) =>+fixfromRational :: forall a . (Integral a, Bits a, Prelude.Floating a) =>                    Prelude.Rational -> Fix a fixfromRational inp = Fix e m    where       inpAsFloat :: Float       inpAsFloat = fromRational inp       intPart :: Float-      intPart = fromRational $ toRational $ Prelude.floor inpAsFloat+      intPart = Prelude.fromIntegral (Prelude.floor inpAsFloat :: Integer)       intPartWidth :: IntN       intPartWidth =  Prelude.ceiling $ Prelude.logBase 2 intPart       fracPartWith :: IntN@@ -136,13 +138,11 @@       e = negate $ value fracPartWith  instance (Type a) => Syntactic (Fix a) where-  type Domain (Fix a)   = FeldDomainAll+  type Domain (Fix a)   = FeldDomain   type Internal (Fix a) = (IntN, a)   desugar = desugar . freezeFix   sugar   = unfreezeFix . sugar -instance (Type a) => Syntax (Fix a)- -- | Converts an abstract real number to a pair of exponent and mantissa freezeFix :: (Type a) => Fix a -> (Data IntN,Data a) freezeFix (Fix e m) = (e,m)@@ -179,8 +179,8 @@     r :: Range a     r =  Range 0 sb -}-wordLength :: forall a . (Integral a, Prelude.Real a) => T a -> IntN-wordLength _ = Prelude.ceiling ( Prelude.logBase 2 $ fromRational $ toRational (maxBound :: a)) + 1+wordLength :: forall a. (Bits a) => T a -> IntN+wordLength _ = Prelude.fromIntegral $ finiteBitSize (undefined :: a)  -- | Operations to get and set exponent class (Splittable t) => Fixable t where@@ -188,12 +188,12 @@     getExp :: t -> Data IntN  instance (Bits a) => Fixable (Fix a) where-    fix e' (Fix e m) = Fix e' $ e' > e ? (m .>>. i2n (e' - e), m .<<. i2n (e - e'))+    fix e' (Fix e m) = Fix e' $ e' > e ? (m .>>. i2n (e' - e)) $ (m .<<. i2n (e - e'))     getExp = Feldspar.FixedPoint.exponent  instance Fixable (Data Float) where     fix = const id-    getExp = const $ fromInteger $ toInteger $ Feldspar.exponent (0.0 :: Float)+    getExp = const $ fromInteger $ toInteger $ Prelude.exponent (0.0 :: Float)  data T a = T @@ -233,7 +233,7 @@ -- | A version of branching for fixed point algorithms infix 1 ?! (?!) :: forall a . (Syntax a, Splittable a) => Data Bool -> (a,a) -> a-cond ?! (x,y) = retrieve (comm, cond ? (x',y'))+cond ?! (x,y) = retrieve (comm, cond ? x' $ y')   where     comm = common x y     x' = snd $ store $ patch comm x

@@ -1,11 +1,11 @@ -- -- 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, +--+--     * 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@@ -13,10 +13,10 @@ --     * 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 +-- 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@@ -39,75 +39,81 @@ -- | Lattice types class Eq a => Lattice a   where-    empty     :: a-    universal :: a-    -- | Union+    bot       :: a+    top       :: a+    -- | Join     (\/)      :: a -> a -> a-    -- | Intersection+    -- | Meet     (/\)      :: a -> a -> a +empty :: Lattice a => a+empty = bot++universal :: Lattice a => a+universal = top+ instance Lattice ()   where-    empty     = ()-    universal = ()+    bot       = ()+    top       = ()     () \/ ()  = ()     () /\ ()  = ()  -- | Lattice product instance (Lattice a, Lattice b) => Lattice (a,b)   where-    empty     = (empty,empty)-    universal = (universal,universal)+    bot = (bot,bot)+    top = (top,top)     (a1,a2) \/ (b1,b2) = (a1 \/ b1, a2 \/ b2)     (a1,a2) /\ (b1,b2) = (a1 /\ b1, a2 /\ b2)  -- | Three-way product instance (Lattice a, Lattice b, Lattice c) => Lattice (a,b,c)   where-    empty     = (empty,empty,empty)-    universal = (universal,universal,universal)+    bot = (bot,bot,bot)+    top = (top,top,top)     (a1,a2,a3) \/ (b1,b2,b3) = (a1 \/ b1, a2 \/ b2, a3 \/ b3)     (a1,a2,a3) /\ (b1,b2,b3) = (a1 /\ b1, a2 /\ b2, a3 /\ b3)  -- | Four-way product instance (Lattice a, Lattice b, Lattice c, Lattice d) => Lattice (a,b,c,d)   where-    empty     = (empty,empty,empty,empty)-    universal = (universal,universal,universal,universal)+    bot = (bot,bot,bot,bot)+    top = (top,top,top,top)     (a1,a2,a3,a4) \/ (b1,b2,b3,b4) = (a1 \/ b1, a2 \/ b2, a3 \/ b3, a4 \/ b4)     (a1,a2,a3,a4) /\ (b1,b2,b3,b4) = (a1 /\ b1, a2 /\ b2, a3 /\ b3, a4 /\ b4)  -- | Five-way product instance (Lattice a, Lattice b, Lattice c, Lattice d, Lattice e) => Lattice (a,b,c,d,e)   where-    empty     = (empty,empty,empty,empty,empty)-    universal = (universal,universal,universal,universal,universal)+    bot = (bot,bot,bot,bot,bot)+    top = (top,top,top,top,top)     (a1,a2,a3,a4,a5) \/ (b1,b2,b3,b4,b5) = (a1 \/ b1, a2 \/ b2, a3 \/ b3, a4 \/ b4, a5 \/ b5)     (a1,a2,a3,a4,a5) /\ (b1,b2,b3,b4,b5) = (a1 /\ b1, a2 /\ b2, a3 /\ b3, a4 /\ b4, a5 /\ b5)  -- | Six-way product instance (Lattice a, Lattice b, Lattice c, Lattice d, Lattice e, Lattice f) => Lattice (a,b,c,d,e,f)   where-    empty     = (empty,empty,empty,empty,empty,empty)-    universal = (universal,universal,universal,universal,universal,universal)+    bot = (bot,bot,bot,bot,bot,bot)+    top = (top,top,top,top,top,top)     (a1,a2,a3,a4,a5,a6) \/ (b1,b2,b3,b4,b5,b6) = (a1 \/ b1, a2 \/ b2, a3 \/ b3, a4 \/ b4, a5 \/ b5, a6 \/ b6)     (a1,a2,a3,a4,a5,a6) /\ (b1,b2,b3,b4,b5,b6) = (a1 /\ b1, a2 /\ b2, a3 /\ b3, a4 /\ b4, a5 /\ b5, a6 /\ b6)  -- | Seven-way product instance (Lattice a, Lattice b, Lattice c, Lattice d, Lattice e, Lattice f, Lattice g) => Lattice (a,b,c,d,e,f,g)   where-    empty     = (empty,empty,empty,empty,empty,empty,empty)-    universal = (universal,universal,universal,universal,universal,universal,universal)+    bot = (bot,bot,bot,bot,bot,bot,bot)+    top = (top,top,top,top,top,top,top)     (a1,a2,a3,a4,a5,a6,a7) \/ (b1,b2,b3,b4,b5,b6,b7) = (a1 \/ b1, a2 \/ b2, a3 \/ b3, a4 \/ b4, a5 \/ b5, a6 \/ b6, a7 \/ b7)     (a1,a2,a3,a4,a5,a6,a7) /\ (b1,b2,b3,b4,b5,b6,b7) = (a1 /\ b1, a2 /\ b2, a3 /\ b3, a4 /\ b4, a5 /\ b5, a6 /\ b6, a7 /\ b7) --- | Accumulated union+-- | Accumulated join unions :: Lattice a => [a] -> a-unions = foldr (\/) empty+unions = foldr (\/) bot --- | Accumulated intersection+-- | Accumulated meet intersections :: Lattice a => [a] -> a-intersections = foldr (/\) universal+intersections = foldr (/\) top   @@ -142,7 +148,7 @@         a'   = (aLens ^= bLat) a  -- | Take the fixed point of a function. The second argument is an initial---  element. A sensible default for the initial element is 'empty'.+--  element. A sensible default for the initial element is 'bot'. -- -- The function is not required to be monotonic. It is made monotonic internally -- by always taking the union of the result and the previous value.@@ -160,10 +166,10 @@ --   termination of the fixed point analysis. type Widening a = (Int -> a -> a) -> (Int -> a -> a) --- | A widening operator which defaults to 'universal' when the number of+-- | A widening operator which defaults to 'top' when the number of --   iterations goes over the specified value. cutOffAt :: Lattice a => Int -> Widening a-cutOffAt n f i a | i >= n    = universal+cutOffAt n f i a | i >= n    = top                  | otherwise = f i a  -- | A bounded version of 'lensedFixedPoint'. It will always do at least one@@ -175,7 +181,7 @@   where     go i a         | aLat == bLat = ((bLens ^= aLat) b, i)-        | i >= n-1     = ((bLens ^= universal) b, i)+        | i >= n-1     = ((bLens ^= top) b, i)         | otherwise    = go (i+1) a'       where         aLat = a ^! aLens