packages feed

co-feldspar (empty) → 0.1.0.1

raw patch · 39 files changed

+10603/−0 lines, 39 filesdep +arraydep +basedep +constraintssetup-changed

Dependencies added: array, base, constraints, containers, data-default-class, exception-transformers, hardware-edsl, imperative-edsl, language-c-quote, language-vhdl, minisat, mtl, operational-alacarte, signals, simple-smt, srcloc, syntactic, template-haskell

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for co-feldspar++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Markus++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 Markus nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ co-feldspar.cabal view
@@ -0,0 +1,80 @@+-- Initial co-feldspar.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                co-feldspar+version:             0.1.0.1+synopsis:            Hardware software co-design Feldspar+description:         An implementation of the Feldspar EDSL with a focus on+                     hardware software co-design and resource-awareness.+license:             BSD3+license-file:        LICENSE+author:              Markus+maintainer:          mararon@chalmers.se+copyright:           Copyright (c) 2015 Markus Aronsson, Emil Axelsson+category:            Language+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++library+  exposed-modules:+    Feldspar,+    Feldspar.Sugar,+    Feldspar.Representation,+    Feldspar.Storable,+    Feldspar.Frontend,+    Feldspar.Array.Buffered,+    Feldspar.Array.Vector,+    Feldspar.Array.Queue,+    Feldspar.Hardware,+    Feldspar.Hardware.Primitive,+    Feldspar.Hardware.Primitive.Backend,+    Feldspar.Hardware.Expression,+    Feldspar.Hardware.Representation,+    Feldspar.Hardware.Frontend,+    Feldspar.Hardware.Compile,+    Feldspar.Hardware.Optimize,+    Feldspar.Software,+    Feldspar.Software.Primitive,+    Feldspar.Software.Primitive.Backend,+    Feldspar.Software.Expression,+    Feldspar.Software.Representation,+    Feldspar.Software.Frontend,+    Feldspar.Software.Compile,+    Feldspar.Software.Marshal,+    Feldspar.Software.Optimize,+    Feldspar.Software.Verify,+    Feldspar.Software.Verify.Command,+    Feldspar.Software.Verify.Primitive,+    Feldspar.Verify.Abstract,+    Feldspar.Verify.Arithmetic,+    Feldspar.Verify.FirstOrder,+    Feldspar.Verify.Monad,+    Feldspar.Verify.SMT,+    Data.Struct,+    Data.Selection+    +  -- other-modules:       +  -- other-extensions:    +  build-depends:+    base                 >=4 && <5,+    mtl                  >=2.2,+    constraints          >=0.8,+    containers           >=0.5,+    array                >=0.5,+    data-default-class,+    exception-transformers,+    minisat,+    simple-smt,+    srcloc,+    language-c-quote,+    template-haskell,+    syntactic            >=3.8,+    operational-alacarte >=0.3,+    language-vhdl        >=0.1.4,+    hardware-edsl        >=0.1.6,+    imperative-edsl      >=0.8.2,+    signals              >=0.2.1++  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/Data/Selection.hs view
@@ -0,0 +1,66 @@+module Data.Selection+  ( Selection+  , includes+  , selectBy+  , empty+  , universal+  , select+  , union+  , intersection+  , difference+  , allExcept+  ) where++--------------------------------------------------------------------------------+-- * Data structure for describing selections of values.+--------------------------------------------------------------------------------++-- | Selection is a description of a set of values.+data Selection a = Selection (a -> Bool)++instance Semigroup (Selection a)+  where+    (<>) = mappend++instance Monoid (Selection a)+  where+    mempty  = empty+    mappend = union++-- | Check whether a value is included in a selection.+includes :: Selection a -> a -> Bool+includes (Selection p) = p++-- | Select the values that fulfill a predicate.+selectBy :: (a -> Bool) -> Selection a+selectBy = Selection++-- | Empty selection.+empty :: Selection a+empty = Selection $ \_ -> False++-- | Select all values.+universal :: Selection a+universal = Selection $ \_ -> True++-- | Union of selections.+union :: Selection a -> Selection a -> Selection a+union s t = Selection $ \a -> includes s a || includes t a++-- | Intersection of selections.+intersection :: Selection a -> Selection a -> Selection a+intersection s t = Selection $ \a -> includes s a && includes t a++-- | Difference of selections.+difference :: Selection a -> Selection a -> Selection a+difference s t = Selection $ \a -> includes s a && not (includes t a)++-- | Create a classification from a list of elements.+select :: Eq a => [a] -> Selection a+select as = selectBy (`elem` as)++-- | Select all values except those in the given list.+allExcept :: Eq a => [a] -> Selection a+allExcept = difference universal . select++--------------------------------------------------------------------------------
+ src/Data/Struct.hs view
@@ -0,0 +1,93 @@+{-# language GADTs #-}+{-# language ConstraintKinds #-}+{-# language ScopedTypeVariables #-}+{-# language Rank2Types #-}+{-# language StandaloneDeriving #-}++module Data.Struct where++import Control.Monad.Identity++--------------------------------------------------------------------------------+-- * Representation.+--------------------------------------------------------------------------------++-- | Typed binary tree structure+data Struct pred con a+  where+    Node   :: pred a => con a -> Struct pred con a+    Branch :: Struct pred con a -> Struct pred con b -> Struct pred con (a, b)++extractNode :: pred a => Struct pred con a -> con a+extractNode (Node a) = a++--------------------------------------------------------------------------------++toStruct :: Struct pred con a -> a -> Struct pred Identity a+toStruct rep = go rep . Identity+  where+    go :: Struct pred con a -> Identity a -> Struct pred Identity a+    go (Node _) i = Node i+    go (Branch u v) (Identity (a, b)) = Branch (go u (Identity a)) (go v (Identity b))++listStruct :: forall pred cont b c . (forall y . pred y => cont y -> c) -> Struct pred cont b -> [c]+listStruct f = go+  where+    go :: Struct pred cont a -> [c]+    go (Node a)     = [f a]+    go (Branch u v) = go u ++ go v++liftStruct+  :: (pred a, pred b)+  => (con a -> con b)+  -> Struct pred con a+  -> Struct pred con b+liftStruct f (Node a) = Node (f a)++liftStruct2+  :: (pred a, pred b, pred c)+  => (con a -> con b -> con c)+  -> Struct pred con a+  -> Struct pred con b+  -> Struct pred con c+liftStruct2 f (Node a) (Node b) = Node (f a b)++--------------------------------------------------------------------------------+-- ** Operations++-- | Map over a `Struct`.+mapStruct :: forall pred c1 c2 b+  .  (forall a. pred a => c1 a -> c2 a)+  -> Struct pred c1 b+  -> Struct pred c2 b+mapStruct f = go+  where+    go :: Struct pred c1 a -> Struct pred c2 a+    go (Node a) = Node (f a)+    go (Branch a b) = Branch (go a) (go b)++-- | Monadic map over a `Struct`.+mapStructA :: forall m pred c1 c2 b+  .  Applicative m+  => (forall a. pred a => c1 a -> m (c2 a))+  -> Struct pred c1 b+  -> m (Struct pred c2 b)+mapStructA f = go+  where+    go :: Struct pred c1 a -> m (Struct pred c2 a)+    go (Node a) = Node <$> f a+    go (Branch a b) = Branch <$> go a <*> go b++-- | Zip two 'Struct's to a list.+zipListStruct :: forall pred c1 c2 b r+    . (forall a . pred a => c1 a -> c2 a -> r)+    -> Struct pred c1 b+    -> Struct pred c2 b+    -> [r]+zipListStruct f = go+  where+    go :: Struct pred c1 a -> Struct pred c2 a -> [r]+    go (Node a)     (Node b)     = [f a b]+    go (Branch a b) (Branch c d) = go a c ++ go b d++--------------------------------------------------------------------------------
+ src/Feldspar.hs view
@@ -0,0 +1,17 @@+module Feldspar+  ( module Feldspar.Representation+  , module Feldspar.Frontend+  , module Data.Int+  , module Data.Word+  , module Language.Syntactic+  ) where++import Feldspar.Sugar+import Feldspar.Representation+import Feldspar.Frontend++import Data.Int+import Data.Word hiding (Word)++-- syntactic.+import Language.Syntactic (Syntactic, Domain, Internal)
+ src/Feldspar/Array/Buffered.hs view
@@ -0,0 +1,154 @@+{-# language TypeFamilies     #-}+{-# language FlexibleContexts #-}+{-# language RecordWildCards  #-}+{-# language MultiParamTypeClasses #-}+{-# language ScopedTypeVariables #-}++module Feldspar.Array.Buffered where++import Feldspar.Representation+import Feldspar.Frontend+import Feldspar.Array.Vector++import Prelude hiding (length)+import qualified Prelude as P++--------------------------------------------------------------------------------+-- *+--------------------------------------------------------------------------------++-- | Double-buffered storage.+data Store m a = Store+    { activeBuf :: Array m a+    , freeBuf   :: Array m a+    }++--------------------------------------------------------------------------------++class ArraysEq vec1 vec2+  where+    unsafeArrEq :: vec1 a -> vec2 a -> Bool++class Arrays m => ArraysSwap m+  where+    unsafeArrSwap :: Array m a -> Array m a -> m ()++--------------------------------------------------------------------------------++-- | Create a new double-buffered 'Store', initialized to a 0x0 matrix.+newStore :: (SyntaxM m a, MonadComp m) => Expr m Length -> m (Store m a)+newStore l = Store <$> newArr l <*> newArr l++-- | Create a new 'Store' from a single array.+newInPlaceStore+  :: ( SyntaxM m a+     , MonadComp m+     , Finite (Expr m) (IArray m a)+     , Finite (Expr m) (Array m a)+     )+  => Expr m Length -> m (Store m a)+newInPlaceStore l = do+  arr <- newArr l+  brr <- unsafeFreezeArr arr >>= unsafeThawArr+  return (Store arr brr)++-- | Read the contents of a 'Store' without making a copy. This is generally+--   only safe if the the 'Store' is not updated as long as the resulting vector+--   is alive.+unsafeFreezeStore+  :: ( SyntaxM m a+     , MonadComp m+     , Finite   (Expr m) (Array  m a)+     , Slicable (Expr m) (IArray m a)+     , Num (Expr m Index)+     )+  => Expr m Length -> Store m a -> m (Manifest m a)+unsafeFreezeStore l st = M <$> unsafeFreezeSlice l (activeBuf st)++-- | Cheap swapping of the two buffers in a 'Store'.+swapStore+  :: ( SyntaxM    m a+     -- hmm..+     , ArraysSwap m+     )+  => Store m a -> m ()+swapStore Store {..} = unsafeArrSwap activeBuf freeBuf++replaceFreeStore :: (SyntaxM m a, Arrays m) => Expr m Length -> Store m a -> m (Store m a)+replaceFreeStore l Store {..} = Store activeBuf <$> newArr l++-- | Write a vector to a 'Store'. The operation may become a no-op+--   if the vector is already in the 'Store'.+setStore+  :: forall m a vec .+     ( Manifestable m vec a+     , Finite (Expr m) vec+     , SyntaxM m a+     --+     , ArraysSwap m+     , ArraysEq (Array m) (IArray m)+     )+  => Store m a -> vec -> m ()+setStore st@Store {..} vec = case viewManifest vec of+    Just (M iarr :: Manifest m a) | unsafeArrEq activeBuf iarr+      -> return ()+    _ -> manifestStore freeBuf vec >> swapStore st+-- todo: Should check for offset and length differences as well.++-- | Write the contents of a vector to a 'Store' and get it back as a+--   'Manifest' vector.+store+  :: ( Manifestable m vec a+     , Finite (Expr m) vec+     , SyntaxM m a+     , MonadComp m+     --+     , Finite   (Expr m) (Array  m a)+     , Slicable (Expr m) (IArray m a)+     , Num (Expr m Index)+     --+     , ArraysSwap m+     , ArraysEq (Array m) (IArray m)+     )+  => Store m a -> vec -> m (Manifest m a)+store st vec = setStore st vec >> unsafeFreezeStore (length vec) st++loopStore+  :: ( Manifestable m vec1 a+     , Finite (Expr m) vec1+     , Manifestable m vec2 a+     , Finite (Expr m) vec2+     , SyntaxM m a+     , MonadComp m+     , Loop m+     --+     , Integral i+     , SyntaxM' m (Expr m i)+     , SyntaxM' m (Expr m Length)+     --+     , Finite   (Expr m) (Array  m a)+     , Slicable (Expr m) (IArray m a)+     , Num (Expr m Index)+     --+     , ArraysSwap m+     , ArraysEq (Array m) (IArray m)+     )+  => Store m a+  -> Expr m i  -- ^ Lower bound.+  -> Int       -- ^ Step.+  -> Expr m i  -- ^ Upper bound.+  -> (Expr m i -> Manifest m a -> m vec1)+  -> vec2+  -> m (Manifest m a)+loopStore store low step high body init = do+  setStore store init+  ilen <- initRef $ length init+  for low step high $ \ix -> do+    len  <- unsafeFreezeRef ilen+    next <- body ix =<< unsafeFreezeStore len store+    setStore store next+    setRef ilen $ length next+  len <- unsafeFreezeRef ilen+  unsafeFreezeStore len store++--------------------------------------------------------------------------------
+ src/Feldspar/Array/Queue.hs view
@@ -0,0 +1,127 @@+{-# language GADTs #-}+{-# language Rank2Types #-}+{-# language FlexibleContexts #-}+{-# language ConstraintKinds #-}+{-# language ScopedTypeVariables #-}++module Feldspar.Array.Queue where++import Feldspar+import Feldspar.Frontend (Arrays)+import Feldspar.Array.Vector++import Prelude hiding (length, mod, reverse, drop, take, (++))++--------------------------------------------------------------------------------+-- * Queues.+--------------------------------------------------------------------------------++data Queue m a = Queue+  { queue_get  :: Expr m Index -> m a+  , queue_put  :: a -> m ()+  , queue_with :: forall b . SyntaxM m b => (Pull (Expr m) a -> m b) -> m b+  }++type Queues m a =+  ( Finite  (Expr m) (Array m a)+  , Finite  (Expr m) (IArray m a)+  , Indexed (Expr m) (IArray m a)+  , ArrElem (IArray m a) ~ a++  , Multiplicative (Expr m)+  , Vector (Expr m)+  +  , SyntaxM m (Expr m Index)+  , SyntaxM m (Expr m Length)+  , PredOf (Expr m) Length+  )++--------------------------------------------------------------------------------++queueBuffer :: forall m a . (MonadComp m, SyntaxM m a, Queues m a)+  => Array m a -> m (Queue m a)+queueBuffer buf =+  do ir <- initRef (0 :: Expr m Index)+     let get :: Expr m Index -> m a+         get j = do+           i <- unsafeFreezeRef ir+           getArr buf $ safeIndex i j+     let put :: a -> m ()+         put a = do+           i <- unsafeFreezeRef ir+           setArr buf i a+           setRef ir ((i+1) `mod` len)+     let with :: forall b . (SyntaxM m b) => (Pull (Expr m) a -> m b) -> m b+         with f = do+           i <- unsafeFreezeRef ir+           v <- unsafeFreezeArr buf+           f $ backPermute (\_ -> safeIndex i) v+     return $ Queue { queue_get = get, queue_put = put, queue_with = with }+  where+    len = length buf+    safeIndex i j = (len + i - j - 1) `mod` len++queueVector ::+  ( Manifestable m vec a+  , Finite (Expr m) vec+  , SyntaxM m a+  , MonadComp m+  , Queues m a+  )+  => vec -> m (Queue m a)+queueVector v =+  do buf <- newArr $ length v+     manifestStore buf v+     queueBuffer buf++newQueue :: (SyntaxM m a, MonadComp m, Queues m a)+  => Expr m Length -> m (Queue m a)+newQueue l = newArr l >>= queueBuffer++--------------------------------------------------------------------------------++queueDoubleBuffer :: forall m a . (MonadComp m, SyntaxM m a, Queues m a)+  => Expr m Length -> Array m a -> m (Queue m a)+queueDoubleBuffer len buf =+  do ir <- initRef (0 :: Expr m Index)+     let get :: Expr m Index -> m a+         get j = do+           i <- unsafeFreezeRef ir+           getArr buf $ len + i - j - 1+     let put :: a -> m ()+         put a = do+           i <- unsafeFreezeRef ir+           setArr buf i a+           setArr buf (i + len) a+           setRef ir ((i + 1) `mod` len)+     let with :: forall b . (SyntaxM m b) => (Pull (Expr m) a -> m b) -> m b+         with f = do+           i <- unsafeFreezeRef ir+           v <- unsafeFreezeArr buf+           f $ reverse $ take len $ drop i v+     return $ Queue { queue_get = get, queue_put = put, queue_with = with }++queueDoubleVector :: forall m vec a .+  ( Manifestable m vec a+  , Finite (Expr m) vec+  , Slicable (Expr m) (IArray m a)+  , Pushy m vec a+  , SyntaxM m a+  , MonadComp m+  , Loop m+  , Queues m a+  )+  => vec -> m (Queue m a)+queueDoubleVector v =+  do let len = length v+     buf <- newArr $ 2 * len+     manifestStore buf $ (v ++ v :: Push m a)+     queueDoubleBuffer len buf++newDoubleQueue :: (SyntaxM m a, MonadComp m, Queues m a)+  => Expr m Length -> m (Queue m a)+newDoubleQueue l =+  do buf <- newArr $ 2 * l+     queueDoubleBuffer l buf+  +--------------------------------------------------------------------------------
+ src/Feldspar/Array/Vector.hs view
@@ -0,0 +1,616 @@+{-# language GADTs                  #-}+{-# language TypeFamilies           #-}+{-# language FlexibleInstances      #-}+{-# language FlexibleContexts       #-}+{-# language UndecidableInstances   #-}+{-# language MultiParamTypeClasses  #-}+{-# language FunctionalDependencies #-}+{-# language DefaultSignatures      #-}++{-# language ScopedTypeVariables    #-}+{-# language ConstraintKinds        #-}++module Feldspar.Array.Vector where++import Feldspar+import Feldspar.Frontend (Arrays)+import Feldspar.Storable++import Data.List (genericLength)++import Control.Monad ((<=<), void)++import Prelude hiding (take, drop, reverse, length, zip, zipWith, sum, min, div, (<), (>=))+import qualified Prelude as P++--------------------------------------------------------------------------------+-- * 1-dimensional vector library.+--------------------------------------------------------------------------------+--+-- This library has been inspired by the vector library in raw-feldspar+-- <https://github.com/Feldspar/raw-feldspar>+--+-- The general idea of pull and push vectors is described in+-- "Combining deep and shallow embedding of domain-specific languages"+-- <http://dx.doi.org/10.1016/j.cl.2015.07.003>.+--+-- Push arrays were originally introduced in+-- "Expressive array constructs in an embedded GPU kernel programming language"+-- <http://dx.doi.org/10.1145/2103736.2103740>.+--+--------------------------------------------------------------------------------++-- | Collection of constraints for `exp` to support Pull/Push vectors.+type Vector exp = (+  -- expressions needed to implement most Pull/Push vectors operations:+    Value     exp+  , Cond      exp+  , Ordered   exp+  , Iterate   exp+  -- constraints needed to support indexing:+  , Primitive exp Length+  , Syntax'   exp (exp Length)+  , Num           (exp Length)+  )++-- | ...+type VectorM m = Vector (Expr m)++--------------------------------------------------------------------------------+-- ** Manifest vectors.+--------------------------------------------------------------------------------++-- | A 1-dimensional vector with a concrete representation in memory+newtype Manifest m a = M { manifest :: IArray m a }++instance Finite exp (IArray m a) => Finite exp (Manifest m a)+  where+    length (M arr) = length arr++instance Indexed exp (IArray m a) => Indexed exp (Manifest m a)+  where+    type ArrElem (Manifest m a) = ArrElem (IArray m a)+    (!) (M arr) ix = arr ! ix++instance Slicable exp (IArray m a) => Slicable exp (Manifest m a)+  where+    slice ix len (M arr) = M $ slice ix len arr++listManifest :: forall m a .+  ( MonadComp m+  , SyntaxM   m a+  , VectorM   m+  , Loop      m+  -- ToDo: These two constraints are quite common.+  , Finite   (Expr m) (Array  m a)+  , Slicable (Expr m) (IArray m a)+  -- ToDo: Inherited from `listPush`.+  , Num  (Internal (Expr m Length))+  , Enum (Internal (Expr m Length))+  )+  => [a]+  -> m (Manifest m a)+listManifest as = manifestFresh (listPush as :: Push m a)++--------------------------------------------------------------------------------+-- * Pull vectors.+--------------------------------------------------------------------------------++-- | 1-dimensional pull vector: a vector representation that supports random+--   access and fusion of operations.+data Pull (exp :: * -> *) (a :: *) where+    Pull :: exp Length       -- ^ Length of vector.+         -> (exp Index -> a) -- ^ Index function.+         -> Pull exp a++instance Functor (Pull exp)+  where+    fmap f (Pull len ixf) = Pull len (f . ixf)++instance Finite exp (Pull exp a)+  where+    length (Pull len _) = len++instance Indexed exp (Pull exp a)+  where+    type ArrElem (Pull exp a) = a+    (Pull _ ixf) ! i = ixf i++instance (Vector exp, ExprOf a ~ exp) => Slicable exp (Pull exp a)+  where+    slice from n = take n . drop from++type instance ExprOf (Pull exp a) = exp++-- | Data structures that are 'Pull'-like.+class    ( Indexed exp vec+         , Finite  exp vec+         , a   ~ ArrElem vec+         , exp ~ ExprOf a)+        => Pully exp vec a++instance ( Indexed exp vec+         , Finite  exp vec+         , a   ~ ArrElem vec+         , exp ~ ExprOf a)+        => Pully exp vec a++--------------------------------------------------------------------------------+-- ** Pully operations.+--------------------------------------------------------------------------------++-- | Convert a 'Pully' vector to 'Pull' vector.+toPull :: Pully exp vec a => vec -> Pull exp a+toPull vec = Pull (length vec) (vec!)++-- | Take the head of a vector.+head :: forall exp vec a . (Vector exp, Pully exp vec a) => vec -> a+head = (!(0 :: exp Index))++-- | Take the 'l' first elements of a vector.+take :: (Vector exp, Pully exp vec a) => exp Length -> vec -> Pull exp a+take l vec = Pull (min (length vec) l) (vec!)++-- | Drop the 'l' first elements of a vector.+drop :: (Vector exp, Pully exp vec a) => exp Length -> vec -> Pull exp a+drop l vec = Pull (length vec - l) ((vec!) . (+l))++-- | Drop the head of a vector.+tail :: (Vector exp, Pully exp vec a) => vec -> Pull exp a+tail = drop 1++-- | Returns all final segments of the argument, longest first.+tails :: (Vector exp, Pully exp vec a) => vec -> Pull exp (Pull exp a)+tails vec = Pull (length vec + 1) (`drop` vec)++-- | Returns all initial segments of the argument, longest first.+inits :: (Vector exp, Pully exp vec a) => vec -> Pull exp (Pull exp a)+inits vec = Pull (length vec + 1) (`take` vec)++-- | `replicate l x` returns a vector of length `l` with `x` the value of every+--   element+replicate :: exp Length -> a -> Pull exp a+replicate l = Pull l . const++-- | `map f xs` is the vector obtained by applying `f` to each element of `xs`.+map :: Pully exp vec a => (a -> b) -> vec -> Pull exp b+map f vec = Pull (length vec) (f . (vec!))++-- | Zips togheter two vectors and returns vector of corresponding pairs.+zip :: (Vector exp, Pully exp vec1 a, Pully exp vec2 b)+  => vec1 -> vec2 -> Pull exp (a, b)+zip a b = Pull (length a `min` length b) (\i -> (a!i, b!i))++-- | Back-permute a `Pully` vector using an index mapping. The supplied mapping+--   must be a bijection when restricted to the domain of the vector. This+--   property is not checked, so use with care.+backPermute :: Pully exp vec a+  => (exp Length -> exp Index -> exp Index)+  -> (vec -> Pull exp a)+backPermute perm vec = Pull len ((vec!) . perm len)+  where+    len = length vec++-- | Reverses a vector.+reverse :: (Vector exp, Pully exp vec a) => vec -> Pull exp a+reverse = backPermute $ \len i -> len-i-1++-- | Returns a vector over the indices in the given range.+(...) :: Num (exp Index) => exp Index -> exp Index -> Pull exp (exp Index)+l ... h = Pull (h-l+1) (+l)++infix 3 ...++-- | Generalised version of `zip` that combines elements using the supplied+--   function, rather than tupeling.+zipWith :: (Vector exp, Pully exp vec1 a, Pully exp vec2 b)+  => (a -> b -> c) -> vec1 -> vec2 -> Pull exp c+zipWith f a b = fmap (uncurry f) $ zip a b++-- | Fold the elements in the vector using the given rigth-associativ binary+--   operator.+fold :: (Syntax exp a, Vector exp, Pully exp vec a)+  => (a -> a -> a) -> a -> vec -> a+fold f init vec = iter (length vec) init $ \i st -> f (vec!i) st++-- | Sums the elements in a vector.+sum :: (Syntax exp a, Num a, Vector exp, Pully exp vec a) => vec -> a+sum = fold (+) 0++-- | Scalar product of two vectors.+scProd :: (Syntax exp a, Num a, Vector exp, Pully exp vec a) => vec -> vec -> a+scProd a b = sum (zipWith (*) a b)++--------------------------------------------------------------------------------+-- * Push vectors.+--------------------------------------------------------------------------------++-- | 1-dimensional push vector: a vector representation that supports nested+--   write patterns and fusion of operations.+data Push m a+  where+    Push :: Expr m Length+         -> ((Expr m Index -> a -> m ()) -> m ())+         -> Push m a++instance Functor (Push m)+  where+    fmap f (Push len dump) = Push len $ \write ->+        dump $ \i -> write i . f++instance (Num (Expr m Length)) => Applicative (Push m)+  where+    pure a = Push 1 $ \write -> write 0 a+    vec1 <*> vec2 = Push (len1*len2) $ \write -> do+        dumpPush vec2 $ \i2 a ->+          dumpPush vec1 $ \i1 f ->+            write (i1*len2 + i2) (f a)+      where+        (len1,len2) = (length vec1, length vec2)+++instance (Expr m ~ exp) => Finite exp (Push m a)+  where+    length (Push len _) = len++-- | Vectors that can be converted to 'Push' vectors.+class Pushy m vec a | vec -> a+  where+    -- | Convert a vector to a 'Push' vector.+    toPush :: vec -> Push m a++-- | A version of 'toPush' that constrains the @m@ argument of 'Push' to that of+--   the monad in which the result is returned. This can be a convenient way to+--   avoid unresolved overloading.+toPushM :: (Pushy m vec a, Monad m) => vec -> m (Push m a)+toPushM = return . toPush++instance (MonadComp m, VectorM m, Loop m, Pully (Expr m) (IArray m a) a)+    => Pushy m (Manifest m a) a+  where+    toPush = toPush . toPull++-- ToDo: `exp ~ ...` hmm...+instance (MonadComp m, VectorM m, Loop m, exp ~ Expr m)+    => Pushy m (Pull exp a) a+  where+    toPush vec = Push len $ \write ->+      for 0 1 (len - 1) $ \i ->+        write i (vec ! i)+      where+        len = length vec++instance (m1 ~ m2) => Pushy m1 (Push m2 a) a+  where+    toPush = id++instance (MonadComp m1, Loop m1, VectorM m1, m1 ~ m2) => Pushy m1 (Seq m2 a) a+  where+    toPush (Seq len init) = Push len $ \write ->+      do next <- init+         for 0 1 (len - 1) $ \i -> do+           a <- next i+           write i a++--------------------------------------------------------------------------------+-- ** Push operations.+--------------------------------------------------------------------------------++-- | Dump the contents of a 'Push' vector.+dumpPush+  :: Push m a                     -- ^ Vector to dump.+  -> (Expr m Index -> a -> m ())  -- ^ Function that writes one element.+  -> m ()+dumpPush (Push _ dump) = dump++-- | Create a 'Push' vector from a list of elements.+listPush ::+  ( Monad m+  , VectorM m+  -- ^ ToDo: Are these necessary? Used to generate indices for each element.+  , Num  (Internal (Expr m Length))+  , Enum (Internal (Expr m Length))+  )+  => [a]+  -> Push m a+listPush as = Push (value $ genericLength as) $ \write ->+  sequence_ [write (value i) a | (i, a) <- P.zip [0..] as]++-- | Append two vectors to make a 'Push' vector.+(++) :: (Pushy m vec1 a, Pushy m vec2 a, Num (Expr m Length), Monad m)+  => vec1+  -> vec2+  -> Push m a+vec1 ++ vec2 = Push (len1 + length v2) $ \write ->+    dumpPush v1 write >> dumpPush v2 (write . (+len1))+  where+    v1   = toPush vec1+    v2   = toPush vec2+    len1 = length v1++-- | Concatenate nested vectors to a 'Push' vector.+concat :: (Pushy m vec1 vec2, Pushy m vec2 a, Num (Expr m Length), Monad m)+  => Expr m Length  -- ^ Length of inner vectors.+  -> vec1           -- ^ Nested vector.+  -> Push m a+concat c vec = Push (len*c) $ \write ->+    dumpPush v $ \i row ->+      dumpPush row $ \j a ->+        write (i * length row + j) a+  where+    v   = fmap toPush $ toPush vec+    len = length v++-- | Embed the effects in the elements into the internal effects of a 'Push'+-- vector+--+-- __WARNING:__ This function should be used with care, since it allows hiding+-- effects inside a vector. These effects may be (seemingly) randomly+-- interleaved with other effects when the vector is used.+--+-- The name 'sequens' has to do with the similarity to the standard function+-- 'sequence'.+sequens :: (Pushy m vec (m a), Monad m) => vec -> Push m a+sequens vec = Push (length v) $ \write ->+    dumpPush v $ \i m ->+      m >>= write i+  where+    v = toPush vec++-- | Forward-permute a 'Push' vector using an index mapping. The supplied+--   mapping must be a bijection when restricted to the domain of the vector.+--   This property is not checked, so use with care.+forwardPermute :: (Pushy m vec a)+  => (Expr m Length -> Expr m Index -> Expr m Index) -> vec -> Push m a+forwardPermute p vec = Push len $ \write ->+    dumpPush v $ \i a ->+      write (p len i) a+  where+    v   = toPush vec+    len = length v++-- I should use the short-hand constraints for 'pariwise' and 'unroll'... their signatures are quite long.+pairwise+  :: ( SyntaxM m a+     , SyntaxM m (Expr m Length)+     , Loop m+     , References m+     , Control m+     , Multiplicative (Expr m)+     , Ordered (Expr m)+     , Num (Expr m Length)+     , PredOf (Expr m) Length+     , PredOf (Expr m) (Internal (Expr m Length))+     , Pully (Expr m) vec a)+  => (Expr m Index -> (Expr m Index, Expr m Index)) -> vec -> Push m a+pairwise idxs vec =+  Push (length vec) $ \write -> do+    for 1 1 (length vec) $ \i -> do+      let (idx1, idx2) = idxs (i-1)+      iff (idx1 >= idx2) (return ()) $ do+        x <- shareM (vec ! idx1)+        y <- shareM (vec ! idx2)+        write idx1 x+        write idx2 y++-- | Convert a vector to a push vector that computes @n@ elements in each step.+-- This can be used to achieve loop unrolling.+--+-- The length of the vector must be divisible by the number of unrolling steps.+unroll+  :: ( Pully (Expr m) vec a+     , Monad m, Assert m+     , SyntaxM' m (Expr m Word32)+     , Internal (ExprOf a Word32) ~ Word32+     , Loop m     +     , References m+     , Value (Expr m)+     , Multiplicative (Expr m)+     , Equality (Expr m)+     , Num (Expr m Word32)+     )+    => Length  -- ^ Number of steps to unroll+    -> vec+    -> Push m a+unroll 0 _   = Prelude.error "unroll: cannot unroll 0 steps"+unroll 1 vec = Push len $ \write -> do+    for 0 1 (len-1) $ \i -> write i (vec!i)+  where+    len = length vec+unroll n vec = Push len $ \write -> do+    assert+      ((len `Feldspar.mod` value n) Feldspar.== 0)+      ("unroll: length not divisible by " Prelude.++ show n)+    for 0 n' (len-1) $ \i -> Prelude.sequence_+        [ do k <- shareM (i + value j)+             write k (vec!k)+        | j <- [0..n-1]]+  where+    n'  = Prelude.fromIntegral n+    len = length vec++--------------------------------------------------------------------------------+-- *+--------------------------------------------------------------------------------++data Seq m a+  where+    Seq :: Expr m Length -> m (Expr m Index -> m a) -> Seq m a++instance Monad m => Functor (Seq m)+  where+    fmap f (Seq len init) = Seq len $+      do next <- init+         return $ fmap f . next++instance (Expr m ~ exp) => Finite exp (Seq m a)+  where+    length (Seq len _) = len++class Sequence m vec a | vec -> a+  where+    toSeq :: vec -> Seq m a++toSeqM :: (Sequence m vec a, Monad m) => vec -> m (Seq m a)+toSeqM = return . toSeq++instance (m1 ~ m2) => Sequence m1 (Seq m2 a) a+  where+    toSeq = id++instance+       ( SyntaxM m a+       , ArrElem (IArray m a) ~ a+       , Indexed (Expr m) (IArray m a)+       , Finite  (Expr m) (IArray m a)+       , MonadComp m+       )+    => Sequence m (Manifest m a) a+  where+    toSeq = toSeq . toPull++instance+       ( Expr m ~ exp+       , ArrElem (IArray m a) ~ a+       , Indexed (Expr m) (IArray m a)+       , Finite  (Expr m) (IArray m a)+       , MonadComp m+       )+    => Sequence m (Pull exp a) a+  where+    toSeq vec = Seq (length vec) $ return $ \i -> return $ vec ! i++--------------------------------------------------------------------------------++recurrenceI+  :: ( Pushy     m fvec a+     , Sequence  m ivec a+     , MonadComp m+     )+  => fvec+  -> ivec+  -> (Pull m a -> b)+  -> Seq m b+recurrenceI ibuf ivec step = Seq len $+  do next <- init+     buf  <- undefined+     undefined+  where+    Seq len init = toSeq ivec+-- ...++--------------------------------------------------------------------------------+-- * Writing to memory.+--------------------------------------------------------------------------------++class ViewManifest m vec a | vec -> a+  where+    -- | Try to cast a vector to 'Manifest' directly.+    viewManifest :: vec -> Maybe (Manifest m a)+    viewManifest _ = Nothing++instance ViewManifest m (Pull exp a) a+instance ViewManifest m (Push m a) a+instance ViewManifest m (Seq m a) a+instance ViewManifest m (Manifest m a) a+  where+    viewManifest = Just++class ViewManifest m vec a => Manifestable m vec a | vec -> a+  where+    -- | Write the contents of a vector to memory and get its 'Manifest'+    --   vector back. The supplied array may or may not be used for storage.+    manifestArr :: (MonadComp m, SyntaxM m a)+        => Array m a  -- ^ Where to store the vector.+        -> vec        -- ^ Vector to store.+        -> m (Manifest m a)++    default manifestArr+        :: ( MonadComp m+           , SyntaxM   m a+           , Pushy     m vec a+           , Finite   (Expr m) vec+           , Finite   (Expr m) (Array  m a)+           , Slicable (Expr m) (IArray m a)+           , Num (Expr m Index)+           )+        => Array m a -> vec -> m (Manifest m a)+    manifestArr loc vec = do+        dumpPush v $ \i a -> setArr loc i a+        M <$> unsafeFreezeSlice (length vec) loc+      where+        v = toPush vec++    -- | A version of 'manifest' that allocates a fresh array for the result.+    manifestFresh :: SyntaxM m a => vec -> m (Manifest m a)++    default manifestFresh+        :: ( MonadComp m+           , SyntaxM   m a+           , Finite (Expr m) vec+           )+        => vec+        -> m (Manifest m a)+    manifestFresh vec = do+        loc <- newArr $ length vec+        manifestArr loc vec++    -- | A version of 'manifest' that only stores the vector to the given array.+    manifestStore :: SyntaxM m a => Array m a -> vec -> m ()++    default manifestStore+        :: ( MonadComp m+           , SyntaxM   m a+           , VectorM   m+           , Loop      m+           , Finite   (Expr m) (Array  m a)+           , Slicable (Expr m) (IArray m a)+           , Num (Expr m Length)+           -- todo: Why isn't this free?+           , Pushy m vec a+           )+        => Array m a+        -> vec+        -> m ()+    manifestStore loc v = void $ manifestArr loc (toPush v :: Push m a)++instance (MonadComp m, SyntaxM m a, Loop m, Finite (Expr m) (IArray m a))+    => Manifestable m (Manifest m a) a+  where+    manifestArr _     = return+    manifestFresh     = return+    manifestStore loc = copyArr loc <=< unsafeThawArr . manifest++  -- ToDo: `exp ~ ...` hmm...+instance (+    MonadComp m+  , SyntaxM   m a+  , VectorM   m+  , Loop      m+  , Finite   exp (Array m a)+  , Slicable exp (IArray m a)+  , exp ~ Expr m+  )+  => Manifestable m (Pull exp a) a++instance (+    MonadComp m+  , SyntaxM   m a+  , VectorM   m+  , Loop      m+  , Finite   (Expr m) (Array m a)+  , Slicable (Expr m) (IArray m a)+  )+  => Manifestable m (Push m a) a++instance (+    MonadComp m+  , SyntaxM   m a+  , VectorM   m+  , Loop      m+  , Finite   (Expr m) (Array m a)+  , Slicable (Expr m) (IArray m a)+  )+  => Manifestable m (Seq m a) a++--------------------------------------------------------------------------------
+ src/Feldspar/Frontend.hs view
@@ -0,0 +1,329 @@+{-# language TypeFamilies          #-}+{-# language MultiParamTypeClasses #-}+{-# language FlexibleContexts      #-}+{-# language ConstraintKinds       #-}+{-# language ScopedTypeVariables   #-}+{-# language FunctionalDependencies #-}++module Feldspar.Frontend where++import Feldspar.Sugar+import Feldspar.Representation++import Data.Bits (Bits, FiniteBits)+import Data.Constraint+import Data.Int+import Data.Struct+import Data.Proxy+import Data.Word hiding (Word)++import qualified Data.Bits as Bits++-- syntactic.+import Language.Syntactic as S hiding (Equality)++-- operational-higher.+import qualified Control.Monad.Operational.Higher as Oper (Program, Param2)++-- imperative-edsl+import qualified Language.Embedded.Imperative     as Imp+import qualified Language.Embedded.Imperative.CMD as Imp (Ref)++import Prelude hiding (length, Word, (<), (>))++--------------------------------------------------------------------------------+-- * ...+--------------------------------------------------------------------------------++-- | ...+type Syn (dom :: * -> *) (pred :: * -> Constraint) (exp :: * -> *) (a :: *) =+  ( Syntactic a+  , Domain a ~ dom+  , Type pred (Internal a)+  , Tuples dom+  )++-- | ...+type Syn' dom pred exp a = (Syn dom pred exp a, PrimType pred (Internal a))++-- | ...+type Syntax  exp a = (Syn  (DomainOf exp) (PredOf exp) exp a, ExprOf a ~ exp)++-- | ...+type Syntax' exp a = (Syn' (DomainOf exp) (PredOf exp) exp a, ExprOf a ~ exp)++-- | ...+type Primitive exp a = PredOf exp a++--------------------------------------------------------------------------------++-- | ...+type SyntaxM  m a = Syntax  (Expr m) a++-- | ...+type SyntaxM' m a = Syntax' (Expr m) a++--------------------------------------------------------------------------------+-- * Expressions.+--------------------------------------------------------------------------------++class Value exp+  where+    value :: Syntax exp a => Internal a -> a++class Share exp+  where+    share :: (Syntax exp a, Syntax exp b) => a -> (a -> b) -> b++class Iterate exp+  where+    loop :: Syntax exp st => exp Length -> exp Length -> st+         -> (exp Index -> st -> st) -> st++iter :: (Iterate exp, Syntax exp st, Num (exp Length))+  => exp Length -> st -> (exp Index -> st -> st) -> st+iter = loop 0++class Cond exp+  where+    cond :: Syntax exp a => exp Bool -> a -> a -> a++-- | Condition operator; use as follows:+--+-- @+-- cond1 `?` a $+-- cond2 `?` b $+--         default+-- @+(?) :: (Cond exp, Syntax exp a) => exp Bool -> a -> a -> a+(?) = cond++infixl 1 ?++class Equality exp+  where+    (==) :: (Eq a, Primitive exp a) => exp a -> exp a -> exp Bool++infix 4 ==+  +class Equality exp => Ordered exp+  where+    (<)  :: (Ord a, Primitive exp a) => exp a -> exp a -> exp Bool+    (<=) :: (Ord a, Primitive exp a) => exp a -> exp a -> exp Bool+    (>)  :: (Ord a, Primitive exp a) => exp a -> exp a -> exp Bool+    (>=) :: (Ord a, Primitive exp a) => exp a -> exp a -> exp Bool++infix 4 <, >, <=, >=++max :: (Cond exp, Ordered exp, Syntax exp (exp a), Ord a, Primitive exp a)+    => exp a -> exp a -> exp a+max a b = cond (a > b) a b+  +min :: (Cond exp, Ordered exp, Syntax exp (exp a), Ord a, Primitive exp a)+    => exp a -> exp a -> exp a+min a b = cond (a < b) a b++class Logical exp+  where+    not  :: exp Bool -> exp Bool+    (&&) :: exp Bool -> exp Bool -> exp Bool+    (||) :: exp Bool -> exp Bool -> exp Bool++infix 3 &&+infix 2 ||++class Multiplicative exp+  where+    mult :: (Integral a, Primitive exp a) => exp a -> exp a -> exp a+    div  :: (Integral a, Primitive exp a) => exp a -> exp a -> exp a+    mod  :: (Integral a, Primitive exp a) => exp a -> exp a -> exp a+  +class Bitwise exp+  where+    complement :: (Bits a, Primitive exp a) => exp a -> exp a+    (.&.) :: (Bits a, Primitive exp a) => exp a -> exp a -> exp a+    (.|.) :: (Bits a, Primitive exp a) => exp a -> exp a -> exp a+    xor   :: (Bits a, Primitive exp a) => exp a -> exp a -> exp a+    sll   :: ( Bits a,     Primitive exp a+             , Integral b, Primitive exp b)+          => exp a -> exp b -> exp a+    srl   :: ( Bits a,     Primitive exp a+             , Integral b, Primitive exp b)+          => exp a -> exp b -> exp a+    rol   :: ( Bits a,     Primitive exp a+             , Integral b, Primitive exp b)+          => exp a -> exp b -> exp a+    ror   :: ( Bits a,     Primitive exp a+             , Integral b, Primitive exp b)+          => exp a -> exp b -> exp a++infixl 8 `sll`, `srl`, `rol`, `ror`+infixl 7 .&.+infixl 6 `xor`+infixl 5 .|.++shiftL  :: (Bitwise exp, Bits a, Primitive exp a, Integral b, Primitive exp b) => exp a -> exp b -> exp a+shiftL = sll++shiftR  :: (Bitwise exp, Bits a, Primitive exp a, Integral b, Primitive exp b) => exp a -> exp b -> exp a+shiftR = srl++rotateL :: (Bitwise exp, Bits a, Primitive exp a, Integral b, Primitive exp b) => exp a -> exp b -> exp a+rotateL = rol++rotateR :: (Bitwise exp, Bits a, Primitive exp a, Integral b, Primitive exp b) => exp a -> exp b -> exp a+rotateR = ror++(.<<.)  :: (Bitwise exp, Bits a, Primitive exp a, Primitive exp Int32) => exp a -> exp Int32 -> exp a+(.<<.) = shiftL++(.>>.)  :: (Bitwise exp, Bits a, Primitive exp a, Primitive exp Int32) => exp a -> exp Int32 -> exp a+(.>>.) = shiftR++infixl 8 `shiftL`, `shiftR`, `rotateL`, `rotateR`, .<<., .>>.++bitSize :: forall exp a. FiniteBits a => exp a -> Word64+bitSize _ = fromIntegral $ Bits.finiteBitSize (a :: a)+  where a = error "Bits.finiteBitSize evaluated its argument"++ones :: (Bitwise exp, Bits a, Num (exp a), Primitive exp a) => exp a+ones = complement 0++class Casting exp+  where+    i2n :: (Integral a, Primitive exp a, Num b, Primitive exp b) => exp a -> exp b+    i2b :: (Integral a, Primitive exp a, Primitive exp Bool) => exp a -> exp Bool+    b2i :: (Integral a, Primitive exp a, Primitive exp Bool) => exp Bool -> exp a++--------------------------------------------------------------------------------+-- * Instructions.+--------------------------------------------------------------------------------++-- | Computational instructions.+type MonadComp m+  = ( Monad m+    , References m+    , Arrays m+    , IArrays m+    , Control m+    )++--------------------------------------------------------------------------------++class Monad m => References m+  where+    type Reference m :: * -> *+    initRef :: SyntaxM m a => a -> m (Reference m a)+    newRef  :: SyntaxM m a => m (Reference m a)+    getRef  :: SyntaxM m a => Reference m a -> m a+    setRef  :: SyntaxM m a => Reference m a -> a -> m ()+    unsafeFreezeRef :: SyntaxM m a => Reference m a -> m a++updateRef :: (References m, SyntaxM m a) => Reference m a -> (a -> a) -> m ()+updateRef ref f = do v <- unsafeFreezeRef ref; setRef ref (f v)++shareM :: (SyntaxM m a, References m) => a -> m a+shareM a = initRef a >>= unsafeFreezeRef++--------------------------------------------------------------------------------++class Finite exp arr+  where+    length :: arr -> exp Length++class Indexed exp arr+  where+    type ArrElem arr :: *+    (!) :: arr -> exp Index -> ArrElem arr++class Slicable exp arr+  where+    slice :: exp Index -> exp Length -> arr -> arr++--------------------------------------------------------------------------------++class Monad m => Arrays m+  where+    type Array m :: * -> *+    initArr :: SyntaxM' m a => [Internal a] -> m (Array m a)+    newArr  :: SyntaxM  m a => Expr m Length -> m (Array m a)+    getArr  :: SyntaxM  m a => Array m a -> Expr m Index -> m a+    setArr  :: SyntaxM  m a => Array m a -> Expr m Index -> a -> m ()+    copyArr :: SyntaxM  m a => Array m a -> Array m a -> m ()++--------------------------------------------------------------------------------++class Arrays m => IArrays m+  where+    type IArray m :: * -> *+    unsafeFreezeArr :: (SyntaxM m a, Finite (Expr m) (Array  m a))+      => Array  m a -> m (IArray m a)+    unsafeThawArr   :: (SyntaxM m a, Finite (Expr m) (IArray m a))+      => IArray m a -> m (Array  m a)++freezeArr ::+     ( IArrays m+     , SyntaxM m a+     , Finite (Expr m) (Array m a)+     )+  => Array m a -> m (IArray m a)+freezeArr arr =+  do iarr <- newArr (length arr)+     copyArr iarr arr+     unsafeFreezeArr iarr++thawArr ::+     ( IArrays m+     , SyntaxM m a+     , Finite (Expr m) (IArray m a)+     )+  => IArray m a -> m (Array m a)+thawArr iarr =+  do brr <- unsafeThawArr iarr -- haha.+     arr <- newArr (length iarr)+     copyArr arr brr+     return arr++unsafeFreezeSlice+  :: ( IArrays m+     , SyntaxM m a+     , Finite   (Expr m) (Array  m a)+     , Slicable (Expr m) (IArray m a)+     , Num (Expr m Index)+     )+  => Expr m Length -> Array m a -> m (IArray m a)+unsafeFreezeSlice len = fmap (slice 0 len) . unsafeFreezeArr++--------------------------------------------------------------------------------++class Monad m => Control m+  where+    -- | Conditional statement.+    iff ::+         Expr m Bool     -- ^ Condition.+      -> m ()            -- ^ True branch.+      -> m ()            -- ^ False branch.+      -> m ()++class Monad m => Loop m+  where+    -- | While-loop.+    while ::+         m (Expr m Bool) -- ^ Condition.+      -> m ()            -- ^ Loop body.+      -> m ()++    -- | For-loop.+    for :: (Integral a, SyntaxM' m (Expr m a))+      => Expr m a           -- ^ Lower bound (inclusive).+      -> Int                -- ^ Inc./dec. step.+      -> Expr m a           -- ^ Upper bound (inclusive).+      -> (Expr m a -> m ()) -- ^ Step function.+      -> m ()++class Monad m => Assert m+  where+    break  :: m ()+    assert :: Expr m Bool -> String -> m ()++--------------------------------------------------------------------------------
+ src/Feldspar/Hardware.hs view
@@ -0,0 +1,19 @@+module Feldspar.Hardware+  ( Hardware+  , Ref, Arr, IArr, SArr, Signal+  , HExp+  , HType, HType', HardwarePrimType+  , module Feldspar+  , module Feldspar.Hardware.Frontend+  , module Feldspar.Hardware.Compile+  ) where++import Feldspar+import Feldspar.Hardware.Representation+import Feldspar.Hardware.Primitive+import Feldspar.Hardware.Expression+import Feldspar.Hardware.Frontend+import Feldspar.Hardware.Compile++-- hardware-edsl+import Language.Embedded.Hardware.Command (Signal)
+ src/Feldspar/Hardware/Compile.hs view
@@ -0,0 +1,269 @@+{-# language GADTs               #-}+{-# language TypeOperators       #-}+{-# language FlexibleContexts    #-}+{-# language ConstraintKinds     #-}+{-# language ScopedTypeVariables #-}++{-# language MultiParamTypeClasses #-}++module Feldspar.Hardware.Compile where++import Feldspar.Sugar+import Feldspar.Representation+import Feldspar.Hardware.Primitive+import Feldspar.Hardware.Primitive.Backend+import Feldspar.Hardware.Expression+import Feldspar.Hardware.Representation+import Feldspar.Hardware.Optimize+import Feldspar.Hardware.Frontend (HSig)+import Data.Struct++-- hmm..+import qualified Language.Embedded.Hardware.Interface.AXI as Hard (FreePrim(..))++import Control.Monad.Identity+import Control.Monad.Reader+import Data.Constraint hiding (Sub)+import Data.Proxy+import Data.Map (Map)+import qualified Data.Map as Map++-- operational-higher.+import Control.Monad.Operational.Higher (Program, ProgramT)+import qualified Control.Monad.Operational.Higher as Oper++-- syntactic.+import Language.Syntactic hiding (Nil)+import Language.Syntactic.Functional hiding (Binding (..))+import Language.Syntactic.Functional.Tuple+import qualified Language.Syntactic as Syn++-- hardware-edsl.+import Language.Embedded.Hardware (Signal, FreeExp (..))+import Language.Embedded.Hardware.Command (Signal)+import qualified Language.Embedded.Hardware as Hard+import qualified Language.Embedded.Hardware.Command as Hard++--------------------------------------------------------------------------------+-- * Hardware compiler.+--------------------------------------------------------------------------------++-- | Target hardware instructions.+type TargetCMD+    =        Hard.VariableCMD+    Oper.:+: Hard.ArrayCMD+    Oper.:+: Hard.VArrayCMD+    Oper.:+: Hard.LoopCMD+    Oper.:+: Hard.ConditionalCMD+    Oper.:+: Hard.ComponentCMD+    Oper.:+: Hard.SignalCMD+    Oper.:+: Hard.ProcessCMD+    --+    Oper.:+: Hard.VHDLCMD++-- | Target monad during translation.+type TargetT m = ReaderT Env (ProgramT TargetCMD (Oper.Param2 Prim HardwarePrimType) m)++-- | Monad for translated programs.+type ProgH = Program TargetCMD (Oper.Param2 Prim HardwarePrimType)++--------------------------------------------------------------------------------+-- ** Compilation of expressions.++-- | Struct expression.+type VExp = Struct HardwarePrimType Prim++-- | Struct expression with hidden result type.+data VExp' where+  VExp' :: Struct HardwarePrimType Prim a -> VExp'++newRefV :: Monad m => HTypeRep a -> String -> TargetT m (Struct HardwarePrimType Hard.Variable a)+newRefV t base = lift $ mapStructA (const (Hard.newNamedVariable base)) t++initRefV :: Monad m => String -> VExp a -> TargetT m (Struct HardwarePrimType Hard.Variable a)+initRefV base = lift . mapStructA (Hard.initNamedVariable base)++getRefV :: Monad m => Struct HardwarePrimType Hard.Variable a -> TargetT m (VExp a)+getRefV = lift . mapStructA Hard.getVariable++setRefV :: Monad m => Struct HardwarePrimType Hard.Variable a -> VExp a -> TargetT m ()+setRefV r = lift . sequence_ . zipListStruct Hard.setVariable r++unsafeFreezeRefV :: Monad m => Struct HardwarePrimType Hard.Variable a -> TargetT m (VExp a)+unsafeFreezeRefV = lift . mapStructA Hard.unsafeFreezeVariable++--------------------------------------------------------------------------------++type Env = Map Name VExp'++localAlias :: MonadReader Env m => Name -> VExp a -> m b -> m b+localAlias v e = local (Map.insert v (VExp' e))++lookAlias :: MonadReader Env m => HTypeRep a -> Name -> m (VExp a)+lookAlias t v = do+  env <- ask+  return $ case Map.lookup v env of+    Nothing -> error $ "lookAlias: variable " ++ show v ++ " not in scope."+    Just (VExp' e) ->+      case hardwareTypeEq t (hardwareTypeRep e) of Just Dict -> e++--------------------------------------------------------------------------------++translateExp :: forall m a . Monad m => HExp a -> TargetT m (VExp a)+translateExp = goAST . optimize . unHExp+  where+    goAST :: ASTF HardwareDomain b -> TargetT m (VExp b)+    goAST = simpleMatch (\(s :&: ValT t) -> go t s)++    goSmallAST :: HardwarePrimType b => ASTF HardwareDomain b -> TargetT m (Prim b)+    goSmallAST = fmap extractNode . goAST++    go :: HTypeRep (DenResult sig)+       -> HardwareConstructs sig+       -> Syn.Args (AST HardwareDomain) sig+       -> TargetT m (VExp (DenResult sig))+    go t lit Syn.Nil+      | Just (Lit a) <- prj lit+      = return $ mapStruct (litE . runIdentity) $ toStruct t a+--    go t lit Syn.Nil+--      | Just (Literal a) <- prj lit+--      = return $ mapStruct (litE . runIdentity) $ toStruct t a+    go t var Syn.Nil+      | Just (FreeVar v) <- prj var+      = return $ Node $ sugarSymPrim $ FreeVar v+    go t var Syn.Nil+      | Just (VarT v) <- prj var+      = lookAlias t v+    go t lt (a :* (lam :$ body) :* Syn.Nil)+      | Just (Let tag) <- prj lt+      , Just (LamT v)  <- prj lam+      = do let base = if Prelude.null tag then "let" else tag+           r  <- initRefV base =<< goAST a+           a' <- unsafeFreezeRefV r+           localAlias v a' $ goAST body+    go t tup (a :* b :* Syn.Nil)+      | Just Pair <- prj tup =+          Branch <$> goAST a <*> goAST b+    go t sel (ab :* Syn.Nil)+      | Just Fst <- prj sel = do+          branch <- goAST ab+          case branch of (Branch a _) -> return a+      | Just Snd <- prj sel = do+          branch <- goAST ab+          case branch of (Branch _ b) -> return b+    go ty cond (b :* t :* f :* Syn.Nil)+      | Just Cond <- prj cond = do+          res <- newRefV ty "b"+          b'  <- goSmallAST b+          ReaderT $ \env -> Hard.iff b'+            (flip runReaderT env $ setRefV res =<< goAST t)+            (flip runReaderT env $ setRefV res =<< goAST f)+          unsafeFreezeRefV res+    go t op (a :* Syn.Nil)+      | Just Neg <- prj op = liftStruct (sugarSymPrim Neg) <$> goAST a+      | Just Not <- prj op = liftStruct (sugarSymPrim Not) <$> goAST a+      | Just I2N <- prj op = liftStruct (sugarSymPrim I2N) <$> goAST a+      | Just (Cast f) <- prj op =+          liftStruct (sugarSymPrim (Cast f)) <$> goAST a+      | Just BitCompl <- prj op =+          liftStruct (sugarSymPrim BitCompl) <$> goAST a+    go t op (a :* b :* Syn.Nil)+      | Just Add <- prj op = liftStruct2 (sugarSymPrim Add) <$> goAST a <*> goAST b+      | Just Sub <- prj op = liftStruct2 (sugarSymPrim Sub) <$> goAST a <*> goAST b+      | Just Mul <- prj op = liftStruct2 (sugarSymPrim Mul) <$> goAST a <*> goAST b+      | Just Div <- prj op = liftStruct2 (sugarSymPrim Div) <$> goAST a <*> goAST b+      | Just Mod <- prj op = liftStruct2 (sugarSymPrim Mod) <$> goAST a <*> goAST b+      | Just Eq  <- prj op = liftStruct2 (sugarSymPrim Eq)  <$> goAST a <*> goAST b+      | Just And <- prj op = liftStruct2 (sugarSymPrim And) <$> goAST a <*> goAST b+      | Just Or  <- prj op = liftStruct2 (sugarSymPrim Or)  <$> goAST a <*> goAST b+      | Just Lt  <- prj op = liftStruct2 (sugarSymPrim Lt)  <$> goAST a <*> goAST b+      | Just Lte <- prj op = liftStruct2 (sugarSymPrim Lte) <$> goAST a <*> goAST b+      | Just Gt  <- prj op = liftStruct2 (sugarSymPrim Gt)  <$> goAST a <*> goAST b+      | Just Gte <- prj op = liftStruct2 (sugarSymPrim Gte) <$> goAST a <*> goAST b+      | Just BitAnd <- prj op =+          liftStruct2 (sugarSymPrim BitAnd)  <$> goAST a <*> goAST b+      | Just BitOr  <- prj op =+          liftStruct2 (sugarSymPrim BitOr)   <$> goAST a <*> goAST b+      | Just BitXor <- prj op =+          liftStruct2 (sugarSymPrim BitXor)  <$> goAST a <*> goAST b+      | Just ShiftL <- prj op =+          liftStruct2 (sugarSymPrim ShiftL)  <$> goAST a <*> goAST b+      | Just ShiftR <- prj op =+          liftStruct2 (sugarSymPrim ShiftR)  <$> goAST a <*> goAST b          +      | Just RotateL <- prj op =+          liftStruct2 (sugarSymPrim RotateL) <$> goAST a <*> goAST b+      | Just RotateR <- prj op =+          liftStruct2 (sugarSymPrim RotateR) <$> goAST a <*> goAST b+    go t loop (min :* max :* init :* (lami :$ (lams :$ body)) :* Syn.Nil)+      | Just ForLoop   <- prj loop+      , Just (LamT iv) <- prj lami+      , Just (LamT sv) <- prj lams = do+          min'  <- goSmallAST min+          max'  <- goSmallAST max+          state <- initRefV "state" =<< goAST init+          let int = Hard.cast (fromIntegral)+          ReaderT $ \env -> Hard.for (int min') (int max') $ \i ->+            flip runReaderT env $ do+              s <- case t of+                Node _ -> unsafeFreezeRefV state+                _      -> getRefV state+              let i' = Hard.cast' (proxyE min') i+              s' <- localAlias iv (Node i') $ localAlias sv s $ goAST body+              setRefV state s'+          unsafeFreezeRefV state+      where+        proxyE :: Prim x -> Proxy x+        proxyE _ = Proxy+    go _ arrIx (i :* Syn.Nil)+      | Just (ArrIx arr) <- prj arrIx = do+          i' <- goSmallAST i+          return $ Node $ sugarSymPrim (ArrIx arr) i'+    go _ s _ = error $ "hardware translation handling for symbol " ++ Syn.renderSym s ++ " is missing."++unsafeTranslateSmallExp :: Monad m => HExp a -> TargetT m (Prim a)+unsafeTranslateSmallExp a = do+  node <- translateExp a+  case node of Node b -> return b++translate :: Hardware a -> ProgH a+translate = flip runReaderT Map.empty . Oper.reexpressEnv unsafeTranslateSmallExp . unHardware++--------------------------------------------------------------------------------++translateHSig :: HSig a -> Hard.Sig TargetCMD Prim HardwarePrimType Identity a+translateHSig (Hard.Ret  prg)      = Hard.Ret (translate (Hardware prg))+translateHSig (Hard.SSig n m sf)   = Hard.SSig n m (translateHSig . sf)+translateHSig (Hard.SArr n m l af) = Hard.SArr n m l (translateHSig . af)++--------------------------------------------------------------------------------+-- * Interpretation of hardware programs.+--------------------------------------------------------------------------------++compile :: Hardware () -> String+compile = Hard.compile . translate++icompile :: Hardware () -> IO ()+icompile = Hard.icompile . translate++--------------------------------------------------------------------------------++compileSig :: HSig a -> String+compileSig = Hard.compileSig . translateHSig++icompileSig :: HSig a -> IO ()+icompileSig = Hard.icompileSig . translateHSig++--------------------------------------------------------------------------------+-- Compiler that wraps a hardware component in an AXI-lite framework.++instance Hard.FreePrim Prim HardwarePrimType+  where+    witPred _ Dict = Dict++compileAXILite :: HSig a -> String+compileAXILite = Hard.compileAXILite . translateHSig++icompileAXILite :: HSig a -> IO ()+icompileAXILite = putStrLn . compileAXILite++--------------------------------------------------------------------------------
+ src/Feldspar/Hardware/Expression.hs view
@@ -0,0 +1,254 @@+{-# language GADTs                 #-}+{-# language TypeFamilies          #-}+{-# language TypeOperators         #-}+{-# language FlexibleInstances     #-}+{-# language FlexibleContexts      #-}+{-# language UndecidableInstances  #-}+{-# language MultiParamTypeClasses #-}+{-# language ConstraintKinds       #-}+{-# language StandaloneDeriving    #-}++{-# options_ghc -fwarn-incomplete-patterns #-}++module Feldspar.Hardware.Expression where++import Feldspar.Sugar+import Feldspar.Representation+import Feldspar.Hardware.Primitive+import Data.Struct++import Data.Int+import Data.Word+import Data.List (genericTake)+import Data.Constraint+import Data.Typeable (Typeable)++-- syntactic.+import Language.Syntactic hiding (Signature, Args)+import Language.Syntactic.Functional hiding (Lam)+import Language.Syntactic.Functional.Tuple+import qualified Language.Syntactic as Syn++-- hardware-edsl.+import Language.Embedded.Hardware.Interface++--------------------------------------------------------------------------------+-- * Hardware expressions.+--------------------------------------------------------------------------------++type instance Pred HardwareDomain = HardwarePrimType++--------------------------------------------------------------------------------+-- hmm...++type instance ExprOf   (HExp a) = HExp+type instance PredOf   HExp     = HardwarePrimType+type instance DomainOf HExp     = HardwareDomain+type instance RepresentationOf HardwarePrimType = HardwarePrimTypeRep++--------------------------------------------------------------------------------+-- ** Hardware types.++-- | Representation of supported hardware types.+type HTypeRep = TypeRep HardwarePrimType HardwarePrimTypeRep++instance Type HardwarePrimType Bool    where typeRep = Node BoolHT+instance Type HardwarePrimType Integer where typeRep = Node IntegerHT+instance Type HardwarePrimType Int8    where typeRep = Node Int8HT+instance Type HardwarePrimType Int16   where typeRep = Node Int16HT+instance Type HardwarePrimType Int32   where typeRep = Node Int32HT+instance Type HardwarePrimType Int64   where typeRep = Node Int64HT+instance Type HardwarePrimType Word8   where typeRep = Node Word8HT+instance Type HardwarePrimType Word16  where typeRep = Node Word16HT+instance Type HardwarePrimType Word32  where typeRep = Node Word32HT+instance Type HardwarePrimType Word64  where typeRep = Node Word64HT++-- | Compare two hardware types for equality.+hardwareTypeEq :: HTypeRep a -> HTypeRep b -> Maybe (Dict (a ~ b))+hardwareTypeEq (Node t)       (Node u) = hardwarePrimTypeEq t u+hardwareTypeEq (Branch t1 u1) (Branch t2 u2) = do+  Dict <- hardwareTypeEq t1 t2+  Dict <- hardwareTypeEq u1 u2+  return Dict+hardwareTypeEq _ _ = Nothing++-- | Construct the hardware type representation of 'a'.+hardwareTypeRep :: Struct HardwarePrimType c a -> HTypeRep a+hardwareTypeRep = mapStruct (const hardwareRep)++--------------------------------------------------------------------------------++-- | Short-hand for hardware types.+type HType    = Type HardwarePrimType++-- | Short-hand for primitive hardware types.+type HType'   = PrimType HardwarePrimType++--------------------------------------------------------------------------------+-- ** Hardware expression symbols.++-- | For loop.+data ForLoop sig+  where+    ForLoop :: HType st =>+      ForLoop (Length :-> Length :-> st :-> (Index -> st -> st) :-> Full st)++deriving instance Eq       (ForLoop a)+deriving instance Show     (ForLoop a)+deriving instance Typeable (ForLoop a)++--------------------------------------------------------------------------------+-- ** Hardware expression symbols.++-- | Hardware symbols.+type HardwareConstructs =+          BindingT+  Syn.:+: Let+  Syn.:+: Tuple+  Syn.:+: HardwarePrimConstructs+  -- ^ Hardware specific symbol.+  Syn.:+: ForLoop++-- | Hardware symbols tagged with their type representation.+type HardwareDomain = HardwareConstructs :&: TypeRepF HardwarePrimType HardwarePrimTypeRep++-- | Hardware expressions.+newtype HExp a = HExp { unHExp :: ASTF HardwareDomain a }++-- | Evaluate a closed hardware expression.+eval :: (Syntactic a, Domain a ~ HardwareDomain) => a -> Internal a+eval = evalClosed . desugar++-- | Sugar a software symbol as a smart constructor.+sugarSymHardware+    :: ( Syn.Signature sig+       , fi  ~ SmartFun dom sig+       , sig ~ SmartSig fi+       , dom ~ SmartSym fi+       , dom ~ HardwareDomain+       , SyntacticN f fi+       , sub :<: HardwareConstructs+       , Type HardwarePrimType (DenResult sig)+       )+    => sub sig -> f+sugarSymHardware = sugarSymDecor $ ValT $ typeRep++-- | Sugar a software symbol as a smart primitive constructor.+sugarSymPrimHardware+    :: ( Syn.Signature sig+       , fi  ~ SmartFun dom sig+       , sig ~ SmartSig fi+       , dom ~ SmartSym fi+       , dom ~ HardwareDomain+       , SyntacticN f fi+       , sub :<: HardwareConstructs+       , HardwarePrimType (DenResult sig)+       )+    => sub sig -> f+sugarSymPrimHardware = sugarSymDecor $ ValT $ Node hardwareRep++--------------------------------------------------------------------------------++instance Syntactic (HExp a)+  where+    type Domain   (HExp a) = HardwareDomain+    type Internal (HExp a) = a++    desugar = unHExp+    sugar   = HExp++instance Syntactic (Struct HardwarePrimType HExp a)+  where+    type Domain   (Struct HardwarePrimType HExp a) = HardwareDomain+    type Internal (Struct HardwarePrimType HExp a) = a++    desugar (Node a)     = unHExp a+    desugar (Branch a b) = sugarSymDecor (ValT $ Branch ta tb) Pair a' b'+      where+        a' = desugar a+        b' = desugar b+        ValT ta = getDecor a'+        ValT tb = getDecor b'++    sugar a = case getDecor a of+      ValT (Node _)       -> Node $ HExp a+      ValT (Branch ta tb) -> Branch+        (sugarSymDecor (ValT ta) Fst a)+        (sugarSymDecor (ValT tb) Snd a)+      FunT _ _ -> error "Syntactic can't sugar a function."++instance Tuples HardwareDomain+  where+    pair   = sugarSymHardware Pair+    first  = sugarSymHardware Fst+    second = sugarSymHardware Snd++instance FreeExp HExp+  where+    type PredicateExp HExp = PrimType HardwarePrimType+    litE = sugarSymHardware . Lit+    varE = sugarSymHardware . FreeVar++--------------------------------------------------------------------------------+-- syntactic instances.++instance Eval ForLoop+  where+    evalSym ForLoop = \min max init body ->+        foldl (flip body) init [min..max]++instance Symbol ForLoop+  where+    symSig (ForLoop) = signature++instance Render ForLoop+  where+    renderSym  = show+    renderArgs = renderArgsSmart++instance EvalEnv ForLoop env++instance StringTree ForLoop++instance Equality ForLoop++--------------------------------------------------------------------------------+-- *** Temporary fix until GHC fixes their class resolution for DTC ***++instance {-# OVERLAPPING #-} Project sub HardwareConstructs =>+    Project sub (AST HardwareDomain)+  where+    prj (Sym s) = Syn.prj s+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project sub HardwareConstructs =>+    Project sub HardwareDomain+  where+    prj (expr :&: info) = Syn.prj expr++instance {-# OVERLAPPING #-} Project BindingT HardwareConstructs+  where+    prj (InjL a) = Just a+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project Let HardwareConstructs+  where+    prj (InjR (InjL a)) = Just a+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project Tuple HardwareConstructs+  where+    prj (InjR (InjR (InjL a))) = Just a+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project HardwarePrimConstructs HardwareConstructs+  where+    prj (InjR (InjR (InjR (InjL a)))) = Just a+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project ForLoop HardwareConstructs+  where+    prj (InjR (InjR (InjR (InjR a)))) = Just a+    prj _ = Nothing++--------------------------------------------------------------------------------
+ src/Feldspar/Hardware/Frontend.hs view
@@ -0,0 +1,535 @@+{-# language TypeFamilies          #-}+{-# language FlexibleInstances     #-}+{-# language FlexibleContexts      #-}+{-# language MultiParamTypeClasses #-}+{-# language UndecidableInstances  #-}+{-# language Rank2Types            #-}+{-# language ScopedTypeVariables   #-}++module Feldspar.Hardware.Frontend where++import Feldspar.Representation+import Feldspar.Frontend+import Feldspar.Sugar+import Feldspar.Array.Vector hiding (reverse)+import Feldspar.Array.Buffered (ArraysSwap(..))+import Feldspar.Hardware.Primitive+import Feldspar.Hardware.Expression+import Feldspar.Hardware.Representation+import Data.Struct++import Control.Monad.Identity (Identity)+import Data.Constraint hiding (Sub)+import Data.Int+import Data.List (genericLength)+import Data.Proxy+import Data.Typeable (Typeable)++-- syntactic.+import Language.Syntactic (Syntactic(..))+import Language.Syntactic.Functional+import qualified Language.Syntactic as Syntactic++-- operational-higher.+import qualified Control.Monad.Operational.Higher as Oper++-- hardware-edsl.+import Language.Embedded.Hardware.Command (Signal, Ident, Mode, ToIdent)+import qualified Language.Embedded.Hardware.Command   as Imp+import qualified Language.Embedded.Hardware.Interface as Imp+import qualified Language.Embedded.Hardware.Expression.Represent as Imp++import Prelude hiding (length, toInteger)+import qualified Prelude as P++--------------------------------------------------------------------------------+-- * Expressions.+--------------------------------------------------------------------------------++instance Value HExp+  where+    value = sugarSymHardware . Lit++instance Share HExp+  where+    share = sugarSymHardware (Let "")++instance Iterate HExp+  where+    loop = sugarSymHardware ForLoop++instance Cond HExp+  where+    cond = sugarSymHardware Cond++instance Equality HExp+  where+    (==) = sugarSymPrimHardware Eq++instance Ordered HExp+  where+    (<)  = sugarSymPrimHardware Lt+    (<=) = sugarSymPrimHardware Lte+    (>)  = sugarSymPrimHardware Gt+    (>=) = sugarSymPrimHardware Gte++instance Logical HExp+  where+    not  = sugarSymPrimHardware Not+    (&&) = sugarSymPrimHardware And+    (||) = sugarSymPrimHardware Or++instance Multiplicative HExp+  where+    mult = sugarSymPrimHardware Mul+    div  = sugarSymPrimHardware Div+    mod  = sugarSymPrimHardware Mod++instance Bitwise HExp+  where+    complement = sugarSymPrimHardware BitCompl+    (.&.) = sugarSymPrimHardware BitAnd+    (.|.) = sugarSymPrimHardware BitOr+    xor   = sugarSymPrimHardware BitXor+    sll   = sugarSymPrimHardware ShiftL+    srl   = sugarSymPrimHardware ShiftR+    rol   = sugarSymPrimHardware RotateL+    ror   = sugarSymPrimHardware RotateR++instance Casting HExp+  where+    i2n = sugarSymPrimHardware I2N+    i2b = error "hardware.todo: i2b"+    b2i = error "hardware.todo: b2i"++cast :: (HardwarePrimType a, HardwarePrimType b) => (a -> b) -> HExp a -> HExp b+cast f = sugarSymPrimHardware (Cast f)++toInteger :: (HardwarePrimType a, Integral a) => HExp a -> HExp Integer+toInteger = cast (fromIntegral)++toUnsigned :: (HardwarePrimType a, Integral a, HardwarePrimType b, Num b) => HExp a -> HExp b+toUnsigned = cast (fromIntegral)++toSigned :: (HardwarePrimType a, Integral a, HardwarePrimType b, Num b) => HExp a -> HExp b+toSigned = cast (fromIntegral)++{-+toBits :: (HardwarePrimType a, Integral a, KnownNat b) => HExp a -> HExp (Bits b)+toBits = cast (bitFrom+-}++toIntegral :: forall a . HardwarePrimType a => Proxy a -> HExp Integer -> HExp a+toIntegral _ = case hardwareRep :: HardwarePrimTypeRep a of+  IntegerHT -> id+  Int8HT    -> toSigned+  Int16HT   -> toSigned+  Int32HT   -> toSigned+  Int64HT   -> toSigned+  Word8HT   -> toUnsigned+  Word16HT  -> toUnsigned+  Word32HT  -> toUnsigned+  Word64HT  -> toUnsigned++--------------------------------------------------------------------------------++instance (Bounded a, HType a) => Bounded (HExp a)+  where+    minBound = value minBound+    maxBound = value maxBound++instance (Num a, HType' a) => Num (HExp a)+  where+    fromInteger = value . fromInteger+    (+)         = sugarSymHardware Add+    (-)         = sugarSymHardware Sub+    (*)         = sugarSymHardware Mul+    negate      = sugarSymHardware Neg+    abs         = error "abs not implemeted for `HExp`"+    signum      = error "signum not implemented for `HExp`"++--------------------------------------------------------------------------------+-- * Instructions.+--------------------------------------------------------------------------------++desugar :: (Syntactic a, Domain a ~ HardwareDomain) => a -> HExp (Internal a)+desugar = HExp . Syntactic.desugar++sugar   :: (Syntactic a, Domain a ~ HardwareDomain) => HExp (Internal a) -> a+sugar   = Syntactic.sugar . unHExp++resugar+  :: ( Syntactic a+     , Syntactic b+     , Internal a ~ Internal b+     , Domain a   ~ HardwareDomain+     , Domain b   ~ HardwareDomain+     )+  => a -> b+resugar = Syntactic.resugar++--------------------------------------------------------------------------------++instance References Hardware+  where+    type Reference Hardware = Ref    +    initRef    = Hardware . fmap Ref . mapStructA (Imp.initVariable) . resugar+    newRef     = Hardware . fmap Ref . mapStructA (const Imp.newVariable) $ typeRep+    getRef     = Hardware . fmap resugar . mapStructA getRef' . unRef+    setRef ref+      = Hardware+      . sequence_+      . zipListStruct setRef' (unRef ref)+      . resugar+    unsafeFreezeRef+      = Hardware+      . fmap resugar+      . mapStructA freezeRef'+      . unRef++-- 'Imp.getRef' specialized hardware.+getRef' :: forall b . HardwarePrimType b => Imp.Variable b -> Oper.Program HardwareCMD (Oper.Param2 HExp HardwarePrimType) (HExp b)+getRef' = withHType (Proxy :: Proxy b) Imp.getVariable++-- 'Imp.setRef' specialized to hardware.+setRef' :: forall b . HardwarePrimType b => Imp.Variable b -> HExp b -> Oper.Program HardwareCMD (Oper.Param2 HExp HardwarePrimType) ()+setRef' = withHType (Proxy :: Proxy b) Imp.setVariable++-- 'Imp.unsafeFreezeRef' specialized to hardware.+freezeRef' :: forall b . HardwarePrimType b => Imp.Variable b -> Oper.Program HardwareCMD (Oper.Param2 HExp HardwarePrimType) (HExp b)+freezeRef' = withHType (Proxy :: Proxy b) Imp.unsafeFreezeVariable++--------------------------------------------------------------------------------++instance Slicable HExp (Arr a)+  where+    slice from len (Arr o l arr) = Arr (o+from) len arr++instance Finite HExp (Arr a)+  where+    length = arrLength++instance Arrays Hardware+  where+    type Array Hardware = Arr+    newArr len+      = Hardware+      $ fmap (Arr 0 len)+      $ mapStructA (const (Imp.newVArray (toInteger len)))+      $ typeRep+    initArr as+      = Hardware+      $ fmap (Arr 0 len . Node)+      $ Imp.initVArray as+      where len = value $ genericLength as+    getArr arr ix+      = Hardware+      $ fmap resugar+      $ mapStructA (flip getArr' (ix + arrOffset arr))+      $ unArr arr+    setArr arr ix a+      = Hardware+      $ sequence_+      $ zipListStruct (\v a -> setArr' a (ix + arrOffset arr) v) (resugar a)+      $ unArr arr+    copyArr arr brr+      = Hardware+      $ sequence_+      $ zipListStruct (\a b ->+          Imp.copyVArray+            (a, toInteger (arrOffset arr))+            (b, toInteger (arrOffset brr))+            (toInteger (length brr)))+        (unArr arr)+        (unArr brr)++-- 'Imp.getVArr' specialized to hardware.+getArr' :: forall b . HardwarePrimType b => Imp.VArray b -> HExp Index -> Oper.Program HardwareCMD (Oper.Param2 HExp HardwarePrimType) (HExp b)+getArr' varr ix = withHType (Proxy :: Proxy b) $ Imp.getVArray varr (toInteger ix)++-- 'Imp.setVArr' specialized to hardware.+setArr' :: forall b . HardwarePrimType b => Imp.VArray b -> HExp Index -> HExp b -> Oper.Program HardwareCMD (Oper.Param2 HExp HardwarePrimType) ()+setArr' varr ix b = withHType (Proxy :: Proxy b) $ Imp.setVArray varr (toInteger ix) b++--------------------------------------------------------------------------------++instance Syntax HExp a => Indexed HExp (IArr a)+  where+    type ArrElem (IArr a) = a+    (!) (IArr off len a) ix = resugar $ mapStruct index a+      where+        index :: HardwarePrimType b => Imp.IArray b -> HExp b+        index arr = sugarSymPrimHardware (ArrIx arr) (toInteger (ix + off))++instance Slicable HExp (IArr a)+  where+    slice from len (IArr o l arr) = IArr (o+from) len arr++instance Finite HExp (IArr a)+  where+    length = iarrLength+      +instance IArrays Hardware+  where+    type IArray Hardware = IArr+    unsafeFreezeArr arr+      = Hardware+      $ fmap (IArr (arrOffset arr) (length arr))+      $ mapStructA (Imp.unsafeFreezeVArray)+      $ unArr arr+    unsafeThawArr iarr+      = Hardware+      $ fmap (Arr (iarrOffset iarr) (length iarr))+      $ mapStructA (Imp.unsafeThawVArray)+      $ unIArr iarr++--------------------------------------------------------------------------------++-- | Short-hand for hardware pull vectors.+type HPull a = Pull HExp a++-- | Short-hand for hardware push vectors.+type HPush a = Push Hardware a++-- | Short-hand for hardware manifest vectors.+type HManifest a = Manifest Hardware a++instance Syntax HExp (HExp a) => Pushy Hardware (IArr (HExp a)) (HExp a)+  where+    toPush iarr = toPush (M iarr :: Manifest Hardware (HExp a))++instance ViewManifest Hardware (IArr (HExp a)) (HExp a)+  where+    viewManifest = Just . M++instance Manifestable Hardware (IArr (HExp a)) (HExp a)    ++--------------------------------------------------------------------------------++instance Control Hardware+  where+    iff c t f+      = Hardware+      $ Imp.iff (resugar c)+          (unHardware t)+          (unHardware f)++-- todo: not synthesizable in general, fix to static ranges and add exit.+instance Loop Hardware+  where+    while c body+      = Hardware+      $ Imp.while+          (fmap resugar $ unHardware c)+          (unHardware body)+    for lower _ upper body+      = Hardware+      $ Imp.for+          (resugar (toInteger lower))+          (resugar (toInteger upper))+          (unHardware . body . resugar . toIntegral (proxyE lower))+      where+        proxyE :: forall a . HExp a -> Proxy a+        proxyE _ = Proxy++--------------------------------------------------------------------------------+-- ** Hardware instructions.+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- Singals.+--------------------------------------------------------------------------------++-- | Creates a new signal with a given initial value.+initSignal :: HType' a => HExp a -> Hardware (Signal a)+initSignal = Hardware . Imp.initSignal++-- | Creates a new signal.+newSignal :: HType' a => Hardware (Signal a)+newSignal = Hardware $ Imp.newSignal++-- | Get the current value of a signal.+getSignal :: HType' a => Signal a -> Hardware (HExp a)+getSignal = Hardware . Imp.getSignal++-- | Set the current value of a signal.+setSignal :: HType' a => Signal a -> HExp a -> Hardware ()+setSignal s = Hardware . (Imp.setSignal s)++-- | Unsafe version of fetching the contents of a signal.+unsafeFreezeSignal :: HType' a => Signal a -> Hardware (HExp a)+unsafeFreezeSignal = Hardware . Imp.unsafeFreezeSignal++-- | ...+veryUnsafeFreezeSignal :: HType' a => Signal a -> HExp a+veryUnsafeFreezeSignal (Imp.SignalC v) = Imp.varE v+veryUnsafeFreezeSignal _ = error "veryUnsafeFreezeSignal shouldn't be used during evaluation."++--------------------------------------------------------------------------------+-- Arrays.+--------------------------------------------------------------------------------++-- | Arrays based on signals.+type SArr a = Imp.Array a++-- | Creates a empty array of the given length.+newSArr :: HType' a => HExp Index -> Hardware (SArr a)+newSArr = Hardware . Imp.newArray . toInteger++-- | Initialize an array with the given elements.+initSArr :: HType' a => [a] -> Hardware (SArr a)+initSArr = Hardware . Imp.initArray++-- | Fetches the indexed element out of the array.+getSArr :: HType' a => SArr a -> HExp Index -> Hardware (HExp a)+getSArr arr ix = Hardware $ Imp.getArray arr (toInteger ix)++-- | Sets the indexed element of the array to the given value.+setSArr :: HType' a => SArr a -> HExp Index -> HExp a -> Hardware ()+setSArr arr ix val = Hardware $ Imp.setArray arr (toInteger ix) val++-- | ...+veryUnsafeFreezeSArr :: HType' a => Length -> SArr a -> IArr (HExp a)+veryUnsafeFreezeSArr len (Imp.ArrayC v) = IArr 0 (value len) $ Node $ Imp.IArrayC v+veryUnsafeFreezeSArr _ _ = error "veryUnsafeFreezeSArr shouldn't be used during evaluation."++--------------------------------------------------------------------------------+-- Components.+--------------------------------------------------------------------------------+-- todo: the `len` argument isn't strictly needed, the problem is that `IArr`+--       length is `HExp Length` while `Imp.copyArray` expects a pure `Length`.++-- | Hardware signature.+type HSig  = Imp.Sig HardwareCMD HExp HardwarePrimType Identity++--------------------------------------------------------------------------------++-- | Finalize signature with an output of a value.+ret :: forall a . (HType' a, Integral a) => Hardware (HExp a) -> HSig (Signal a -> ())+ret prg = withHType' (Proxy :: Proxy a) $ Imp.output $ \o -> Imp.ret $ Imp.process [] $ do+    v <- unHardware prg+    Imp.setSignal o v++retExpr :: forall a . (HType' a, Integral a) => HExp a -> HSig (Signal a -> ())+retExpr expr = ret (return expr)++-- | Finalize signature with an output of a immutable array.+retIArr :: forall a . (HType' a, Integral a) => Length -> Hardware (IArr (HExp a)) -> HSig (SArr a -> ())+retIArr len prg = withHType' (Proxy :: Proxy a) $+  Imp.outputArray (P.toInteger len) $ \o -> Imp.ret $ Imp.process [] $ do+    (IArr _ _ node) <- unHardware prg+    let iarr = case node of (Node iarr) -> iarr+    arr <- Imp.unsafeThawArray iarr+    Imp.copyArray (o,0) (arr,0) (value (P.toInteger len))++-- | Finalize signature with an output of an array.+retVArr :: forall a . (HType' a, Integral a) => Length -> Hardware (Arr (HExp a)) -> HSig (SArr a -> ())+retVArr len prg = withHType' (Proxy :: Proxy a) $+  Imp.outputArray (P.toInteger len) $ \o -> Imp.ret $ Imp.process [] $ do+    (Arr _ _ node) <- unHardware prg+    let arr = case node of (Node arr) -> arr+    iarr <- Imp.unsafeFreezeVArray arr -- this is so bad.+    brr  <- Imp.unsafeThawArray iarr+    Imp.copyArray (o,0) (brr, 0) (value (P.toInteger len))++--------------------------------------------------------------------------------++-- | Extend signature with an input signal.+input :: forall a b . (HType' a, Integral a) => (HExp a -> HSig b) -> HSig (Signal a -> b)+input f = withHType' (Proxy :: Proxy a) $+  Imp.input $ f . veryUnsafeFreezeSignal++-- | Extend signature with an input array.+inputIArr :: forall a b . (HType' a, Integral a) => Length -> (IArr (HExp a) -> HSig b) -> HSig (SArr a -> b)+inputIArr len f = withHType' (Proxy :: Proxy a) $+  Imp.inputArray (P.toInteger len) $ f . veryUnsafeFreezeSArr len++-- inputVec :: forall a b . (HType' a, Integral a) => Lenght -> () -> HSig (SArr a -> b)+++--------------------------------------------------------------------------------+--+--------------------------------------------------------------------------------++-- Swap an `Imp.FreePred` constraint with a `HardwarePrimType` one.+withHType :: forall a b . Proxy a+  -> (Imp.PredicateExp HExp a => b)+  -> (HardwarePrimType a => b)+withHType _ f = let rep = hardwareRep :: HardwarePrimTypeRep a in+  case predicateDict rep of+    Dict -> f++withHType' :: forall a b . Proxy a+  -> (Imp.Inhabited a => Imp.Sized a => Imp.PrimType a => b)+  -> (HardwarePrimType a => b)+withHType' _ f = let rep = hardwareRep :: HardwarePrimTypeRep a in+  case (inhabitedDict rep, sizedDict rep, repDict rep) of+    (Dict, Dict, Dict) -> f++-- Proves that a `HardwarePrimTypeRep a` type satisfies `Imp.FreePred`.+predicateDict :: HardwarePrimTypeRep a -> Dict (Imp.PredicateExp HExp a)+predicateDict rep = case rep of+  BoolHT    -> Dict+  IntegerHT -> Dict+  Int8HT    -> Dict+  Int16HT   -> Dict+  Int32HT   -> Dict+  Int64HT   -> Dict+  Word8HT   -> Dict+  Word16HT  -> Dict+  Word32HT  -> Dict+  Word64HT  -> Dict++inhabitedDict :: HardwarePrimTypeRep a -> Dict (Imp.Inhabited a)+inhabitedDict rep = case rep of+  BoolHT    -> Dict+  IntegerHT -> Dict+  Int8HT    -> Dict+  Int16HT   -> Dict+  Int32HT   -> Dict+  Int64HT   -> Dict+  Word8HT   -> Dict+  Word16HT  -> Dict+  Word32HT  -> Dict+  Word64HT  -> Dict++sizedDict :: HardwarePrimTypeRep a -> Dict (Imp.Sized a)+sizedDict rep = case rep of+  BoolHT    -> Dict+  Int8HT    -> Dict+  Int16HT   -> Dict+  Int32HT   -> Dict+  Int64HT   -> Dict+  Word8HT   -> Dict+  Word16HT  -> Dict+  Word32HT  -> Dict+  Word64HT  -> Dict+  t         -> error ("predicateDict failed for " Prelude.++ show t)++repDict :: HardwarePrimTypeRep a -> Dict (Imp.PrimType a)+repDict rep = case rep of+  BoolHT    -> Dict+  IntegerHT -> Dict+  Int8HT    -> Dict+  Int16HT   -> Dict+  Int32HT   -> Dict+  Int64HT   -> Dict+  Word8HT   -> Dict+  Word16HT  -> Dict+  Word32HT  -> Dict+  Word64HT  -> Dict++typeableDict :: HardwarePrimTypeRep a -> Dict (Typeable a)+typeableDict rep = case rep of+  BoolHT    -> Dict+  IntegerHT -> Dict+  Int8HT    -> Dict+  Int16HT   -> Dict+  Int32HT   -> Dict+  Int64HT   -> Dict+  Word8HT   -> Dict+  Word16HT  -> Dict+  Word32HT  -> Dict+  Word64HT  -> Dict++--------------------------------------------------------------------------------
+ src/Feldspar/Hardware/Optimize.hs view
@@ -0,0 +1,310 @@+{-# language GADTs               #-}+{-# language TypeOperators       #-}+{-# language PatternSynonyms     #-}+{-# language ViewPatterns        #-}+{-# language FlexibleContexts    #-}+{-# language ScopedTypeVariables #-}++module Feldspar.Hardware.Optimize where++import Feldspar.Representation+import Feldspar.Hardware.Primitive+import Feldspar.Hardware.Expression+import Data.Struct++import Control.Monad.Writer hiding (Any (..))+import Data.Maybe+import Data.Constraint (Dict (..))+import Data.Set (Set)+import qualified Data.Monoid as Monoid+import qualified Data.Set as Set++-- syntactic.+import Language.Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Tuple+import Language.Syntactic.Functional.Sharing++--------------------------------------------------------------------------------+-- * Optimize hardware expressions.+--------------------------------------------------------------------------------++viewLit :: ASTF HardwareDomain a -> Maybe a+viewLit lit | Just (Lit a) <- prj lit = Just a+viewLit _ = Nothing++witInteger :: ASTF HardwareDomain a -> Maybe (Dict (Integral a, Ord a))+witInteger a = case getDecor a of+  ValT (Node Int8HT)   -> Just Dict+  ValT (Node Int16HT)  -> Just Dict+  ValT (Node Int32HT)  -> Just Dict+  ValT (Node Int64HT)  -> Just Dict+  ValT (Node Word8HT)  -> Just Dict+  ValT (Node Word16HT) -> Just Dict+  ValT (Node Word32HT) -> Just Dict+  ValT (Node Word64HT) -> Just Dict+  _ -> Nothing++isExact :: ASTF HardwareDomain a -> Bool+isExact = isJust . witInteger++-- | projection with a stronger constraint to allow using it in+--   bidirectional patterns.+prjBi :: (sub :<: sup) => sup sig -> Maybe (sub sig)+prjBi = prj+++--------------------------------------------------------------------------------++pattern SymP t s <- Sym ((prjBi -> Just s) :&: ValT t)+  where+    SymP t s = Sym ((inj s) :&: ValT t)++pattern VarP t v <- Sym ((prjBi -> Just (VarT v)) :&: t)+  where+    VarP t v = Sym (inj (VarT v) :&: t)++pattern LamP t v body <- Sym ((prjBi -> Just (LamT v)) :&: t) :$ body+  where+    LamP t v body = Sym (inj (LamT v) :&: t) :$ body+++--------------------------------------------------------------------------------++pattern LitP :: () => (Eq a, Show a)+  => HTypeRep a -> a -> ASTF HardwareDomain a+  +pattern AddP :: () => (Num a, HardwarePrimType a)+  => HTypeRep a -> ASTF HardwareDomain a -> ASTF HardwareDomain a+  -> ASTF HardwareDomain a++pattern SubP :: () => (Num a, HardwarePrimType a)+  => HTypeRep a -> ASTF HardwareDomain a -> ASTF HardwareDomain a+  -> ASTF HardwareDomain a++pattern MulP :: () => (Num a, HardwarePrimType a)+  => HTypeRep a -> ASTF HardwareDomain a -> ASTF HardwareDomain a+  -> ASTF HardwareDomain a++pattern NegP :: () => (Num a, HardwarePrimType a)+  => HTypeRep a -> ASTF HardwareDomain a -> ASTF HardwareDomain a++pattern DivP :: () => (Integral a, HardwarePrimType a)+  => HTypeRep a -> ASTF HardwareDomain a -> ASTF HardwareDomain a+  -> ASTF HardwareDomain a++pattern ModP :: () => (Integral a, HardwarePrimType a)+  => HTypeRep a -> ASTF HardwareDomain a -> ASTF HardwareDomain a+  -> ASTF HardwareDomain a+++--------------------------------------------------------------------------------++pattern NonLitP <- (viewLit -> Nothing)++pattern LitP t a <- Sym ((prj -> Just (Lit a)) :&: ValT t)+  where+    LitP t a = Sym (inj (Lit a) :&: ValT t)++pattern AddP t a b <- SymP t Add :$ a :$ b+  where+    AddP t a b = simplifyUp $ SymP t Add :$ a :$ b+  +pattern SubP t a b <- SymP t Sub :$ a :$ b+  where+    SubP t a b = simplifyUp $ SymP t Sub :$ a :$ b++pattern MulP t a b <- SymP t Mul :$ a :$ b+  where+    MulP t a b = simplifyUp $ SymP t Mul :$ a :$ b++pattern NegP t a <- SymP t Neg :$ a+  where+    NegP t a = simplifyUp $ SymP t Neg :$ a++pattern DivP t a b <- SymP t Div :$ a :$ b+  where+    DivP t a b = simplifyUp $ SymP t Div :$ a :$ b++pattern ModP t a b <- SymP t Mod :$ a :$ b+  where+    ModP t a b = simplifyUp $ SymP t Mod :$ a :$ b+++--------------------------------------------------------------------------------++simplifyUp :: ASTF HardwareDomain a -> ASTF HardwareDomain a+-- Addition with zero.+simplifyUp (AddP t (LitP _ 0) b) | isExact b = b+simplifyUp (AddP t a (LitP _ 0)) | isExact a = a+-- Simplify additions with literals.+simplifyUp (AddP t (AddP _ a (LitP _ b)) (LitP _ c)) | isExact a+  = AddP t a (LitP t (b+c))+simplifyUp (AddP t (SubP _ a (LitP _ b)) (LitP _ c)) | isExact a+  = AddP t a (LitP t (c-b))+simplifyUp (AddP t a (LitP _ b)) | Just Dict <- witInteger a, b < 0+  = SubP t a (LitP t (negate b))+-- Subtraction with zero.+simplifyUp (SubP t (LitP _ 0) b) | isExact b = NegP t b+simplifyUp (SubP t a (LitP _ 0)) | isExact a = a+-- Simplify subtractions with literals.+simplifyUp (SubP t (AddP _ a (LitP _ b)) (LitP _ c)) | isExact a+  = AddP t a (LitP t (b-c))+simplifyUp (SubP t (SubP _ a (LitP _ b)) (LitP _ c)) | isExact a+  = SubP t a (LitP t (b+c))+simplifyUp (SubP t a (LitP _ b)) | Just Dict <- witInteger a, b < 0+  = AddP t a (LitP t (negate b))+-- Multiplication with zero.+simplifyUp (MulP t (LitP _ 0) b) | isExact b = LitP t 0+simplifyUp (MulP t a (LitP _ 0)) | isExact a = LitP t 0+-- Multiplication with one.+simplifyUp (MulP t (LitP _ 1) b) | isExact b = b+simplifyUp (MulP t a (LitP _ 1)) | isExact a = a+-- Simplify multiplications with literals.+simplifyUp (MulP t (MulP _ a (LitP _ b)) (LitP _ c)) | isExact a+  = MulP t a (LitP t (b*c))+-- Simplify negations.+simplifyUp (NegP t (NegP _ a))   | isExact a = a+simplifyUp (NegP t (AddP _ a b)) | isExact a = SubP t (NegP t a) b+simplifyUp (NegP t (SubP _ a b)) | isExact a = SubP t b a+simplifyUp (NegP t (MulP _ a b)) | isExact a = MulP t a (NegP t b)+-- Move literals to the right.+simplifyUp (AddP t a@(LitP _ _) b@NonLitP) | isExact a = AddP t b a+simplifyUp (SubP t a@(LitP _ _) b@NonLitP) | isExact a = AddP t (NegP t b) a+simplifyUp (MulP t a@(LitP _ _) b@NonLitP) | isExact a = MulP t b a+-- Simplify not-expressions.+-- Not sure (yet) why I can't write `simplifyUp (NotP _ (NotP _ a)) = a`+simplifyUp (SymP _ Not :$ (SymP _ Not :$ a)) = a+simplifyUp (SymP t Not :$ (SymP _ Lt :$ a :$ b))+  = simplifyUp $ SymP t Gte :$ a :$ b+simplifyUp (SymP t Not :$ (SymP _ Gt :$ a :$ b))+  = simplifyUp $ SymP t Lte :$ a :$ b+simplifyUp (SymP t Not :$ (SymP _ Lte :$ a :$ b))+  = simplifyUp $ SymP t Gt :$ a :$ b+simplifyUp (SymP t Not :$ (SymP _ Gte :$ a :$ b))+  = simplifyUp $ SymP t Lt :$ a :$ b+-- Simplify and-expressions.+simplifyUp (SymP _ And :$ LitP t False :$ _) = LitP t False+simplifyUp (SymP _ And :$ _ :$ LitP t False) = LitP t False+simplifyUp (SymP _ And :$ LitP t True :$ b)  = b+simplifyUp (SymP _ And :$ a :$ LitP t True)  = a+-- Simplify or-expressions.+simplifyUp (SymP _ Or :$ LitP t False :$ b) = b+simplifyUp (SymP _ Or :$ a :$ LitP t False) = a+simplifyUp (SymP _ Or :$ LitP t True :$ _)  = LitP t True+simplifyUp (SymP _ Or :$ _ :$ LitP t True)  = LitP t True+-- Simplify conditional expressions.+simplifyUp (SymP _ Cond :$ LitP _ True  :$ t :$ _)  = t+simplifyUp (SymP _ Cond :$ LitP _ False :$ _ :$ f)  = f+simplifyUp (SymP _ Cond :$ c :$ t :$ f) | equal t f = t+-- Simplify pairs.+simplifyUp (SymP t Pair :$ (SymP _ Fst :$ a) :$ (SymP _ Snd :$ b))+    | alphaEq a b+    , ValT t' <- getDecor a+    , Just Dict <- hardwareTypeEq t t' = a+simplifyUp (SymP t Fst :$ (SymP _ Pair :$ a :$ _)) = a+simplifyUp (SymP t Snd :$ (SymP _ Pair :$ _ :$ a)) = a+-- +simplifyUp a = constFold a+  -- `constFold` here ensures that `simplifyUp` does not produce any expressions+  -- that can be statically constant folded. This property is needed, e.g. to+  -- fully simplify the expression `negate (2*x)`. The simplification should go+  -- as follows:+  --+  --     negate (2*x)  ->  negate (x*2)  ->  x * negate 2  ->  x*(-2)+  --+  -- There is no explicit rule for the last step; it is done by `constFold`.+  -- Furthermore, this constant folding would not be performed by `simplifyM`+  -- since it never sees the sub-expression `negate 2`. (Note that the constant+  -- folding in `simplifyM` is still needed, because constructs such as+  -- `ForLoop` cannot be folded by simple literal propagation.)+  --+  -- In order to see that `simplifyUp` doesn't produce any "junk"+  -- (sub-expressions that can be folded by `constFold`), we reason as follows:+  --+  --   * Assume that the arguments of the top-level node are junk-free+  --   * `simplifyUp` will either apply an explicit rewrite or apply `constFold`+  --   * In the latter case, the result will be junk-free+  --   * In case of an explicit rewrite, the resulting expression is constructed+  --     by applying `simplifyUp` to each newly introduced node; thus the+  --     resulting expression must be junk-free+++--------------------------------------------------------------------------------++-- | Reduce an expression to a literal if the following conditions are met:+--+-- * The top-most symbol can be evaluated statically (i.g. not a variable or a+--   lifted side-effecting program)+-- * All immediate sub-terms are literals+-- * The type of the expression is an allowed type for literals (e.g. not a+--   function)+--+-- Note that this function only folds the top-level node of an expressions (if+-- possible). It does not reduce an expression like @1+(2+3)@ where the+-- sub-expression @2+3@ is not a literal.+constFold :: ASTF HardwareDomain a -> ASTF HardwareDomain a+constFold e+    | constArgs e, canFold e, ValT t@(Node _) <- getDecor e+    = LitP t (evalClosed e)+  where+    canFold :: ASTF HardwareDomain a -> Bool+    canFold = simpleMatch (\(s :&: ValT _) _ -> go s)+      where+        go :: HardwareConstructs sig+           -> Bool+        go var | Just (FreeVar _)         <- prj var = False+        go ix  | Just (ArrIx _)           <- prj ix  = False+        go bid | Just (_ :: BindingT sig) <- prj bid = False+        go _   = True+constFold e = e++-- | Check whether all arguments of a symbol are literals+constArgs :: AST HardwareDomain sig -> Bool+constArgs (Sym _)         = True+constArgs (s :$ LitP _ _) = constArgs s+constArgs _               = False+++--------------------------------------------------------------------------------++type Opt = Writer (Set Name, Monoid.Any)++freeVar :: Name -> Opt ()+freeVar v = tell (Set.singleton v, mempty)++bindVar :: Name -> Opt a -> Opt a+bindVar v = censor (\(vars, unsafe) -> (Set.delete v vars, unsafe))++tellUnsafe :: Opt ()+tellUnsafe = tell (mempty, Monoid.Any True)++simplifyM :: ASTF HardwareDomain a -> Opt (ASTF HardwareDomain a)+simplifyM exp = case exp of+    (VarP _ v)      -> freeVar v >> return exp+    (LamP t v body) -> bindVar v $ fmap (LamP t v) $ simplifyM body+    _               -> simpleMatch (\s@(v :&: t) args ->+      do (exp', (vars, Monoid.Any unsafe)) <- listen+           (simplifyUp . appArgs (Sym s) <$> mapArgsM simplifyM args)+         case () of+           _ | Just (FreeVar _) <- prj v -> tellUnsafe >> return exp'+           _ | Just (ArrIx _)   <- prj v -> tellUnsafe >> return exp'+           _ | null vars && not unsafe, ValT t'@(Node _) <- t+             -> return $ LitP t' $ evalClosed exp'+           _ -> return exp'+      )+      exp+  -- Array indexing is actually not unsafe. It's more like+  -- an expression with a free variable. But setting the+  -- unsafe flag does the trick.+  -- Constant fold if expression is closed and does not+  -- contain unsafe operations.+++--------------------------------------------------------------------------------++optimize :: ASTF HardwareDomain a -> ASTF HardwareDomain a+optimize = fst . runWriter . simplifyM+++--------------------------------------------------------------------------------
+ src/Feldspar/Hardware/Primitive.hs view
@@ -0,0 +1,399 @@+{-# language GADTs #-}+{-# language StandaloneDeriving #-}+{-# language TypeOperators #-}+{-# language FlexibleInstances #-}+{-# language FlexibleContexts #-}+{-# language UndecidableInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language TypeFamilies #-}++{-# language Rank2Types #-}+{-# language ScopedTypeVariables #-}++{-# options_ghc -fwarn-incomplete-patterns #-}++module Feldspar.Hardware.Primitive where++import Feldspar.Representation+import Data.Struct++import Data.Array ((!))+import Data.Bits (Bits)+import Data.Int+import Data.Word+import Data.List (genericTake)+import Data.Typeable hiding (TypeRep)+import Data.Constraint hiding (Sub)+import qualified Data.Bits as Bits++-- syntactic.+import Language.Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Tuple++-- hardware-edsl.+import Language.Embedded.Hardware.Interface+import qualified Language.Embedded.Hardware.Expression.Represent.Bit as Imp (Bits)+import qualified Language.Embedded.Hardware.Expression.Frontend  as Imp+import qualified Language.Embedded.Hardware.Expression.Represent as Imp+import qualified Language.Embedded.Hardware.Command as Imp (IArray(..))++import GHC.TypeLits (KnownNat)++--------------------------------------------------------------------------------+-- * Hardware primitives.+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- * Hardware primitive types.++-- | Representation of supported, primitive software types.+data HardwarePrimTypeRep a+  where+    -- booleans+    BoolHT    :: HardwarePrimTypeRep Bool+    -- integers+    IntegerHT :: HardwarePrimTypeRep Integer+    -- signed numbers.+    Int8HT    :: HardwarePrimTypeRep Int8+    Int16HT   :: HardwarePrimTypeRep Int16+    Int32HT   :: HardwarePrimTypeRep Int32+    Int64HT   :: HardwarePrimTypeRep Int64+    -- unsigned numbers.+    Word8HT   :: HardwarePrimTypeRep Word8+    Word16HT  :: HardwarePrimTypeRep Word16+    Word32HT  :: HardwarePrimTypeRep Word32+    Word64HT  :: HardwarePrimTypeRep Word64+    -- bits.+    BitsHT    :: KnownNat n => HardwarePrimTypeRep (Imp.Bits n)++deriving instance Eq       (HardwarePrimTypeRep a)+deriving instance Show     (HardwarePrimTypeRep a)+deriving instance Typeable (HardwarePrimTypeRep a)++--------------------------------------------------------------------------------++-- | Class of supported, primitive hardware types.+class (Eq a, Show a, Typeable a, Inhabited a) => HardwarePrimType a+  where+    hardwareRep :: HardwarePrimTypeRep a++instance HardwarePrimType Bool    where hardwareRep = BoolHT+instance HardwarePrimType Integer where hardwareRep = IntegerHT+instance HardwarePrimType Int8    where hardwareRep = Int8HT+instance HardwarePrimType Int16   where hardwareRep = Int16HT+instance HardwarePrimType Int32   where hardwareRep = Int32HT+instance HardwarePrimType Int64   where hardwareRep = Int64HT+instance HardwarePrimType Word8   where hardwareRep = Word8HT+instance HardwarePrimType Word16  where hardwareRep = Word16HT+instance HardwarePrimType Word32  where hardwareRep = Word32HT+instance HardwarePrimType Word64  where hardwareRep = Word64HT++instance KnownNat n => HardwarePrimType (Imp.Bits n)+  where+    hardwareRep = BitsHT++-- | Compare two primitive hardware types for equality.+hardwarePrimTypeEq :: HardwarePrimTypeRep a -> HardwarePrimTypeRep b -> Maybe (Dict (a ~ b))+hardwarePrimTypeEq (BoolHT)    (BoolHT)    = Just Dict+hardwarePrimTypeEq (IntegerHT) (IntegerHT) = Just Dict+hardwarePrimTypeEq (Int8HT)    (Int8HT)    = Just Dict+hardwarePrimTypeEq (Int16HT)   (Int16HT)   = Just Dict+hardwarePrimTypeEq (Int32HT)   (Int32HT)   = Just Dict+hardwarePrimTypeEq (Int64HT)   (Int64HT)   = Just Dict+hardwarePrimTypeEq (Word8HT)   (Word8HT)   = Just Dict+hardwarePrimTypeEq (Word16HT)  (Word16HT)  = Just Dict+hardwarePrimTypeEq (Word32HT)  (Word32HT)  = Just Dict+hardwarePrimTypeEq (Word64HT)  (Word64HT)  = Just Dict+hardwarePrimTypeEq _           _           = Nothing++-- | Construct the primitive hardware type representation of 'a'.+hardwarePrimTypeOf :: HardwarePrimType a => a -> HardwarePrimTypeRep a+hardwarePrimTypeOf _ = hardwareRep++-- | Construct a primitive hardware type witness from its representation.+hardwarePrimWitType :: HardwarePrimTypeRep a -> Dict (HardwarePrimType a)+hardwarePrimWitType BoolHT    = Dict+hardwarePrimWitType IntegerHT = Dict+hardwarePrimWitType Int8HT    = Dict+hardwarePrimWitType Int16HT   = Dict+hardwarePrimWitType Int32HT   = Dict+hardwarePrimWitType Int64HT   = Dict+hardwarePrimWitType Word8HT   = Dict+hardwarePrimWitType Word16HT  = Dict+hardwarePrimWitType Word32HT  = Dict+hardwarePrimWitType Word64HT  = Dict+hardwarePrimWitType BitsHT    = Dict++--------------------------------------------------------------------------------+-- ** Hardware primitive expressions.++-- | Hardware primitive symbols.+data HardwarePrim sig+  where+    -- ^ free variables and literals.+    FreeVar :: (HardwarePrimType a) => String -> HardwarePrim (Full a)+    Lit     :: (Show a, Eq a)       => a      -> HardwarePrim (Full a)++    -- ^ type casting.+    Cast :: (HardwarePrimType a, HardwarePrimType b)+      => (a -> b) -> HardwarePrim (a :-> Full b)+    I2N :: (HardwarePrimType a, Integral a, HardwarePrimType b, Num b)+      => HardwarePrim (a :-> Full b)+    +    -- ^ conditional+    Cond :: HardwarePrim (Bool :-> a :-> a :-> Full a)+    +    -- ^ array indexing.+    ArrIx :: (HardwarePrimType a)+      => Imp.IArray a -> HardwarePrim (Integer :-> Full a)+            +    -- ^ numerical operations.+    Neg :: (HardwarePrimType a, Num a) => HardwarePrim (a :-> Full a)+    Add :: (HardwarePrimType a, Num a) => HardwarePrim (a :-> a :-> Full a)+    Sub :: (HardwarePrimType a, Num a) => HardwarePrim (a :-> a :-> Full a)+    Mul :: (HardwarePrimType a, Num a) => HardwarePrim (a :-> a :-> Full a)++    -- ^ integral operations.+    Div :: (HardwarePrimType a, Integral a) => HardwarePrim (a :-> a :-> Full a)+    Mod :: (HardwarePrimType a, Integral a) => HardwarePrim (a :-> a :-> Full a)++    -- ^ logical operations.+    Not :: HardwarePrim (Bool :-> Full Bool)+    And :: HardwarePrim (Bool :-> Bool :-> Full Bool)+    Or  :: HardwarePrim (Bool :-> Bool :-> Full Bool)++    -- ^ bitwise logical operations.+    BitAnd   :: (HardwarePrimType a, Bits a) => HardwarePrim (a :-> a :-> Full a)+    BitOr    :: (HardwarePrimType a, Bits a) => HardwarePrim (a :-> a :-> Full a)+    BitXor   :: (HardwarePrimType a, Bits a) => HardwarePrim (a :-> a :-> Full a)+    BitCompl :: (HardwarePrimType a, Bits a) => HardwarePrim (a :-> Full a)+    ShiftL   :: (HardwarePrimType a, Bits a, HardwarePrimType b, Integral b)+      => HardwarePrim (a :-> b :-> Full a)+    ShiftR   :: (HardwarePrimType a, Bits a, HardwarePrimType b, Integral b)+      => HardwarePrim (a :-> b :-> Full a)+    RotateL  :: (HardwarePrimType a, Bits a, HardwarePrimType b, Integral b)+      => HardwarePrim (a :-> b :-> Full a)+    RotateR  :: (HardwarePrimType a, Bits a, HardwarePrimType b, Integral b)+      => HardwarePrim (a :-> b :-> Full a)+    +    -- ^ relational operations.+    Eq  :: (HardwarePrimType a, Eq a)  => HardwarePrim (a :-> a :-> Full Bool)+    Lt  :: (HardwarePrimType a, Ord a) => HardwarePrim (a :-> a :-> Full Bool)+    Lte :: (HardwarePrimType a, Ord a) => HardwarePrim (a :-> a :-> Full Bool)+    Gt  :: (HardwarePrimType a, Ord a) => HardwarePrim (a :-> a :-> Full Bool)+    Gte :: (HardwarePrimType a, Ord a) => HardwarePrim (a :-> a :-> Full Bool)++deriving instance Show     (HardwarePrim a)+deriving instance Typeable (HardwarePrim a)++--------------------------------------------------------------------------------++-- | Hardware primitive symbols.+type HardwarePrimConstructs = HardwarePrim++-- | Hardware primitive symbols tagged with their type representation.+type HardwarePrimDomain = HardwarePrimConstructs :&: HardwarePrimTypeRep++-- | Hardware primitive expressions.+newtype Prim a = Prim { unPrim :: ASTF HardwarePrimDomain a }++-- | Evaluate a closed, hardware primitive expression.+evalPrim :: Prim a -> a+evalPrim = go . unPrim+  where+    go :: AST HardwarePrimDomain sig -> Denotation sig+    go (Sym (s :&: _)) = evalSym s+    go (f :$ a)        = go f $ go a++-- | Sugar a hardware primitive symbol as a smart constructor.+sugarSymPrim+  :: ( Signature sig+     , fi  ~ SmartFun dom sig+     , sig ~ SmartSig fi+     , dom ~ SmartSym fi+     , dom ~ HardwarePrimDomain+     , SyntacticN f fi+     , sub :<: HardwarePrimConstructs+     , HardwarePrimType (DenResult sig)+     )+  => sub sig -> f+sugarSymPrim = sugarSymDecor hardwareRep++--------------------------------------------------------------------------------++instance Syntactic (Prim a)+  where+    type Domain   (Prim a) = HardwarePrimDomain+    type Internal (Prim a) = a+    desugar = unPrim+    sugar   = Prim++instance FreeExp Prim+  where+    type PredicateExp Prim = HardwarePrimType+    litE = sugarSymPrim . Lit+    varE = sugarSymPrim . FreeVar++instance EvaluateExp Prim+  where+    evalE = evalPrim++--------------------------------------------------------------------------------+-- front-end.++instance (HardwarePrimType a, Num a) => Num (Prim a)+  where+    fromInteger = litE . fromInteger+    (+)         = sugarSymPrim Add+    (-)         = sugarSymPrim Sub+    (*)         = sugarSymPrim Mul+    negate      = sugarSymPrim Neg+    abs         = error "Num (Prim a): abs."+    signum      = error "Num (Prim a): signum."++--------------------------------------------------------------------------------+-- hardware expressions needed for 'compileAXI', I'll make them prettier later.++instance Imp.Expr Prim+  where+    true  = litE True+    false = litE False+    and   = sugarSymPrim And+    or    = sugarSymPrim Or+    xor   = error "todo: prim xor"+    xnor  = error "todo: prim xnor"+    nand  = error "todo: prim nand"+    nor   = error "todo: prim nor"++instance Imp.Rel Prim+  where+    eq (a :: Prim a) (b :: Prim a) =+      case primDict (Imp.typeRep :: Imp.TypeRep a) of+        Dict -> sugarSymPrim Eq a b+    neq a b = Imp.not (Imp.eq a b)+    lt  (a :: Prim a) (b :: Prim a) =+      case primDict (Imp.typeRep :: Imp.TypeRep a) of+        Dict -> sugarSymPrim Lt a b+    lte (a :: Prim a) (b :: Prim a) =+      case primDict (Imp.typeRep :: Imp.TypeRep a) of+        Dict -> sugarSymPrim Lte a b+    gt  (a :: Prim a) (b :: Prim a) =+      case primDict (Imp.typeRep :: Imp.TypeRep a) of+        Dict -> sugarSymPrim Gt a b+    gte (a :: Prim a) (b :: Prim a) =+      case primDict (Imp.typeRep :: Imp.TypeRep a) of+        Dict -> sugarSymPrim Gte a b++instance Imp.Factor Prim+  where+    exp = error "todo: prim exp."+    abs = error "todo: prim abs."+    not = sugarSymPrim Not++instance Imp.Primary Prim+  where+    value (a :: a) = +      case primDict (Imp.typeRep :: Imp.TypeRep a) of+        Dict -> sugarSymPrim (Lit a)+    name  = error "todo: prim name."+    cast (f :: a -> b) (a :: Prim a)  =+      case ( primDict (Imp.typeRep :: Imp.TypeRep a)+           , primDict (Imp.typeRep :: Imp.TypeRep b))+      of+        (Dict, Dict) -> sugarSymPrim (Cast f) a++primDict :: Imp.TypeRep a -> Dict (HardwarePrimType a)+primDict rep = case rep of+  Imp.BoolT    -> Dict+  Imp.Int8T    -> Dict+  Imp.Int16T   -> Dict+  Imp.Int32T   -> Dict+  Imp.Int64T   -> Dict+  Imp.Word8T   -> Dict+  Imp.Word16T  -> Dict+  Imp.Word32T  -> Dict+  Imp.Word64T  -> Dict+  Imp.IntegerT -> Dict+  Imp.BitsT    -> Dict+  _            -> error "todo: primDict."++--------------------------------------------------------------------------------+-- syntactic instances.++instance Eval HardwarePrim+  where+    evalSym (FreeVar v) = error $ "evaluating free variable " ++ show v+    evalSym (Lit a)     = a+    evalSym Cond        = \c t f -> if c then t else f+    evalSym Neg         = negate+    evalSym Add         = (+)+    evalSym Sub         = (-)+    evalSym Mul         = (*)+    evalSym Div         = div+    evalSym Mod         = mod+    evalSym (Cast f)    = f+    evalSym I2N         = fromIntegral+    evalSym Not         = not+    evalSym And         = (&&)+    evalSym Or          = (||)+    evalSym BitAnd      = (Bits..&.)+    evalSym BitOr       = (Bits..|.)+    evalSym BitXor      = Bits.xor+    evalSym BitCompl    = Bits.complement+    evalSym ShiftL      = \b i -> Bits.shiftL  b (fromIntegral i)+    evalSym ShiftR      = \b i -> Bits.shiftR  b (fromIntegral i)+    evalSym RotateL     = \b i -> Bits.rotateL b (fromIntegral i)+    evalSym RotateR     = \b i -> Bits.rotateR b (fromIntegral i)+    evalSym Eq          = (==)+    evalSym Lt          = (<)+    evalSym Lte         = (<=)+    evalSym Gt          = (>)+    evalSym Gte         = (>=)+    evalSym (ArrIx (Imp.IArrayE a)) = \i -> a ! toInteger i+    evalSym (ArrIx _)   = error "eval of array variable"++instance Symbol HardwarePrim+  where+    symSig (FreeVar v) = signature+    symSig (Lit a)     = signature+    symSig Cond        = signature+    symSig Neg         = signature+    symSig Add         = signature+    symSig Sub         = signature+    symSig Mul         = signature+    symSig Div         = signature+    symSig Mod         = signature+    symSig (Cast f)    = signature+    symSig I2N         = signature+    symSig Not         = signature+    symSig And         = signature+    symSig Or          = signature+    symSig BitAnd      = signature+    symSig BitOr       = signature+    symSig BitXor      = signature+    symSig BitCompl    = signature+    symSig ShiftL      = signature+    symSig ShiftR      = signature+    symSig RotateL     = signature+    symSig RotateR     = signature+    symSig Eq          = signature+    symSig Lt          = signature+    symSig Lte         = signature+    symSig Gt          = signature+    symSig Gte         = signature+    symSig (ArrIx a)   = signature++instance Render HardwarePrim+  where+    renderSym  = show+    renderArgs = renderArgsSmart++instance Equality HardwarePrim+  where+    equal s1 s2 = show s1 == show s2++instance StringTree HardwarePrim+instance EvalEnv HardwarePrim env++--------------------------------------------------------------------------------
+ src/Feldspar/Hardware/Primitive/Backend.hs view
@@ -0,0 +1,262 @@+{-# language GADTs #-}+{-# language QuasiQuotes #-}+{-# language ScopedTypeVariables #-}+{-# language FlexibleContexts #-}++{-# language PolyKinds #-}++module Feldspar.Hardware.Primitive.Backend where++import Feldspar.Hardware.Primitive++import Data.Constraint (Dict(..))+import Data.Proxy++-- syntactic.+import Language.Syntactic+import qualified Language.Syntactic.Traversal as Syn (Args(Nil))++-- hardware-edsl.+import Language.Embedded.Hardware hiding (Sym)+import Language.Embedded.Hardware.Expression.Represent+import Language.Embedded.Hardware.Expression.Represent.Bit (Bits, ni)+import Language.Embedded.Hardware.Expression.Hoist (lift, Kind)+import Language.Embedded.Hardware.Command.CMD (IArray(..))+import qualified Language.Embedded.Hardware.Expression.Hoist as Hoist++-- language-vhdl.+import Language.Embedded.VHDL (VHDL)+import qualified Language.VHDL          as VHDL+import qualified Language.Embedded.VHDL as VHDL++import GHC.TypeLits++--------------------------------------------------------------------------------+-- * Compilation of hardware primitives.+--------------------------------------------------------------------------------++viewLitPrim :: ASTF HardwarePrimDomain a -> Maybe a+viewLitPrim (Sym (Lit a :&: _ )) = Just a+viewLitPrim _                    = Nothing++--------------------------------------------------------------------------------++-- todo: should we declare types here as well?+compLiteral :: forall a . PrimType a => (a -> String) -> a -> VHDL VHDL.Expression+compLiteral f = return . exp+  where+    exp :: a -> VHDL.Expression+    exp = lift . VHDL.literal . VHDL.number . f++compNum  :: PrimType a => a -> VHDL VHDL.Expression+compNum  = compLiteral primTypeVal++compBits :: PrimType a => a -> VHDL VHDL.Expression+compBits = compLiteral primTypeBits++instance CompileType HardwarePrimType+  where+    compileType _ (v :: proxy a) =+      compTypeSign (hardwareRep :: HardwarePrimTypeRep a)      +    compileLit _ a = case hardwarePrimTypeOf a of+      BoolHT    -> compNum a+      IntegerHT -> compNum a+      Int8HT    -> compNum a+      Int16HT   -> compNum a+      Int32HT   -> compNum a+      Int64HT   -> compNum a+      Word8HT   -> compNum a+      Word16HT  -> compNum a+      Word32HT  -> compNum a+      Word64HT  -> compNum a+      BitsHT    -> compNum a+    compileBits _ a = case hardwarePrimTypeOf a of+      BoolHT    -> compBits a+      IntegerHT -> compBits a+      Int8HT    -> compBits a+      Int16HT   -> compBits a+      Int32HT   -> compBits a+      Int64HT   -> compBits a+      Word8HT   -> compBits a+      Word16HT  -> compBits a+      Word32HT  -> compBits a+      Word64HT  -> compBits a+      BitsHT    -> compBits a++--------------------------------------------------------------------------------++instance CompileExp Prim+  where+    compE = compPrim++--------------------------------------------------------------------------------++compSize :: Int -> VHDL.Primary+compSize = VHDL.literal . VHDL.number . primTypeVal++compTypeSize :: forall a . HardwarePrimTypeRep a -> VHDL.Primary+compTypeSize BoolHT    = compSize (1  :: Int)+compTypeSize IntegerHT = compSize (32 :: Int)+compTypeSize Int8HT    = compSize (8  :: Int)+compTypeSize Int16HT   = compSize (16 :: Int)+compTypeSize Int32HT   = compSize (32 :: Int)+compTypeSize Int64HT   = compSize (64 :: Int)+compTypeSize Word8HT   = compSize (8  :: Int)+compTypeSize Word16HT  = compSize (16 :: Int)+compTypeSize Word32HT  = compSize (32 :: Int)+compTypeSize Word64HT  = compSize (64 :: Int)+compTypeSize b@BitsHT  = compSizeBits b+  where+    compSizeBits :: forall n . KnownNat n =>+      HardwarePrimTypeRep (Bits n) -> VHDL.Primary+    compSizeBits rep = compSize (fromInteger (ni (Proxy :: Proxy n)))++compTypeSign :: forall a. HardwarePrimTypeRep a -> VHDL VHDL.Type+compTypeSign BoolHT    = declareType (Proxy :: Proxy a)+compTypeSign IntegerHT = declareType (Proxy :: Proxy a)+compTypeSign Int8HT    = declareType (Proxy :: Proxy a)+compTypeSign Int16HT   = declareType (Proxy :: Proxy a)+compTypeSign Int32HT   = declareType (Proxy :: Proxy a)+compTypeSign Int64HT   = declareType (Proxy :: Proxy a)+compTypeSign Word8HT   = declareType (Proxy :: Proxy a)+compTypeSign Word16HT  = declareType (Proxy :: Proxy a)+compTypeSign Word32HT  = declareType (Proxy :: Proxy a)+compTypeSign Word64HT  = declareType (Proxy :: Proxy a)+compTypeSign BitsHT    = declareType (Proxy :: Proxy a)++--------------------------------------------------------------------------------++compExpr   :: [ASTF HardwarePrimDomain a] -> ([VHDL.Relation] -> VHDL.Expression) -> VHDL Kind+compExpr as f = do+  as' <- mapM compKind as+  return $ Hoist.E $ f $ map lift as'++compRel    :: [ASTF HardwarePrimDomain a] -> ([VHDL.ShiftExpression] -> VHDL.Relation) -> VHDL Kind+compRel as f = do+  as' <- mapM compKind as+  return $ Hoist.R $ f $ map lift as'++compShift :: ASTF HardwarePrimDomain a -> ASTF HardwarePrimDomain b -> (VHDL.SimpleExpression -> VHDL.SimpleExpression -> VHDL.ShiftExpression) -> VHDL Kind+compShift a b f = do+  a' <- compKind a+  b' <- compKind b+  tf <- compTypeSign (getDecor b)+  return $ Hoist.Sh $ f (lift a') $ lift $ VHDL.uCast (lift b') tf tt+  where+    tt :: VHDL.Type+    tt = VHDL.integer Nothing++compSimple :: [ASTF HardwarePrimDomain a] -> ([VHDL.Term] -> VHDL.SimpleExpression) -> VHDL Kind+compSimple as f = do+  as' <- mapM compKind as+  return $ Hoist.Si $ f $ map lift as'++compTerm   :: [ASTF HardwarePrimDomain a] -> ([VHDL.Factor] -> VHDL.Term) -> VHDL Kind+compTerm as f = do+  as' <- mapM compKind as+  return $ Hoist.T $ f $ map lift as'++compFactor :: [ASTF HardwarePrimDomain a] -> ([VHDL.Primary] -> VHDL.Factor) -> VHDL Kind+compFactor as f = do+  as' <- mapM compKind as+  return $ Hoist.F $ f $ map lift as'++compCast :: forall a b . HardwarePrimTypeRep a -> ASTF HardwarePrimDomain b -> VHDL Kind+compCast tt a = do+  a'  <- compKind a+  tt' <- compTypeSign tt+  tf' <- compTypeSign tf+  return $ Hoist.E $ VHDL.uCast (lift a') tf' tt'+  where+    tf :: HardwarePrimTypeRep b+    tf = getDecor a++isSigned  :: HardwarePrimTypeRep x -> Maybe Bool+isSigned (Int8HT)   = Just True+isSigned (Int16HT)  = Just True+isSigned (Int32HT)  = Just True+isSigned (Int64HT)  = Just True    +isSigned (Word8HT)  = Just False+isSigned (Word16HT) = Just False+isSigned (Word32HT) = Just False+isSigned (Word64HT) = Just False    +isSigned _          = Nothing++isInteger :: HardwarePrimTypeRep x -> Maybe Bool+isInteger (IntegerHT) = Just True+isInteger _           = Nothing++width :: HardwarePrimTypeRep x -> Int+width (IntegerHT) = 32+width (Int8HT)    = 8+width (Int16HT)   = 16+width (Int32HT)   = 32+width (Int64HT)   = 64+width (Word8HT)   = 8+width (Word16HT)  = 16+width (Word32HT)  = 32+width (Word64HT)  = 64+width _           = 0++--------------------------------------------------------------------------------++compKind :: ASTF HardwarePrimDomain a -> VHDL Kind+compKind = simpleMatch (\(s :&: t) -> go t s)+  where+    go :: forall sig+        . HardwarePrimTypeRep (DenResult sig)+        -> HardwarePrimConstructs sig+        -> Args (AST HardwarePrimDomain) sig+        -> VHDL Kind+    go _ (FreeVar v) Syn.Nil =+      return $ Hoist.P $ VHDL.name $ VHDL.NSimple $ VHDL.Ident v+    go t (Lit a)     Syn.Nil | Dict <- hardwarePrimWitType t =+      fmap Hoist.E $ compileLit (Proxy :: Proxy HardwarePrimType) a+      +    go t (Cast f) (a :* Syn.Nil) = compCast t a+    go t I2N (a :* Syn.Nil) = compCast t a++    go _ Neg (a :* Syn.Nil)      = compSimple [a]    (one VHDL.neg)+    go _ Add (a :* b :* Syn.Nil) = compSimple [a, b] VHDL.add+    go _ Sub (a :* b :* Syn.Nil) = compSimple [a, b] VHDL.sub+    go _ Mul (a :* b :* Syn.Nil) = compTerm   [a, b] VHDL.mul+    +    go _ Div (a :* b :* Syn.Nil) = compTerm   [a, b] VHDL.div+    go _ Mod (a :* b :* Syn.Nil) = compTerm   [a, b] VHDL.mod+    +    go _ Not (a :* Syn.Nil)      = compFactor [a]    (one VHDL.not)+    go _ And (a :* b :* Syn.Nil) = compExpr   [a, b] VHDL.and+    go _ Or  (a :* b :* Syn.Nil) = compExpr   [a, b] VHDL.or+    +    go _ Eq  (a :* b :* Syn.Nil) = compRel    [a, b] (two VHDL.eq)+    go _ Lt  (a :* b :* Syn.Nil) = compRel    [a, b] (two VHDL.lt)+    go _ Lte (a :* b :* Syn.Nil) = compRel    [a, b] (two VHDL.lte)+    go _ Gt  (a :* b :* Syn.Nil) = compRel    [a, b] (two VHDL.gt)+    go _ Gte (a :* b :* Syn.Nil) = compRel    [a, b] (two VHDL.gte)++    go _ BitAnd   (a :* b :* Syn.Nil) = compExpr   [a, b] VHDL.and+    go _ BitOr    (a :* b :* Syn.Nil) = compExpr   [a, b] VHDL.or+    go _ BitXor   (a :* b :* Syn.Nil) = compExpr   [a, b] VHDL.xor+    go _ BitCompl (a :* Syn.Nil)      = compFactor [a]    (one VHDL.not)+    +    go _ ShiftL  (a :* b :* Syn.Nil) = compShift a b VHDL.sll+    go _ ShiftR  (a :* b :* Syn.Nil) = compShift a b VHDL.srl+    go _ RotateL (a :* b :* Syn.Nil) = compShift a b VHDL.rol+    go _ RotateR (a :* b :* Syn.Nil) = compShift a b VHDL.ror++    go _ (ArrIx (IArrayC arr)) (i :* Syn.Nil) =+      do i' <- compPrim $ Prim i+         return $ Hoist.P $ VHDL.name $ VHDL.indexed (VHDL.simple arr) (lift i')++    one :: (a -> b) -> ([a] -> b)+    one f = \[a] -> f a++    two :: (a -> a -> b) -> ([a] -> b)+    two f = \[a, b] -> f a b+    +--------------------------------------------------------------------------------++compPrim :: Prim a -> VHDL VHDL.Expression+compPrim = fmap lift . compKind . unPrim++--------------------------------------------------------------------------------
+ src/Feldspar/Hardware/Representation.hs view
@@ -0,0 +1,118 @@+{-# language GADTs                      #-}+{-# language DataKinds                  #-}+{-# language TypeOperators              #-}+{-# language TypeFamilies               #-}+{-# language MultiParamTypeClasses      #-}+{-# language FlexibleContexts           #-}+{-# language FlexibleInstances          #-}+{-# language GeneralizedNewtypeDeriving #-}++module Feldspar.Hardware.Representation where++import Feldspar.Sugar+import Feldspar.Representation+import Feldspar.Frontend+import Feldspar.Storable+import Feldspar.Array.Buffered (ArraysEq(..))+import Feldspar.Hardware.Primitive+import Feldspar.Hardware.Expression+import Data.Struct++import Data.Int+import Data.Word+import Data.List (genericTake)+import Data.Typeable (Typeable)+import Data.Constraint++import Control.Monad.Identity (Identity)+import Control.Monad.Trans++-- syntactic.+import Language.Syntactic hiding (Signature, Args)+import Language.Syntactic.Functional hiding (Lam)+import Language.Syntactic.Functional.Tuple++import qualified Language.Syntactic as Syn++-- operational-higher.+import Control.Monad.Operational.Higher as Oper hiding ((:<:))++-- hardware-edsl.+import qualified Language.Embedded.Hardware.Command   as Imp+import qualified Language.Embedded.Hardware.Interface as Imp++import Prelude hiding ((==))+import qualified Prelude as P++--------------------------------------------------------------------------------+-- * Programs.+--------------------------------------------------------------------------------++-- | Hardware instruction set.+type HardwareCMD =+    -- ^ Computatonal instructions.+           Imp.VariableCMD+  Oper.:+: Imp.VArrayCMD+  Oper.:+: Imp.LoopCMD+  Oper.:+: Imp.ConditionalCMD+    -- ^ Hardware specific instructions.+  Oper.:+: Imp.SignalCMD+  Oper.:+: Imp.ArrayCMD+  Oper.:+: Imp.ProcessCMD+  Oper.:+: Imp.ComponentCMD++-- | Monad for building hardware programs in Co-Feldspar.+newtype Hardware a = Hardware { unHardware :: Program HardwareCMD (Param2 HExp HardwarePrimType) a}+  deriving (Functor, Applicative, Monad)++--------------------------------------------------------------------------------++-- | Hardware references.+newtype Ref a = Ref { unRef :: Struct HardwarePrimType Imp.Variable (Internal a) }++-- | Hardware arrays.+data Arr a = Arr+  { arrOffset :: HExp Index+  , arrLength :: HExp Length+  , unArr     :: Struct HardwarePrimType Imp.VArray (Internal a)+  }++-- | Immutable hardware arrays.+data IArr a = IArr+  { iarrOffset :: HExp Index+  , iarrLength :: HExp Length+  , unIArr     :: Struct HardwarePrimType Imp.IArray (Internal a)+  }++--------------------------------------------------------------------------------+-- ** ...+--------------------------------------------------------------------------------++instance ArraysEq Arr IArr+  where+    unsafeArrEq (Arr _ _ arr) (IArr _ _ brr) =+        and (zipListStruct sameId arr brr)+      where+        sameId :: Imp.VArray a -> Imp.IArray a -> Bool+        sameId (Imp.VArrayC a) (Imp.IArrayC b) = a P.== b+        sameId _ _ = False++--------------------------------------------------------------------------------++type instance Expr     Hardware = HExp+type instance DomainOf Hardware = HardwareDomain++--------------------------------------------------------------------------------++instance (Reference Hardware ~ Ref, Type HardwarePrimType a) =>+    Storable Hardware (HExp a)+  where+    type StoreRep Hardware (HExp a) = Ref (HExp a)+    type StoreSize Hardware (HExp a) = ()+    newStoreRep _ _      = newRef+    initStoreRep         = initRef+    readStoreRep         = getRef+    unsafeFreezeStoreRep = unsafeFreezeRef+    writeStoreRep        = setRef++--------------------------------------------------------------------------------
+ src/Feldspar/Representation.hs view
@@ -0,0 +1,115 @@+{-# language GADTs #-}+{-# language TypeFamilies #-}+{-# language MultiParamTypeClasses #-}+{-# language FlexibleInstances #-}+{-# language FlexibleContexts #-}+{-# language UndecidableInstances #-}+{-# language UndecidableSuperClasses #-}+{-# language ConstraintKinds #-}++module Feldspar.Representation+  (+  -- short-hands.+    Length+  , Index+  -- type representations.+  , TypeRep(..)+  , TypeRepF(..)+  -- types.+  , Type(..)+  , PrimType+  -- type families.+  , Expr+  , Pred+  -- external.+  , Inhabited(..)+  -- hmm...+  , ExprOf+  , PredOf+  , DomainOf+  , RepresentationOf+  ) where++import Data.Struct++import Data.Constraint+import Data.Word+import Data.List (genericTake)+import Data.Typeable hiding (typeRep, TypeRep)++-- syntactic.+import Language.Syntactic hiding ((:+:))+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Tuple++-- hardware-edsl.+import Language.Embedded.Hardware.Expression.Represent (Inhabited(..))++-- operational-higher.+import Control.Monad.Operational.Higher (ProgramT, Param2)++--------------------------------------------------------------------------------+-- * Co-Feldspar types.+--------------------------------------------------------------------------------++-- | Expression associated with a program monad.+type family Expr (m :: * -> *) :: * -> *++-- | Predicate associated with a program monad.+type family Pred (m :: * -> *) :: * -> Constraint++--------------------------------------------------------------------------------++-- | Representation of supported feldspar types as typed binary trees over+--   primitive types.+type TypeRep pred rep = Struct pred rep++-- | Representation of supported value types and N-ary functions over such+--   types.+data TypeRepF pred rep a+  where+    ValT :: TypeRep pred rep a -> TypeRepF pred rep a+    FunT :: TypeRep pred rep a -> TypeRepF pred rep b -> TypeRepF pred rep (a -> b)+  +-- | Supported types, that is, types which can be represented as nested pairs of+--   simpler values that respect `pred` and are in turn represented using `trep`.+class (Eq a, Show a, Typeable a, Inhabited a) => Type pred a+  where+    typeRep :: TypeRep pred (RepresentationOf pred) a++-- | Pairs of valid types are themselves also valid types.+instance (Type pred a, Type pred b) => Type pred (a, b)+  where+    typeRep = Branch typeRep typeRep++-- | Pairs of inhabited types are also inhabited.+instance (Inhabited a, Inhabited b) => Inhabited (a, b)+  where+    reset = (reset, reset)++-- | Short-hand for supported types that also respect their primitive constraint.+class    (Type pred a, pred a) => PrimType pred a+instance (Type pred a, pred a) => PrimType pred a++--------------------------------------------------------------------------------+-- Short-hand for common data types.++type Length = Word32+type Index  = Word32++--------------------------------------------------------------------------------+-- hmm...++type family ExprOf (val :: *) :: * -> *++type family PredOf (exp :: * -> *) :: * -> Constraint++type family DomainOf (exp :: * -> *) :: * -> *++type family RepresentationOf (pred :: * -> Constraint) :: * -> *++--------------------------------------------------------------------------------++type instance ExprOf (a, b) = ExprOf a+  +--------------------------------------------------------------------------------
+ src/Feldspar/Software.hs view
@@ -0,0 +1,22 @@+module Feldspar.Software+  ( module Feldspar+  , module Feldspar.Software.Frontend+  , Software+  , Ref, Arr, IArr+  , SExp+  , SType, SType', SoftwarePrimType+  , runIO+  , captureIO+  , compile+  , icompile+  , runCompiled+  , withCompiled+  , compareCompiled+  ) where++import Feldspar+import Feldspar.Software.Representation+import Feldspar.Software.Primitive+import Feldspar.Software.Expression+import Feldspar.Software.Frontend+import Feldspar.Software.Compile
+ src/Feldspar/Software/Compile.hs view
@@ -0,0 +1,483 @@+{-# language GADTs               #-}+{-# language TypeOperators       #-}+{-# language FlexibleContexts    #-}+{-# language ScopedTypeVariables #-}+{-# language ConstraintKinds #-}+{-# language TypeSynonymInstances #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language QuasiQuotes #-}++module Feldspar.Software.Compile where++import Feldspar.Representation+import Feldspar.Software.Primitive+import Feldspar.Software.Primitive.Backend+import Feldspar.Software.Expression+import Feldspar.Software.Representation+import Feldspar.Software.Optimize+import Data.Struct++import Control.Monad.Identity+import Control.Monad.Reader+import Data.Proxy+import Data.Constraint hiding (Sub)+import Data.Map (Map)+import qualified Data.Map as Map++import Data.Selection+import Data.Default.Class++-- syntactic.+import Language.Syntactic (AST (..), ASTF, (:&:) (..), Args((:*)), prj)+import Language.Syntactic.Functional hiding (Binding (..))+import Language.Syntactic.Functional.Tuple+import qualified Language.Syntactic as Syn++-- operational-higher.+import Control.Monad.Operational.Higher (Program)+import qualified Control.Monad.Operational.Higher as Oper++-- imperative-edsl.+import Language.Embedded.Expression+import qualified Language.Embedded.Imperative as Imp+import qualified Language.Embedded.Imperative.CMD as Imp+import qualified Language.Embedded.Imperative.Frontend as Imp+import qualified Language.Embedded.Backend.C  as Imp+import qualified Language.C.Monad as C+  (CGen, addGlobal, addLocal, addInclude, addStm, gensym)++-- hardware-edsl+import qualified Language.Embedded.Hardware.Command as Hard++-- language-c-quote+import Language.C.Quote.GCC+import qualified Language.C.Syntax as C++-- hmm!+import Feldspar.Hardware.Primitive  (HardwarePrimType(..), HardwarePrimTypeRep(..))+import Feldspar.Hardware.Expression (HType')+import Feldspar.Hardware.Frontend   (HSig, withHType')++-- debug.+import Debug.Trace++--------------------------------------------------------------------------------+-- * Software compiler.+--------------------------------------------------------------------------------++-- | Target software instructions.+type TargetCMD+    =        Imp.RefCMD+    Oper.:+: Imp.ArrCMD+    Oper.:+: Imp.ControlCMD+    Oper.:+: Imp.FileCMD+    Oper.:+: Imp.PtrCMD+    Oper.:+: Imp.C_CMD+    --+    Oper.:+: MMapCMD++-- | Target monad during translation.+type TargetT m = ReaderT Env (Oper.ProgramT TargetCMD (Oper.Param2 Prim SoftwarePrimType) m)++-- | Monad for translated programs.+type ProgC = Program TargetCMD (Oper.Param2 Prim SoftwarePrimType)++--------------------------------------------------------------------------------+-- ** Compilation of expressions.++-- | Struct expression.+type VExp = Struct SoftwarePrimType Prim++-- | Struct expression with hidden result type.+data VExp' where+  VExp' :: Struct SoftwarePrimType Prim a -> VExp'++newRefV :: Monad m => STypeRep a -> String -> TargetT m (Struct SoftwarePrimType Imp.Ref a)+newRefV t base = lift $ mapStructA (const (Imp.newNamedRef base)) t++initRefV :: Monad m => String -> VExp a -> TargetT m (Struct SoftwarePrimType Imp.Ref a)+initRefV base = lift . mapStructA (Imp.initNamedRef base)++getRefV :: Monad m => Struct SoftwarePrimType Imp.Ref a -> TargetT m (VExp a)+getRefV = lift . mapStructA Imp.getRef++setRefV :: Monad m => Struct SoftwarePrimType Imp.Ref a -> VExp a -> TargetT m ()+setRefV r = lift . sequence_ . zipListStruct Imp.setRef r++unsafeFreezeRefV :: Monad m => Struct SoftwarePrimType Imp.Ref a -> TargetT m (VExp a)+unsafeFreezeRefV = lift . mapStructA Imp.unsafeFreezeRef++--------------------------------------------------------------------------------+-- ** Compilation options.++-- | Options affecting code generation+--+-- A default set of options is given by 'def'.+--+-- The assertion labels to include in the generated code can be stated using the+-- functions 'select', 'allExcept' and 'selectBy'. For example+--+-- @`def` {compilerAssertions = `allExcept` [`InternalAssertion`]}@+--+-- states that we want to include all except internal assertions.+data CompilerOpts = CompilerOpts+    { compilerAssertions :: Selection AssertionLabel+        -- ^ Which assertions to include in the generated code+    }++instance Default CompilerOpts+  where+    def = CompilerOpts+      { compilerAssertions = universal+      }++--------------------------------------------------------------------------------+-- ** Compilation environment.++data Env = Env {+    envAliases :: Map Name VExp'+  , envOptions :: CompilerOpts+  }++env0 :: Env+env0 = Env Map.empty def++localAlias :: MonadReader Env m => Name -> VExp a -> m b -> m b+localAlias v e = local (\env ->+  env {envAliases = Map.insert v (VExp' e) (envAliases env)})++lookAlias :: MonadReader Env m => STypeRep a -> Name -> m (VExp a)+lookAlias t v = do+  env <- asks envAliases+  return $ case Map.lookup v env of+    Nothing -> error $ "lookAlias: variable " ++ show v ++ " not in scope."+    Just (VExp' e) -> case softwareTypeEq t (softwareTypeRep e) of Just Dict -> e++--------------------------------------------------------------------------------++translateExp :: forall m a . Monad m => SExp a -> TargetT m (VExp a)+translateExp = goAST . optimize . unSExp+  where+    goAST :: ASTF SoftwareDomain b -> TargetT m (VExp b)+    goAST = Syn.simpleMatch (\(s :&: ValT t) -> go t s)++    goSmallAST :: SoftwarePrimType b => ASTF SoftwareDomain b -> TargetT m (Prim b)+    goSmallAST = fmap extractNode . goAST++    go :: STypeRep (Syn.DenResult sig) +       -> SoftwareConstructs sig+       -> Syn.Args (AST SoftwareDomain) sig+       -> TargetT m (VExp (Syn.DenResult sig))+    go t lit Syn.Nil+      | Just (Lit a) <- prj lit+      = return $ mapStruct (constExp . runIdentity) $ toStruct t a+--    go t lit Syn.Nil+--      | Just (Literal a) <- prj lit+--      = return $ mapStruct (constExp . runIdentity) $ toStruct t a+    go t var Syn.Nil+      | Just (FreeVar v) <- prj var+      = return $ Node $ sugarSymPrim $ FreeVar v+    go t var Syn.Nil+      | Just (VarT v) <- prj var+      = do lookAlias t v+    go t lt (a :* (lam :$ body) :* Syn.Nil)+      | Just (Let tag) <- prj lt+      , Just (LamT v)  <- prj lam+      = do let base = if null tag then "let" else tag+           r  <- initRefV base =<< goAST a+           a' <- unsafeFreezeRefV r+           localAlias v a' $ goAST body+    go t ffi args+      | Just (Construct addr sem) <- prj ffi+      = do +           undefined+    go t tup (a :* b :* Syn.Nil)+      | Just Pair <- prj tup+      = Branch <$> goAST a <*> goAST b+    go t sel (ab :* Syn.Nil)+      | Just Fst <- prj sel = do+          branch <- goAST ab+          case branch of (Branch a _) -> return a+      | Just Snd <- prj sel = do+          branch <- goAST ab+          case branch of (Branch _ b) -> return b+    go ty cond (b :* t :* f :* Syn.Nil)+      | Just Cond <- prj cond = do+          res <- newRefV ty "b"+          b'  <- goSmallAST b+          ReaderT $ \env -> Imp.iff b'+            (flip runReaderT env $ setRefV res =<< goAST t)+            (flip runReaderT env $ setRefV res =<< goAST f)+          unsafeFreezeRefV res+    go _ op (a :* Syn.Nil)+      | Just Neg       <- prj op = liftStruct (sugarSymPrim Neg)       <$> goAST a+      | Just Not       <- prj op = liftStruct (sugarSymPrim Not)       <$> goAST a+      | Just Exp       <- prj op = liftStruct (sugarSymPrim Exp)       <$> goAST a+      | Just Log       <- prj op = liftStruct (sugarSymPrim Log)       <$> goAST a+      | Just Sqrt      <- prj op = liftStruct (sugarSymPrim Sqrt)      <$> goAST a+      | Just Sin       <- prj op = liftStruct (sugarSymPrim Sin)       <$> goAST a+      | Just Cos       <- prj op = liftStruct (sugarSymPrim Cos)       <$> goAST a+      | Just Tan       <- prj op = liftStruct (sugarSymPrim Tan)       <$> goAST a+      | Just Asin      <- prj op = liftStruct (sugarSymPrim Asin)      <$> goAST a+      | Just Acos      <- prj op = liftStruct (sugarSymPrim Acos)      <$> goAST a+      | Just Atan      <- prj op = liftStruct (sugarSymPrim Atan)      <$> goAST a+      | Just Sinh      <- prj op = liftStruct (sugarSymPrim Sinh)      <$> goAST a+      | Just Cosh      <- prj op = liftStruct (sugarSymPrim Cosh)      <$> goAST a+      | Just Tanh      <- prj op = liftStruct (sugarSymPrim Tanh)      <$> goAST a+      | Just Asinh     <- prj op = liftStruct (sugarSymPrim Asinh)     <$> goAST a+      | Just Acosh     <- prj op = liftStruct (sugarSymPrim Acosh)     <$> goAST a+      | Just Atanh     <- prj op = liftStruct (sugarSymPrim Atanh)     <$> goAST a+      | Just Real      <- prj op = liftStruct (sugarSymPrim Real)      <$> goAST a+      | Just Imag      <- prj op = liftStruct (sugarSymPrim Imag)      <$> goAST a+      | Just Magnitude <- prj op = liftStruct (sugarSymPrim Magnitude) <$> goAST a+      | Just Phase     <- prj op = liftStruct (sugarSymPrim Phase)     <$> goAST a+      | Just Conjugate <- prj op = liftStruct (sugarSymPrim Conjugate) <$> goAST a+      | Just I2N       <- prj op = liftStruct (sugarSymPrim I2N)       <$> goAST a+      | Just I2B       <- prj op = liftStruct (sugarSymPrim I2B)       <$> goAST a+      | Just B2I       <- prj op = liftStruct (sugarSymPrim B2I)       <$> goAST a+      | Just Round     <- prj op = liftStruct (sugarSymPrim Round)     <$> goAST a+      | Just BitCompl  <- prj op = liftStruct (sugarSymPrim BitCompl)  <$> goAST a+    go _ op (a :* b :* Syn.Nil)+      | Just Add <- prj op = liftStruct2 (sugarSymPrim Add) <$> goAST a <*> goAST b+      | Just Sub <- prj op = liftStruct2 (sugarSymPrim Sub) <$> goAST a <*> goAST b+      | Just Mul <- prj op = liftStruct2 (sugarSymPrim Mul) <$> goAST a <*> goAST b+      | Just Div <- prj op = liftStruct2 (sugarSymPrim Div) <$> goAST a <*> goAST b+      | Just Mod <- prj op = liftStruct2 (sugarSymPrim Mod) <$> goAST a <*> goAST b+      | Just Eq  <- prj op = liftStruct2 (sugarSymPrim Eq)  <$> goAST a <*> goAST b+      | Just And <- prj op = liftStruct2 (sugarSymPrim And) <$> goAST a <*> goAST b+      | Just Or  <- prj op = liftStruct2 (sugarSymPrim Or)  <$> goAST a <*> goAST b+      | Just Lt  <- prj op = liftStruct2 (sugarSymPrim Lt)  <$> goAST a <*> goAST b+      | Just Lte <- prj op = liftStruct2 (sugarSymPrim Lte) <$> goAST a <*> goAST b+      | Just Gt  <- prj op = liftStruct2 (sugarSymPrim Gt)  <$> goAST a <*> goAST b+      | Just Gte <- prj op = liftStruct2 (sugarSymPrim Gte) <$> goAST a <*> goAST b+      | Just FDiv    <- prj op =+          liftStruct2 (sugarSymPrim FDiv)    <$> goAST a <*> goAST b+      | Just Complex <- prj op =+          liftStruct2 (sugarSymPrim Complex) <$> goAST a <*> goAST b+      | Just Polar   <- prj op =+          liftStruct2 (sugarSymPrim Polar)   <$> goAST a <*> goAST b+      | Just Pow     <- prj op =+          liftStruct2 (sugarSymPrim Pow)     <$> goAST a <*> goAST b+      | Just BitAnd <- prj op =+          liftStruct2 (sugarSymPrim BitAnd)  <$> goAST a <*> goAST b+      | Just BitOr  <- prj op =+          liftStruct2 (sugarSymPrim BitOr)   <$> goAST a <*> goAST b+      | Just BitXor <- prj op =+          liftStruct2 (sugarSymPrim BitXor)  <$> goAST a <*> goAST b+      | Just ShiftL <- prj op =+          liftStruct2 (sugarSymPrim ShiftL)  <$> goAST a <*> goAST b+      | Just ShiftR <- prj op =+          liftStruct2 (sugarSymPrim ShiftR)  <$> goAST a <*> goAST b+      | Just RotateL <- prj op =+          liftStruct2 (sugarSymPrim RotateL) <$> goAST a <*> goAST b+      | Just RotateR <- prj op =+          liftStruct2 (sugarSymPrim RotateR) <$> goAST a <*> goAST b+    go t guard (cond :* a :* Syn.Nil)+      | Just (GuardVal lbl msg) <- prj guard+      = do cond' <- extractNode <$> goAST cond+           lift $ Imp.assert cond' msg+           goAST a+    go t hint (cond :* a :* Syn.Nil)+        | Just (HintVal) <- prj hint+        = do cond' <- extractNode <$> goAST cond+             lift $ Imp.hint cond'+             goAST a+    go t loop (min :* max :* init :* (lami :$ (lams :$ body)) :* Syn.Nil)+      | Just ForLoop   <- prj loop+      , Just (LamT iv) <- prj lami+      , Just (LamT sv) <- prj lams = do+          min'  <- goSmallAST min+          max'  <- goSmallAST max+          state <- initRefV "state" =<< goAST init+          ReaderT $ \env -> Imp.for (min', 1, Imp.Excl max') $ \i ->+            flip runReaderT env $ do+              s <- case t of+                Node _ -> unsafeFreezeRefV state+                _      -> getRefV state+              s' <- localAlias iv (Node i) $ localAlias sv s $ goAST body+              setRefV state s'+          unsafeFreezeRefV state+    go _ arrIx (i :* Syn.Nil)+      | Just (ArrIx arr) <- prj arrIx = do+          i' <- goSmallAST i+          return $ Node $ sugarSymPrim (ArrIx arr) i'+    go _ s _ = error $ "software translation handling for symbol " ++ Syn.renderSym s ++ " is missing."++unsafeTranslateSmallExp :: Monad m => SExp a -> TargetT m (Prim a)+unsafeTranslateSmallExp a = do+  node <- translateExp a+  case node of (Node b) -> return b++--------------------------------------------------------------------------------+-- * Interpretation of software commands.+--------------------------------------------------------------------------------+{-+instance (Imp.CompExp exp, Imp.CompTypeClass ct) =>+    Oper.Interp PtrCMD C.CGen (Oper.Param2 exp ct)+  where+    interp = compPtrCMD++compPtrCMD :: forall exp ct a . (Imp.CompExp exp, Imp.CompTypeClass ct) =>+  PtrCMD (Oper.Param3 C.CGen exp ct) a -> C.CGen a+compPtrCMD = undefined+-}+--------------------------------------------------------------------------------++instance (Imp.CompExp exp, Imp.CompTypeClass ct) =>+    Oper.Interp MMapCMD C.CGen (Oper.Param2 exp ct)+  where+    interp = compMMapCMD++-- todo:+--  > only need one 'ix' for read/write to arrays in 'Call'.+--  > 'n' in 'MMap' isn't really an '$id'.+compMMapCMD :: forall exp ct a . (Imp.CompExp exp, Imp.CompTypeClass ct)+  => MMapCMD (Oper.Param3 C.CGen exp ct) a+  -> C.CGen a+compMMapCMD (MMap n sig) =+  do C.addInclude "<stdio.h>"+     C.addInclude "<stdlib.h>"+     C.addInclude "<stddef.h>"+     C.addInclude "<unistd.h>"+     C.addInclude "<sys/mman.h>"+     C.addInclude "<fcntl.h>"+     C.addGlobal [cedecl| unsigned page_size = 0; |]+     C.addGlobal [cedecl| int mem_fd = -1; |]+     C.addGlobal mmap_def+     mem <- C.gensym "mem"+     C.addLocal [cdecl| int * $id:mem = f_map($id:n); |]+     return mem+compMMapCMD (Call (Address ptr sig) arg) =+  do traverse 0 sig arg+  where+    traverse :: Integer -> HSig b -> Argument ct (Soften b) -> C.CGen ()+    traverse ix (Hard.Ret _) (Nil) = return ()+    traverse ix (Hard.SSig _ Hard.Out rf) (ARef (Ref (Node ref@(Imp.RefComp r))) arg) =+      do typ <- compRefType (Proxy :: Proxy ct) ref+         C.addStm [cstm| $id:r = ($ty:typ) *($id:ptr + $int:ix); |]+         traverse (ix + 1) (rf dummy) arg+    traverse ix (Hard.SArr _ Hard.Out len af) (AArr (Arr _ _ (Node arr@(Imp.ArrComp a))) arg) =+      do let end = ix + toInteger len+         i   <- C.gensym "ix"+         typ <- compArrType (Proxy :: Proxy ct) arr+         C.addLocal [cdecl| int $id:i; |]+         C.addStm [cstm| for ($id:i=$int:ix; $id:i<$int:end; $id:i++) {+                           $id:arr[$id:i] = ($ty:typ) *($id:ptr + $id:i);+                         } |]+         traverse end (af dummy) arg+    traverse ix (Hard.SSig _ Hard.In rf) (ARef (Ref (Node (Imp.RefComp r))) arg) =+      do C.addStm [cstm| *($id:ptr + $int:ix) = (int) $id:r; |]+         traverse (ix + 1) (rf dummy) arg+    traverse ix (Hard.SArr _ Hard.In len af) (AArr (Arr _ _ (Node arr@(Imp.ArrComp a))) arg) =+      do let end = ix + toInteger len+         i   <- C.gensym "ix"+         typ <- compArrType (Proxy :: Proxy ct) arr+         C.addLocal [cdecl| int $id:i; |]+         C.addStm [cstm| for ($id:i=$int:ix; $id:i<$int:end; $id:i++) {+                           *($id:ptr + $id:i) = (int) $id:arr[$id:i];+                         } |]+         traverse end (af dummy) arg++    dummy :: forall x . x+    dummy = error "dummy evaluated."++    compRefType :: forall x . (Imp.CompTypeClass ct, HardwarePrimType x, ct x)+      => Proxy ct -> Imp.Ref x -> C.CGen C.Type+    compRefType ct _ = case witnessSP (Proxy :: Proxy x) of+      Dict -> Imp.compType ct (Proxy :: Proxy x)++    compArrType :: forall i x . (Imp.CompTypeClass ct, HardwarePrimType x, ct x)+      => Proxy ct -> Imp.Arr i x -> C.CGen C.Type+    compArrType ct _ = case witnessSP (Proxy :: Proxy x) of+      Dict -> Imp.compType ct (Proxy :: Proxy x)++    witnessSP :: forall x . HardwarePrimType x => Proxy x -> Dict (SoftwarePrimType x)+    witnessSP _ = case hardwareRep :: HardwarePrimTypeRep x of+      BoolHT    -> Dict+      Int8HT    -> Dict+      Int16HT   -> Dict+      Int32HT   -> Dict+      Int64HT   -> Dict+      Word8HT   -> Dict+      Word16HT  -> Dict+      Word32HT  -> Dict+      Word64HT  -> Dict+      _         -> error "unrecognized software type used by mmap."++--------------------------------------------------------------------------------++mmap_def :: C.Definition+mmap_def = [cedecl|+int * f_map(unsigned addr) {+  unsigned page_addr;+  unsigned offset;+  void * ptr;+  if (!page_size) {+    page_size = sysconf(_SC_PAGESIZE);+  }+  if (mem_fd < 1) {+    mem_fd = open("/dev/mem", O_RDWR);+    if (mem_fd < 1) {+      perror("f_map");+    }+  }+  page_addr = (addr & (~(page_size - 1)));+  offset = addr - page_addr;+  ptr = mmap(NULL, page_size, PROT_READ|PROT_WRITE, MAP_SHARED, mem_fd, page_addr);+  if (ptr == MAP_FAILED || !ptr) {+    perror("f_map");+  }+  return (int*) (ptr + offset);+}+|]++--------------------------------------------------------------------------------++translate' :: Env -> Software a -> ProgC a+translate' env =+    flip runReaderT env+  . Oper.reexpressEnv unsafeTranslateSmallExp+  . unSoftware+  +translate :: Software a -> ProgC a+translate = translate' env0++--------------------------------------------------------------------------------+-- * Interpretation of software programs.+--------------------------------------------------------------------------------++runIO :: Software a -> IO a+runIO = Imp.runIO . translate++captureIO :: Software a -> String -> IO String+captureIO = Imp.captureIO . translate++compile :: Software a -> String+compile = Imp.compile . translate++icompile :: Software a -> IO ()+icompile = Imp.icompile . translate++runCompiled :: Software a -> IO ()+runCompiled = Imp.runCompiled' opts . translate++withCompiled :: Software a -> ((String -> IO String) -> IO b) -> IO b+withCompiled = Imp.withCompiled' opts . translate++compareCompiled :: Software a -> IO a -> String -> IO ()+compareCompiled = Imp.compareCompiled' opts . translate++opts :: Imp.ExternalCompilerOpts+opts = Imp.def { Imp.externalFlagsPost = ["-lm"] }++--------------------------------------------------------------------------------++runCompiled' ::+       CompilerOpts+    -> Imp.ExternalCompilerOpts+    -> Software a+    -> IO ()+runCompiled' opts eopts = Imp.runCompiled' eopts . translate' (Env mempty opts)++--------------------------------------------------------------------------------
+ src/Feldspar/Software/Expression.hs view
@@ -0,0 +1,355 @@+{-# language GADTs                 #-}+{-# language StandaloneDeriving    #-}+{-# language TypeOperators         #-}+{-# language FlexibleInstances     #-}+{-# language FlexibleContexts      #-}+{-# language UndecidableInstances  #-}+{-# language MultiParamTypeClasses #-}+{-# language ConstraintKinds       #-}+{-# language TypeFamilies          #-}++{-# options_ghc -fwarn-incomplete-patterns #-}++module Feldspar.Software.Expression where++import Feldspar.Sugar+import Feldspar.Representation+import Feldspar.Software.Primitive+import Data.Struct++import Data.Complex (Complex)+import Data.Int+import Data.Word+import Data.List (genericTake)+import Data.Constraint+import Data.Typeable (Typeable)++-- syntactic.+import Language.Syntactic hiding (Signature, Args)+import Language.Syntactic.Functional hiding (Lam)+import Language.Syntactic.Functional.Tuple+import qualified Language.Syntactic as Syn++-- imperative-edsl.+import Language.Embedded.Expression++--------------------------------------------------------------------------------+-- * Software expressions.+--------------------------------------------------------------------------------++type instance Pred SoftwareDomain = SoftwarePrimType++--------------------------------------------------------------------------------+-- hmm...++type instance ExprOf   (SExp a) = SExp+type instance PredOf   SExp     = SoftwarePrimType+type instance DomainOf SExp     = SoftwareDomain+type instance RepresentationOf SoftwarePrimType = SoftwarePrimTypeRep++--------------------------------------------------------------------------------+-- ** Software types.++-- | Representation of supported software types.+type STypeRep  = TypeRep SoftwarePrimType SoftwarePrimTypeRep++-- | ...+type STypeRepF = TypeRepF SoftwarePrimType SoftwarePrimTypeRep++instance Type SoftwarePrimType Bool   where typeRep = Node BoolST+instance Type SoftwarePrimType Int8   where typeRep = Node Int8ST+instance Type SoftwarePrimType Int16  where typeRep = Node Int16ST+instance Type SoftwarePrimType Int32  where typeRep = Node Int32ST+instance Type SoftwarePrimType Int64  where typeRep = Node Int64ST+instance Type SoftwarePrimType Word8  where typeRep = Node Word8ST+instance Type SoftwarePrimType Word16 where typeRep = Node Word16ST+instance Type SoftwarePrimType Word32 where typeRep = Node Word32ST+instance Type SoftwarePrimType Word64 where typeRep = Node Word64ST+instance Type SoftwarePrimType Float  where typeRep = Node FloatST+instance Type SoftwarePrimType Double where typeRep = Node DoubleST+instance Type SoftwarePrimType (Complex Float)  where typeRep = Node ComplexFloatST+instance Type SoftwarePrimType (Complex Double) where typeRep = Node ComplexDoubleST++-- | Compare two software types for equality.+softwareTypeEq :: STypeRep a -> STypeRep b -> Maybe (Dict (a ~ b))+softwareTypeEq (Node t)       (Node u) = softwarePrimTypeEq t u+softwareTypeEq (Branch t1 u1) (Branch t2 u2) = do+  Dict <- softwareTypeEq t1 t2+  Dict <- softwareTypeEq u1 u2+  return Dict+softwareTypeEq _ _ = Nothing++-- | Construct the software type representation of 'a'.+softwareTypeRep :: Struct SoftwarePrimType c a -> STypeRep a+softwareTypeRep = mapStruct (const softwareRep)++--------------------------------------------------------------------------------++-- | Short-hand for software types.+type SType    = Type SoftwarePrimType++-- | Short-hand for primitive software types.+type SType'   = PrimType SoftwarePrimType++--------------------------------------------------------------------------------+-- ** Software expression symbols.++data AssertionLabel =+    -- ^ Internal assertion to guarantee meaningful results.+    InternalAssertion+    -- ^ User made assertion.+  | UserAssertion String+  deriving (Eq, Show)++-- | Guard a value with an assertion.+data GuardVal sig+  where+    GuardVal :: AssertionLabel -> String -> GuardVal (Bool :-> a :-> Full a)++deriving instance Eq       (GuardVal a)+deriving instance Show     (GuardVal a)+deriving instance Typeable (GuardVal a)++--------------------------------------------------------------------------------++-- | Hint that a value may appear in an invariant+data HintVal sig+  where+    HintVal :: SoftwarePrimType a => HintVal (a :-> b :-> Full b)++deriving instance Eq       (HintVal a)+deriving instance Show     (HintVal a)+deriving instance Typeable (HintVal a)++--------------------------------------------------------------------------------++-- | For loop.+data ForLoop sig+  where+    ForLoop :: SType st =>+        ForLoop (Length :-> Length :-> st :-> (Index -> st -> st) :-> Full st)++deriving instance Eq       (ForLoop a)+deriving instance Show     (ForLoop a)+deriving instance Typeable (ForLoop a)++--------------------------------------------------------------------------------+{-+-- |+data Foreign sig+  where+    Foreign :: Signature sig => String -> Denotation sig -> Foreign sig+-}+--------------------------------------------------------------------------------++-- | Software symbols.+type SoftwareConstructs = +          BindingT+  Syn.:+: Let+  Syn.:+: Tuple+  Syn.:+: SoftwarePrimConstructs+  Syn.:+: Construct+  -- ^ Software specific symbol.+  Syn.:+: GuardVal+  Syn.:+: HintVal+  Syn.:+: ForLoop++-- | Software symbols tagged with their type representation.+type SoftwareDomain = SoftwareConstructs :&: TypeRepF SoftwarePrimType SoftwarePrimTypeRep++-- | Software expressions.+newtype SExp a = SExp { unSExp :: ASTF SoftwareDomain a }++-- | Evaluate a closed software expression.+eval :: (Syntactic a, Domain a ~ SoftwareDomain) => a -> Internal a+eval = evalClosed . desugar++-- | Sugar a software symbol as a smart constructor.+sugarSymSoftware+  :: ( Syn.Signature sig+       , fi  ~ SmartFun dom sig+       , sig ~ SmartSig fi+       , dom ~ SmartSym fi+       , dom ~ SoftwareDomain+       , SyntacticN f fi+       , sub :<: SoftwareConstructs+       , Type SoftwarePrimType (DenResult sig)+       )+    => sub sig -> f+sugarSymSoftware = sugarSymDecor $ ValT $ typeRep++-- | Sugar a software symbol as a primitive smart constructor.+sugarSymPrimSoftware+    :: ( Syn.Signature sig+       , fi  ~ SmartFun dom sig+       , sig ~ SmartSig fi+       , dom ~ SmartSym fi+       , dom ~ SoftwareDomain+       , SyntacticN f fi+       , sub :<: SoftwareConstructs+       , SoftwarePrimType (DenResult sig)+       )+    => sub sig -> f+sugarSymPrimSoftware = sugarSymDecor $ ValT $ Node softwareRep++--------------------------------------------------------------------------------++instance Syntactic (SExp a)+  where+    type Domain   (SExp a) = SoftwareDomain+    type Internal (SExp a) = a++    desugar = unSExp+    sugar   = SExp++instance Syntactic (Struct SoftwarePrimType SExp a)+  where+    type Domain   (Struct SoftwarePrimType SExp a) = SoftwareDomain+    type Internal (Struct SoftwarePrimType SExp a) = a++    desugar (Node a)     = unSExp a+    desugar (Branch a b) = sugarSymDecor (ValT $ Branch ta tb) Pair a' b'+      where+        a' = desugar a+        b' = desugar b+        ValT ta = getDecor a'+        ValT tb = getDecor b'+    +    sugar a = case getDecor a of+      ValT (Node _)       -> Node $ SExp a+      ValT (Branch ta tb) -> Branch+        (sugarSymDecor (ValT ta) Fst a)+        (sugarSymDecor (ValT tb) Snd a)+      FunT _ _ -> error "Syntactic can't sugar a function."++instance Tuples SoftwareDomain+  where+    pair   = sugarSymSoftware Pair+    first  = sugarSymSoftware Fst+    second = sugarSymSoftware Snd++instance FreeExp SExp+  where+    type FreePred SExp = PrimType SoftwarePrimType+    constExp = sugarSymSoftware . Lit+    varExp   = sugarSymSoftware . FreeVar++--------------------------------------------------------------------------------+-- syntactic instances.++instance Eval GuardVal+  where+    evalSym (GuardVal InternalAssertion msg) = \cond a ->+      if cond then a else error $ "Internal assertion failure: " ++ show msg+    evalSym (GuardVal (UserAssertion ass) msg) = \cond a ->+      if cond then a else error $ "User assertion " ++ show ass ++ " failure: " ++ show msg++instance Symbol GuardVal+  where+    symSig (GuardVal _ _) = signature++instance Render GuardVal+  where+    renderSym  = show+    renderArgs = renderArgsSmart++instance EvalEnv GuardVal env++instance StringTree GuardVal++instance Equality GuardVal++--------------------------------------------------------------------------------++instance Eval HintVal+  where+    evalSym (HintVal) = flip const++instance Symbol HintVal+  where+    symSig (HintVal) = signature++instance Render HintVal+  where+    renderSym  = show+    renderArgs = renderArgsSmart++instance EvalEnv    HintVal env+instance StringTree HintVal+instance Equality   HintVal++--------------------------------------------------------------------------------++instance Eval ForLoop+  where+    evalSym ForLoop = \min max init body ->+      foldl (flip body) init [min..max]++instance Symbol ForLoop+  where+    symSig (ForLoop) = signature++instance Render ForLoop+  where+    renderSym  = show+    renderArgs = renderArgsSmart++instance EvalEnv    ForLoop env+instance StringTree ForLoop+instance Equality   ForLoop++--------------------------------------------------------------------------------+-- *** Temporary fix until GHC fixes their class resolution for DTC ***++instance {-# OVERLAPPING #-} Project sub SoftwareConstructs =>+    Project sub (AST SoftwareDomain)+  where+    prj (Sym s) = Syn.prj s+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project sub SoftwareConstructs =>+    Project sub SoftwareDomain+  where+    prj (expr :&: info) = Syn.prj expr++instance {-# OVERLAPPING #-} Project BindingT SoftwareConstructs+  where+    prj (InjL a) = Just a+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project Let SoftwareConstructs+  where+    prj (InjR (InjL a)) = Just a+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project Tuple SoftwareConstructs+  where+    prj (InjR (InjR (InjL a))) = Just a+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project SoftwarePrimConstructs SoftwareConstructs+  where+    prj (InjR (InjR (InjR (InjL a)))) = Just a+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project Construct SoftwareConstructs+  where+    prj (InjR (InjR (InjR (InjR (InjL a))))) = Just a+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project GuardVal SoftwareConstructs+  where+    prj (InjR (InjR (InjR (InjR (InjR (InjL a)))))) = Just a+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project HintVal SoftwareConstructs+  where+    prj (InjR (InjR (InjR (InjR (InjR (InjR (InjL a))))))) = Just a+    prj _ = Nothing++instance {-# OVERLAPPING #-} Project ForLoop SoftwareConstructs+  where+    prj (InjR (InjR (InjR (InjR (InjR (InjR (InjR a))))))) = Just a+    prj _ = Nothing++--------------------------------------------------------------------------------
+ src/Feldspar/Software/Frontend.hs view
@@ -0,0 +1,725 @@+{-# language TypeFamilies          #-}+{-# language FlexibleInstances     #-}+{-# language FlexibleContexts      #-}+{-# language MultiParamTypeClasses #-}+{-# language UndecidableInstances  #-}+{-# language Rank2Types            #-}+{-# language ScopedTypeVariables   #-}+{-# language TypeOperators #-}++module Feldspar.Software.Frontend where++import Feldspar.Sugar+import Feldspar.Representation+import Feldspar.Frontend+import Feldspar.Array.Vector hiding (reverse, (++))+import Feldspar.Array.Buffered (ArraysSwap(..))+import Feldspar.Software.Primitive+import Feldspar.Software.Primitive.Backend ()+import Feldspar.Software.Expression+import Feldspar.Software.Representation+import Data.Struct++import Data.Bits (Bits, FiniteBits)+import Data.Complex+import Data.Constraint hiding (Sub)+import Data.Proxy+import Data.List (genericLength)+import Data.Word hiding (Word)++-- syntactic.+import Language.Syntactic (Syntactic(..))+import Language.Syntactic.Functional+import qualified Language.Syntactic as Syn++-- operational-higher.+import qualified Control.Monad.Operational.Higher as Oper++-- imperative-edsl.+import Language.Embedded.Imperative.Frontend.General hiding (Ref, Arr, IArr)+import qualified Language.Embedded.Imperative     as Imp+import qualified Language.Embedded.Imperative.CMD as Imp++-- hardware-edsl.+import qualified Language.Embedded.Hardware.Command.CMD as Hard++-- hmm!+import Feldspar.Hardware.Primitive  (HardwarePrimType(..), HardwarePrimTypeRep(..))+import Feldspar.Hardware.Expression (HType')+import Feldspar.Hardware.Frontend   (HSig, withHType')++import Prelude hiding (length, Word, (<=), (<), (>=), (>))+import qualified Prelude as P++--------------------------------------------------------------------------------+-- * Expressions.+--------------------------------------------------------------------------------++instance Value SExp+  where+    value = sugarSymSoftware . Lit++instance Share SExp+  where+    share = sugarSymSoftware (Let "")++instance Iterate SExp+  where+    loop = sugarSymSoftware ForLoop++instance Cond SExp+  where+    cond = sugarSymSoftware Cond++instance Equality SExp+  where+    (==) = sugarSymPrimSoftware Eq++instance Ordered SExp+  where+    (<)  = sugarSymPrimSoftware Lt+    (<=) = sugarSymPrimSoftware Lte+    (>)  = sugarSymPrimSoftware Gt+    (>=) = sugarSymPrimSoftware Gte++instance Logical SExp+  where+    not  = sugarSymPrimSoftware Not+    (&&) = sugarSymPrimSoftware And+    (||) = sugarSymPrimSoftware Or++instance Multiplicative SExp+  where+    mult = sugarSymPrimSoftware Mul+    div  = sugarSymPrimSoftware Div+    mod  = sugarSymPrimSoftware Mod++instance Bitwise SExp+  where+    complement = sugarSymPrimSoftware BitCompl+    (.&.) = sugarSymPrimSoftware BitAnd+    (.|.) = sugarSymPrimSoftware BitOr+    xor   = sugarSymPrimSoftware BitXor+    sll   = sugarSymPrimSoftware ShiftL+    srl   = sugarSymPrimSoftware ShiftR+    rol   = sugarSymPrimSoftware RotateL+    ror   = sugarSymPrimSoftware RotateR++instance Casting SExp+  where+    i2n = sugarSymPrimSoftware I2N+    i2b = sugarSymPrimSoftware I2B+    b2i = sugarSymPrimSoftware B2I++--------------------------------------------------------------------------------++instance (Bounded a, SType a) => Bounded (SExp a)+  where+    minBound = value minBound+    maxBound = value maxBound++instance (Num a, SType' a) => Num (SExp a)+  where+    fromInteger = value . fromInteger+    (+)         = sugarSymPrimSoftware Add+    (-)         = sugarSymPrimSoftware Sub+    (*)         = sugarSymPrimSoftware Mul+    negate      = sugarSymPrimSoftware Neg+    abs         = error "todo: abs not implemeted for `SExp`"+    signum      = error "todo: signum not implemented for `SExp`"++instance (Fractional a, SType' a) => Fractional (SExp a)+  where+    fromRational = value . fromRational+    (/)          = sugarSymPrimSoftware FDiv++instance (Floating a, SType' a) => Floating (SExp a)+  where+    pi    = sugarSymPrimSoftware Pi+    exp   = sugarSymPrimSoftware Exp+    log   = sugarSymPrimSoftware Log+    sqrt  = sugarSymPrimSoftware Sqrt+    (**)  = sugarSymPrimSoftware Pow+    sin   = sugarSymPrimSoftware Sin+    cos   = sugarSymPrimSoftware Cos+    tan   = sugarSymPrimSoftware Tan+    asin  = sugarSymPrimSoftware Asin+    acos  = sugarSymPrimSoftware Acos+    atan  = sugarSymPrimSoftware Atan+    sinh  = sugarSymPrimSoftware Sinh+    cosh  = sugarSymPrimSoftware Cosh+    tanh  = sugarSymPrimSoftware Tanh+    asinh = sugarSymPrimSoftware Asinh+    acosh = sugarSymPrimSoftware Acosh+    atanh = sugarSymPrimSoftware Atanh++--------------------------------------------------------------------------------++complex :: (Num a, SType' a, SType' (Complex a)) =>+  SExp a -> -- ^ Real+  SExp a -> -- ^ Imaginary+  SExp (Complex a)+complex = sugarSymPrimSoftware Complex++polar :: (Floating a, SType' a, SType' (Complex a)) =>+  SExp a -> -- ^ Magnitude+  SExp a -> -- ^ Phase+  SExp (Complex a)+polar = sugarSymPrimSoftware Polar++real :: (SType' a, SType' (Complex a)) => SExp (Complex a) -> SExp a+real = sugarSymPrimSoftware Real++imaginary :: (SType' a, SType' (Complex a)) => SExp (Complex a) -> SExp a+imaginary = sugarSymPrimSoftware Imag++magnitude :: (RealFloat a, SType' a, SType' (Complex a)) => SExp (Complex a) -> SExp a+magnitude = sugarSymPrimSoftware Magnitude++phase :: (RealFloat a, SType' a, SType' (Complex a)) => SExp (Complex a) -> SExp a+phase = sugarSymPrimSoftware Phase++conjugate :: (RealFloat a, SType' a, SType' (Complex a)) => SExp (Complex a) -> SExp (Complex a)+conjugate = sugarSymPrimSoftware Conjugate++ilog2 :: (FiniteBits a, Integral a, SType' a) => SExp a -> SExp a+ilog2 a = snd $ P.foldr (\ffi vr -> share vr (step ffi)) (a,0) ffis+  where+    step (ff,i) (v,r) = share (b2i (v > fromInteger ff) .<<. value i) $ \shift ->+      (v .>>. i2n shift, r .|. shift)++    -- [(0x1, 0), (0x3, 1), (0xF, 2), (0xFF, 3), (0xFFFF, 4), ...]+    ffis = (`P.zip` [0..])+         $ P.takeWhile (P.<= (2 P.^ (bitSize a `P.div` 2) - 1 :: Integer))+         $ P.map ((subtract 1) . (2 P.^) . (2 P.^))+         $ [(0::Integer)..]+    -- Based on: http://graphics.stanford.edu/~seander/bithacks.html#IntegerLog++--------------------------------------------------------------------------------++foreignImport+  :: ( Syn.Signature sig+     , fi  ~ Syn.SmartFun dom sig+     , sig ~ Syn.SmartSig fi+     , dom ~ Syn.SmartSym fi+     , dom ~ SoftwareDomain+     , Syn.SyntacticN f fi+     , Type SoftwarePrimType (Syn.DenResult sig)+     )+  => String -> Denotation sig -> f+foreignImport str f = sugarSymSoftware (Construct str f)++--------------------------------------------------------------------------------+-- * Instructions.+--------------------------------------------------------------------------------++desugar :: (Syntactic a, Domain a ~ SoftwareDomain) => a -> SExp (Internal a)+desugar = SExp . Syn.desugar++sugar   :: (Syntactic a, Domain a ~ SoftwareDomain) => SExp (Internal a) -> a+sugar   = Syn.sugar . unSExp++resugar+  :: ( Syntactic a+     , Syntactic b+     , Internal a ~ Internal b+     , Domain a   ~ SoftwareDomain+     , Domain b   ~ SoftwareDomain+     )+  => a -> b+resugar = Syn.resugar++--------------------------------------------------------------------------------++instance References Software+  where+    type Reference Software = Ref    +    initRef = Software . fmap Ref . mapStructA (Imp.initRef) . resugar+    newRef  = Software . fmap Ref . mapStructA (const Imp.newRef) $ typeRep+    getRef  = Software . fmap resugar . mapStructA getRef' . unRef+    setRef ref+      = Software+      . sequence_+      . zipListStruct setRef' (unRef ref)+      . resugar+    unsafeFreezeRef+      = Software+      . fmap resugar+      . mapStructA freezeRef'+      . unRef++-- Imp.getRef specialized to software.+getRef' :: forall b . SoftwarePrimType b => Imp.Ref b -> Oper.Program SoftwareCMD (Oper.Param2 SExp SoftwarePrimType) (SExp b)+getRef' = withSType (Proxy :: Proxy b) Imp.getRef++-- Imp.setRef specialized to software.+setRef' :: forall b . SoftwarePrimType b => Imp.Ref b -> SExp b -> Oper.Program SoftwareCMD (Oper.Param2 SExp SoftwarePrimType) ()+setRef' = withSType (Proxy :: Proxy b) Imp.setRef++-- 'Imp.unsafeFreezeRef' specialized to software.+freezeRef' :: forall b . SoftwarePrimType b => Imp.Ref b -> Oper.Program SoftwareCMD (Oper.Param2 SExp SoftwarePrimType) (SExp b)+freezeRef' = withSType (Proxy :: Proxy b) Imp.unsafeFreezeRef++--------------------------------------------------------------------------------++instance Slicable SExp (Arr a)+  where+    slice from len (Arr o l arr) = Arr (o+from) len arr++instance Finite SExp (Arr a)+  where+    length = arrLength++instance Arrays Software+  where+    type Array Software = Arr+    newArr len+      = Software+      $ fmap (Arr 0 len)+      $ mapStructA (const (Imp.newArr len))+      $ typeRep+    initArr elems+      = Software+      $ fmap (Arr 0 len . Node)+      $ Imp.constArr elems+      where len = value $ genericLength elems      +    getArr arr ix+      = Software+      $ fmap resugar+      $ mapStructA (flip getArr' (ix + arrOffset arr))+      $ unArr arr    +    setArr arr ix a+      = Software+      $ sequence_+      $ zipListStruct+         (\a' arr' -> setArr' arr' (ix + arrOffset arr) a')+         (resugar a)+      $ unArr arr+    copyArr arr brr+      = Software+      $ sequence_+      $ zipListStruct (\a b ->+          Imp.copyArr (a, arrOffset arr) (b, arrOffset brr) (length brr))+        (unArr arr)+        (unArr brr)++-- 'Imp.getArr' specialized to software.+getArr' :: forall b . SoftwarePrimType b+  => Imp.Arr Index b -> SExp Index+  -> Oper.Program SoftwareCMD (Oper.Param2 SExp SoftwarePrimType) (SExp b)+getArr' = withSType (Proxy :: Proxy b) Imp.getArr++-- 'Imp.setArr' specialized to software.+setArr' :: forall b . SoftwarePrimType b+  => Imp.Arr Index b -> SExp Index -> SExp b+  -> Oper.Program SoftwareCMD (Oper.Param2 SExp SoftwarePrimType) ()+setArr' = withSType (Proxy :: Proxy b) Imp.setArr++--------------------------------------------------------------------------------++instance Syntax SExp a => Indexed SExp (IArr a)+  where+    type ArrElem (IArr a) = a+    (!) (IArr off len a) ix = resugar $ mapStruct index a+      where+        index :: forall b . SoftwarePrimType b => Imp.IArr Index b -> SExp b+        index arr = sugarSymPrimSoftware+          (GuardVal InternalAssertion "arrIndex: index out of bounds.")+          (ix < len)+          (sugarSymPrimSoftware (ArrIx arr) (ix + off) :: SExp b)++instance Slicable SExp (IArr a)+  where+    slice from len (IArr o l arr) = IArr (o+from) len arr++instance Finite SExp (IArr a)+  where+    length = iarrLength++instance IArrays Software+  where+    type IArray Software = IArr    +    unsafeFreezeArr arr+      = Software+      $ fmap (IArr (arrOffset arr) (length arr))+      $ mapStructA (Imp.unsafeFreezeArr)+      $ unArr arr+    unsafeThawArr iarr+      = Software+      $ fmap (Arr (iarrOffset iarr) (length iarr))+      $ mapStructA (Imp.unsafeThawArr)+      $ unIArr iarr++--------------------------------------------------------------------------------++-- | Short-hand for software pull vectors.+type SPull a = Pull SExp a++-- | Short-hand for software push vectors.+type SPush a = Push Software a++-- | Short-hand for software manifest vectors.+type SManifest a = Manifest Software a++instance Syntax SExp (SExp a) => Pushy Software (IArr (SExp a)) (SExp a)+  where+    toPush iarr = toPush (M iarr :: Manifest Software (SExp a))++instance ViewManifest Software (IArr (SExp a)) (SExp a)+  where+    viewManifest = Just . M++instance Manifestable Software (IArr (SExp a)) (SExp a)++instance ArraysSwap Software+  where+    unsafeArrSwap arr brr = Software $ sequence_ $ zipListStruct Imp.unsafeSwapArr+      (unArr arr)+      (unArr brr)++--------------------------------------------------------------------------------++instance Control Software+  where+    iff c t f+      = Software+      $ Imp.iff (resugar c)+          (unSoftware t)+          (unSoftware f)++instance Loop Software+  where+    while c body+      = Software+      $ Imp.while+          (fmap resugar $ unSoftware c)+          (unSoftware body)+    for lower step upper body+      = Software+      $ Imp.for+          (resugar lower, step, Imp.Incl $ resugar upper)+          (unSoftware . body . resugar)++instance Assert Software+  where+    assert = assertLabel $ UserAssertion ""++assertLabel :: AssertionLabel -> SExp Bool -> String -> Software ()+assertLabel lbl cond msg = Software $ Oper.singleInj $ Assert lbl cond msg++--------------------------------------------------------------------------------+-- ** Software instructions.+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- *** Assertions.++guard :: Syntax SExp a => SExp Bool -> String -> a -> a+guard = guardLabel $ UserAssertion ""++guardLabel :: Syntax SExp a => AssertionLabel -> SExp Bool -> String -> a -> a+guardLabel lbl cond msg = sugarSymSoftware (GuardVal lbl msg) cond++hint :: (Syntax SExp a, Syntax SExp b, Primitive SExp (Internal a))+  => a -- ^ Value to be used in invariant.+  -> b -- ^ Result value.+  -> b+hint x y = sugarSymSoftware HintVal x y++--------------------------------------------------------------------------------+-- *** File handling.++-- | Open a file.+fopen :: FilePath -> IOMode -> Software Handle+fopen file = Software . Imp.fopen file++-- | Close a file.+fclose :: Handle -> Software ()+fclose = Software . Imp.fclose++-- | Check for end of file.+feof :: Handle -> Software (SExp Bool)+feof = Software . Imp.feof++-- | Put a primitive value to a handle.+fput :: (Formattable a, SType' a)+    => Handle+    -> String  -- ^ Prefix.+    -> SExp a  -- ^ Expression to print.+    -> String  -- ^ Suffix.+    -> Software ()+fput h pre e post = Software $ Imp.fput h pre e post++-- | Get a primitive value from a handle.+fget :: (Formattable a, SType' a) => Handle -> Software (SExp a)+fget = Software . Imp.fget++-- | Handle to \stdin\.+stdin :: Handle+stdin = Imp.stdin++-- | Handle to \stdout\.+stdout :: Handle+stdout = Imp.stdout++--------------------------------------------------------------------------------+-- *** Printing.++class PrintfType r+  where+    fprf :: Handle -> String -> [Imp.PrintfArg SExp SoftwarePrimType] -> r++instance (a ~ ()) => PrintfType (Software a)+  where+    fprf h form = Software . Oper.singleInj . Imp.FPrintf h form . reverse++instance (Formattable a, SType' a, PrintfType r) => PrintfType (SExp a -> r)+  where+    fprf h form as = \a -> fprf h form (Imp.PrintfArg a : as)++-- | Print to a handle. Accepts a variable number of arguments.+fprintf :: PrintfType r => Handle -> String -> r+fprintf h format = fprf h format []++-- | Print to @stdout@. Accepts a variable number of arguments.+printf :: PrintfType r => String -> r+printf = fprintf Imp.stdout++--------------------------------------------------------------------------------+-- *** Memory.++-- | Software argument specialized to software primitives.+type SArg = Argument SoftwarePrimType++-- | Establish a memory-mapping to a hardware signature.+mmap :: String -> HSig a -> Software (Address a)+mmap address sig =+  do pointer <- Software $ Oper.singleInj $ MMap address sig+     return $ Address pointer sig++-- | Call a memory-mapped component.+call :: Address a -> SArg (Soften a) -> Software ()+call address arg = Software $ Oper.singleInj $ Call address arg++-- | ...+nil :: SArg ()+nil = Nil++-- | ...+(>:) :: forall a b . (SType' a, HType' a, Integral a)+  => Ref (SExp a) -> SArg b -> SArg (Ref (SExp a) -> b)+(>:) = withHType' (Proxy :: Proxy a) ARef++(>.) :: forall a b . (SType' a, HType' a, Integral a)+  => SExp a -> SArg b -> SArg (Ref (SExp a) -> b)+(>.) v = undefined++-- | ...+(>>:) :: forall a b . (SType' a, HType' a, Integral a)+  => Arr (SExp a) -> SArg b -> SArg (Arr (SExp a) -> b)+(>>:) = withHType' (Proxy :: Proxy a) AArr++(>>.) :: forall a b . (SType' a, HType' a, Integral a)+  => IArr (SExp a) -> SArg b -> SArg (Arr (SExp a) -> b)+(>>.) = undefined++infixr 1 >:, >>:++--------------------------------------------------------------------------------+-- *** C specific.++-- | Create a null pointer+newPtr :: SType' a => Software (Ptr a)+newPtr = newNamedPtr "p"++-- | Create a named null pointer+--+-- The provided base name may be appended with a unique identifier to avoid name+-- collisions.+newNamedPtr :: SType' a => String -> Software (Ptr a)+newNamedPtr = Software . Imp.newNamedPtr++-- | Cast a pointer to an array+ptrToArr :: SType' a => Ptr a -> SExp Length -> Software (Arr (SExp a))+ptrToArr ptr len = fmap (Arr 0 len . Node) $ Software $ Imp.ptrToArr ptr++-- | Create a pointer to an abstract object. The only thing one can do with such+-- objects is to pass them to 'callFun' or 'callProc'.+newObject+    :: String  -- ^ Object type+    -> Bool    -- ^ Pointed?+    -> Software Object+newObject = newNamedObject "obj"++-- | Create a pointer to an abstract object. The only thing one can do with such+-- objects is to pass them to 'callFun' or 'callProc'.+--+-- The provided base name may be appended with a unique identifier to avoid name+-- collisions.+newNamedObject+    :: String  -- ^ Base name+    -> String  -- ^ Object type+    -> Bool    -- ^ Pointed?+    -> Software Object+newNamedObject base t p = Software $ Imp.newNamedObject base t p++-- | Add an @#include@ statement to the generated code+addInclude :: String -> Software ()+addInclude = Software . Imp.addInclude++-- | Add a global definition to the generated code+--+-- Can be used conveniently as follows:+--+-- > {-# LANGUAGE QuasiQuotes #-}+-- >+-- > import Feldspar.IO+-- >+-- > prog = do+-- >     ...+-- >     addDefinition myCFunction+-- >     ...+-- >   where+-- >     myCFunction = [cedecl|+-- >       void my_C_function( ... )+-- >       {+-- >           // C code+-- >           // goes here+-- >       }+-- >       |]+addDefinition :: Imp.Definition -> Software ()+addDefinition = Software . Imp.addDefinition++-- | Declare an external function+addExternFun :: SType' res+    => String    -- ^ Function name+    -> proxy res -- ^ Proxy for expression and result type+    -> [FunArg SExp SoftwarePrimType]+                 -- ^ Arguments (only used to determine types)+    -> Software ()+addExternFun fun res args = Software $ Imp.addExternFun fun res args++-- | Declare an external procedure+addExternProc+    :: String -- ^ Procedure name+    -> [FunArg SExp SoftwarePrimType]+              -- ^ Arguments (only used to determine types)+    -> Software ()+addExternProc proc args = Software $ Imp.addExternProc proc args++-- | Call a function+callFun :: SType' a+    => String -- ^ Function name+    -> [FunArg SExp SoftwarePrimType]+              -- ^ Arguments+    -> Software (SExp a)+callFun fun as = Software $ Imp.callFun fun as++-- | Call a procedure+callProc+    :: String -- ^ Function name+    -> [FunArg SExp SoftwarePrimType]+              -- ^ Arguments+    -> Software ()+callProc fun as = Software $ Imp.callProc fun as++-- | Call a procedure and assign its result+callProcAssign :: Assignable obj+    => obj    -- ^ Object to which the result should be assigned+    -> String -- ^ Procedure name+    -> [FunArg SExp SoftwarePrimType]+              -- ^ Arguments+    -> Software ()+callProcAssign obj fun as = Software $ Imp.callProcAssign obj fun as++-- | Declare and call an external function+externFun :: SType' res+    => String -- ^ Procedure name+    -> [FunArg SExp SoftwarePrimType]+              -- ^ Arguments+    -> Software (SExp res)+externFun fun args = Software $ Imp.externFun fun args++-- | Declare and call an external procedure+externProc+    :: String -- ^ Procedure name+    -> [FunArg SExp SoftwarePrimType]+              -- ^ Arguments+    -> Software ()+externProc proc args = Software $ Imp.externProc proc args++-- | Generate code into another translation unit+inModule :: String -> Software () -> Software ()+inModule mod = Software . Imp.inModule mod . unSoftware++-- | Get current time as number of seconds passed today+getTime :: Software (SExp Double)+getTime = Software Imp.getTime++-- | Constant string argument+strArg :: String -> FunArg SExp SoftwarePrimType+strArg = Imp.strArg++-- | Value argument+valArg :: SoftwarePrimType a => SExp a -> FunArg SExp SoftwarePrimType+valArg = Imp.valArg++-- | Reference argument+refArg :: SoftwarePrimType (Internal a) => Ref a -> FunArg SExp SoftwarePrimType+refArg (Ref r) = Imp.refArg (extractNode r)++-- | Mutable array argument+arrArg :: SoftwarePrimType (Internal a) => Arr a -> FunArg SExp SoftwarePrimType+arrArg (Arr o _ a) = Imp.offset (Imp.arrArg (extractNode a)) o++-- | Immutable array argument+iarrArg :: SoftwarePrimType (Internal a) => IArr a -> FunArg SExp SoftwarePrimType+iarrArg (IArr o _ a) = Imp.offset (Imp.iarrArg (extractNode a)) o++-- | Abstract object argument+objArg :: Object -> FunArg SExp SoftwarePrimType+objArg = Imp.objArg++-- | Named constant argument+constArg+    :: String  -- ^ Type+    -> String  -- ^ Named constant+    -> FunArg SExp SoftwarePrimType+constArg = Imp.constArg++-- | Modifier that takes the address of another argument+addr :: FunArg SExp SoftwarePrimType -> FunArg SExp SoftwarePrimType+addr = Imp.addr++-- | Modifier that dereferences another argument+deref :: FunArg SExp SoftwarePrimType -> FunArg SExp SoftwarePrimType+deref = Imp.deref+  +--------------------------------------------------------------------------------+--+--------------------------------------------------------------------------------++-- Swap an `Imp.FreePred` constraint with a `SoftwarePrimType` one.+withSType :: forall a b . Proxy a+  -> (Imp.FreePred SExp a => b)+  -> (SoftwarePrimType  a => b)+withSType _ f = case predicateDict (softwareRep :: SoftwarePrimTypeRep a) of+  Dict -> f++-- Proves that a type from `SoftwarePrimTypeRep` satisfies `Imp.FreePred`.+predicateDict :: SoftwarePrimTypeRep a -> Dict (Imp.FreePred SExp a)+predicateDict rep = case rep of+  BoolST   -> Dict+  Int8ST   -> Dict+  Int16ST  -> Dict+  Int32ST  -> Dict+  Int64ST  -> Dict+  Word8ST  -> Dict+  Word16ST -> Dict+  Word32ST -> Dict+  Word64ST -> Dict+  FloatST  -> Dict+  ComplexFloatST  -> Dict+  ComplexDoubleST -> Dict++--------------------------------------------------------------------------------
+ src/Feldspar/Software/Marshal.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Feldspar.Software.Marshal where -- based on raw-feldspar/run/marshal++import Feldspar.Frontend (Finite(..), Indexed(..), Arrays(..), IArrays(..), value, shareM, for)+import Feldspar.Array.Vector (Manifest(..))++import Feldspar.Software (Syntax, Internal, Software, SType', SExp)+import Feldspar.Software.Primitive (SoftwarePrimType)+import Feldspar.Software.Representation (Arr, IArr)+import Feldspar.Software.Frontend (fput, fget, fprintf)++import Language.Embedded.Imperative.CMD (Formattable, Handle, stdout, stdin)++import Data.Typeable+import Data.Int+import Data.Word++import Control.Monad (ap, replicateM)++import qualified Prelude as P+import Prelude hiding (length)++--------------------------------------------------------------------------------+-- *+--------------------------------------------------------------------------------++newtype Parser a = Parser {runParser :: String -> (a,String)}++instance Functor Parser+  where+    fmap = (<$>)++instance Applicative Parser+  where+    pure  = return+    (<*>) = ap++instance Monad Parser+  where+    return a   = Parser $ \s -> (a,s)+    (>>=)  p k = Parser $ \s -> let (a,s') = runParser p s in runParser (k a) s'++readParser :: forall a . (Read a, Typeable a) => Parser a+readParser = Parser $ \s -> case reads s of+  [(a,s')] -> (a,s')+  _        -> error $ "cannot read " ++ show s++parse :: Parser a -> String -> a+parse = (fst .) . runParser++--------------------------------------------------------------------------------+-- **++class MarshalHaskell a+  where+    fromHaskell :: a -> String+    default fromHaskell :: Show a => a -> String+    fromHaskell = show++    toHaskell :: Parser a+    default toHaskell :: (Read a, Typeable a) => Parser a+    toHaskell = readParser++instance MarshalHaskell Int+instance MarshalHaskell Int8+instance MarshalHaskell Int16+instance MarshalHaskell Int32+instance MarshalHaskell Int64++instance MarshalHaskell Word+instance MarshalHaskell Word8+instance MarshalHaskell Word16+instance MarshalHaskell Word32+instance MarshalHaskell Word64++instance (MarshalHaskell a, MarshalHaskell b) => MarshalHaskell (a,b)+  where+    fromHaskell (a,b) = unwords [fromHaskell a, fromHaskell b]+    toHaskell         = (,) <$> toHaskell <*> toHaskell++instance MarshalHaskell a => MarshalHaskell [a]+  where+    fromHaskell as = unwords $ show (P.length as) : map fromHaskell as+    toHaskell      = do+        len <- toHaskell+        replicateM len toHaskell++--------------------------------------------------------------------------------+-- **++class MarshalHaskell (Haskelly a) => MarshalFeldspar a+  where+    type Haskelly a++    fwrite :: Handle -> a -> Software ()+    default fwrite :: (SType' b, Formattable b, a ~ SExp b) => Handle -> a -> Software ()+    fwrite h i = fput h "" i ""++    fread :: Handle -> Software a+    default fread :: (SType' b, Formattable b, a ~ SExp b) => Handle -> Software a+    fread = fget++writeStd :: MarshalFeldspar a => a -> Software ()+writeStd = fwrite stdout++readStd :: MarshalFeldspar a => Software a+readStd = fread stdin++instance MarshalFeldspar (SExp Int8)   where type Haskelly (SExp Int8)   = Int8+instance MarshalFeldspar (SExp Int16)  where type Haskelly (SExp Int16)  = Int16+instance MarshalFeldspar (SExp Int32)  where type Haskelly (SExp Int32)  = Int32+instance MarshalFeldspar (SExp Int64)  where type Haskelly (SExp Int64)  = Int64++instance MarshalFeldspar (SExp Word8)  where type Haskelly (SExp Word8)  = Word8+instance MarshalFeldspar (SExp Word16) where type Haskelly (SExp Word16) = Word16+instance MarshalFeldspar (SExp Word32) where type Haskelly (SExp Word32) = Word32+instance MarshalFeldspar (SExp Word64) where type Haskelly (SExp Word64) = Word64++instance (MarshalFeldspar a, MarshalFeldspar b) => MarshalFeldspar (a,b)+  where+    type Haskelly (a,b) = (Haskelly a, Haskelly b)+    fwrite h (a,b) = fwrite h a >> fprintf h " " >> fwrite h b+    fread  h       = (,) <$> fread h <*> fread h++--------------------------------------------------------------------------------+-- **++instance (MarshalHaskell (Internal a), MarshalFeldspar a, Syntax SExp a) => MarshalFeldspar (Arr a)+  where+    type Haskelly (Arr a) = [Internal a]++    fwrite h arr = do+      len :: SExp Word32 <- shareM (length arr)+      fput h "" len ""+      for 0 1 (len-1) $ \i -> do+        a <- getArr arr i+        fwrite h a+        fprintf h " "++    fread h = do+      len <- fget h+      arr <- newArr len+      for 0 1 (len-1) $ \i -> do+        a <- fread h+        setArr arr i a+      return arr++instance (MarshalHaskell (Internal a), MarshalFeldspar a, Syntax SExp a) => MarshalFeldspar (IArr a)+  where+    type Haskelly (IArr a) = [Internal a]++    fwrite h arr = do+      len :: SExp Word32 <- shareM (length arr)+      fput h "" len ""+      for 0 1 (len-1) $ \i -> do+        fwrite h ((!) arr i)+        fprintf h " "++    fread h = do+      len <- fget h+      arr <- newArr len+      for 0 1 (len-1) $ \i -> do+        a <- fread h+        setArr arr i a+      iarr <- unsafeFreezeArr arr+      return iarr++instance (MarshalHaskell (Internal a), MarshalFeldspar a, Syntax SExp a) => MarshalFeldspar (Manifest Software a)+  where+    type Haskelly (Manifest Software a) = [Internal a]++    fwrite h arr = do+      len :: SExp Word32 <- shareM (length arr)+      fput h "" len ""+      for 0 1 (len-1) $ \i -> do+        let iarr = manifest arr+        fwrite h ((!) iarr i)+        fprintf h " "++    fread h = do+      len <- fget h+      arr <- newArr len+      for 0 1 (len-1) $ \i -> do+        a <- fread h+        setArr arr i a+      iarr <- unsafeFreezeArr arr+      return (M iarr)++--------------------------------------------------------------------------------+-- **++connectStdIO :: (MarshalFeldspar a, MarshalFeldspar b) => (a -> Software b) -> Software ()+connectStdIO f = (readStd >>= f) >>= writeStd++--------------------------------------------------------------------------------
+ src/Feldspar/Software/Optimize.hs view
@@ -0,0 +1,310 @@+{-# language GADTs               #-}+{-# language TypeOperators       #-}+{-# language PatternSynonyms     #-}+{-# language ViewPatterns        #-}+{-# language FlexibleContexts    #-}+{-# language ScopedTypeVariables #-}++module Feldspar.Software.Optimize where++import Feldspar.Representation+import Feldspar.Software.Primitive+import Feldspar.Software.Expression+import Data.Struct++import Control.Monad.Writer hiding (Any (..))+import Data.Maybe+import Data.Constraint (Dict (..))+import Data.Set (Set)+import qualified Data.Monoid as Monoid+import qualified Data.Set as Set++-- syntactic.+import Language.Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Tuple+import Language.Syntactic.Functional.Sharing++--------------------------------------------------------------------------------+-- * Optimize software expressions.+--------------------------------------------------------------------------------++viewLit :: ASTF SoftwareDomain a -> Maybe a+viewLit lit | Just (Lit a) <- prj lit = Just a+viewLit _ = Nothing++witInteger :: ASTF SoftwareDomain a -> Maybe (Dict (Integral a, Ord a))+witInteger a = case getDecor a of+  ValT (Node Int8ST)   -> Just Dict+  ValT (Node Int16ST)  -> Just Dict+  ValT (Node Int32ST)  -> Just Dict+  ValT (Node Int64ST)  -> Just Dict+  ValT (Node Word8ST)  -> Just Dict+  ValT (Node Word16ST) -> Just Dict+  ValT (Node Word32ST) -> Just Dict+  ValT (Node Word64ST) -> Just Dict+  _ -> Nothing++isExact :: ASTF SoftwareDomain a -> Bool+isExact = isJust . witInteger++-- | projection with a stronger constraint to allow using it in+--   bidirectional patterns.+prjBi :: (sub :<: sup) => sup sig -> Maybe (sub sig)+prjBi = prj+++--------------------------------------------------------------------------------++pattern SymP t s <- Sym ((prjBi -> Just s) :&: ValT t)+  where+    SymP t s = Sym ((inj s) :&: ValT t)++pattern VarP t v <- Sym ((prjBi -> Just (VarT v)) :&: t)+  where+    VarP t v = Sym (inj (VarT v) :&: t)++pattern LamP t v body <- Sym ((prjBi -> Just (LamT v)) :&: t) :$ body+  where+    LamP t v body = Sym (inj (LamT v) :&: t) :$ body+++--------------------------------------------------------------------------------++pattern LitP :: () => (Eq a, Show a)+  => STypeRep a -> a -> ASTF SoftwareDomain a+  +pattern AddP :: () => (Num a, SoftwarePrimType a)+  => STypeRep a -> ASTF SoftwareDomain a -> ASTF SoftwareDomain a+  -> ASTF SoftwareDomain a++pattern SubP :: () => (Num a, SoftwarePrimType a)+  => STypeRep a -> ASTF SoftwareDomain a -> ASTF SoftwareDomain a+  -> ASTF SoftwareDomain a++pattern MulP :: () => (Num a, SoftwarePrimType a)+  => STypeRep a -> ASTF SoftwareDomain a -> ASTF SoftwareDomain a+  -> ASTF SoftwareDomain a++pattern NegP :: () => (Num a, SoftwarePrimType a)+  => STypeRep a -> ASTF SoftwareDomain a -> ASTF SoftwareDomain a++pattern DivP :: () => (Integral a, SoftwarePrimType a)+  => STypeRep a -> ASTF SoftwareDomain a -> ASTF SoftwareDomain a+  -> ASTF SoftwareDomain a++pattern ModP :: () => (Integral a, SoftwarePrimType a)+  => STypeRep a -> ASTF SoftwareDomain a -> ASTF SoftwareDomain a+  -> ASTF SoftwareDomain a+++--------------------------------------------------------------------------------++pattern NonLitP <- (viewLit -> Nothing)++pattern LitP t a <- Sym ((prj -> Just (Lit a)) :&: ValT t)+  where+    LitP t a = Sym (inj (Lit a) :&: ValT t)++pattern AddP t a b <- SymP t Add :$ a :$ b+  where+    AddP t a b = simplifyUp $ SymP t Add :$ a :$ b+  +pattern SubP t a b <- SymP t Sub :$ a :$ b+  where+    SubP t a b = simplifyUp $ SymP t Sub :$ a :$ b++pattern MulP t a b <- SymP t Mul :$ a :$ b+  where+    MulP t a b = simplifyUp $ SymP t Mul :$ a :$ b++pattern NegP t a <- SymP t Neg :$ a+  where+    NegP t a = simplifyUp $ SymP t Neg :$ a++pattern DivP t a b <- SymP t Div :$ a :$ b+  where+    DivP t a b = simplifyUp $ SymP t Div :$ a :$ b++pattern ModP t a b <- SymP t Mod :$ a :$ b+  where+    ModP t a b = simplifyUp $ SymP t Mod :$ a :$ b+++--------------------------------------------------------------------------------++simplifyUp :: ASTF SoftwareDomain a -> ASTF SoftwareDomain a+-- Addition with zero.+simplifyUp (AddP t (LitP _ 0) b) | isExact b = b+simplifyUp (AddP t a (LitP _ 0)) | isExact a = a+-- Simplify additions with literals.+simplifyUp (AddP t (AddP _ a (LitP _ b)) (LitP _ c)) | isExact a+  = AddP t a (LitP t (b+c))+simplifyUp (AddP t (SubP _ a (LitP _ b)) (LitP _ c)) | isExact a+  = AddP t a (LitP t (c-b))+simplifyUp (AddP t a (LitP _ b)) | Just Dict <- witInteger a, b < 0+  = SubP t a (LitP t (negate b))+-- Subtraction with zero.+simplifyUp (SubP t (LitP _ 0) b) | isExact b = NegP t b+simplifyUp (SubP t a (LitP _ 0)) | isExact a = a+-- Simplify subtractions with literals.+simplifyUp (SubP t (AddP _ a (LitP _ b)) (LitP _ c)) | isExact a+  = AddP t a (LitP t (b-c))+simplifyUp (SubP t (SubP _ a (LitP _ b)) (LitP _ c)) | isExact a+  = SubP t a (LitP t (b+c))+simplifyUp (SubP t a (LitP _ b)) | Just Dict <- witInteger a, b < 0+  = AddP t a (LitP t (negate b))+-- Multiplication with zero.+simplifyUp (MulP t (LitP _ 0) b) | isExact b = LitP t 0+simplifyUp (MulP t a (LitP _ 0)) | isExact a = LitP t 0+-- Multiplication with one.+simplifyUp (MulP t (LitP _ 1) b) | isExact b = b+simplifyUp (MulP t a (LitP _ 1)) | isExact a = a+-- Simplify multiplications with literals.+simplifyUp (MulP t (MulP _ a (LitP _ b)) (LitP _ c)) | isExact a+  = MulP t a (LitP t (b*c))+-- Simplify negations.+simplifyUp (NegP t (NegP _ a))   | isExact a = a+simplifyUp (NegP t (AddP _ a b)) | isExact a = SubP t (NegP t a) b+simplifyUp (NegP t (SubP _ a b)) | isExact a = SubP t b a+simplifyUp (NegP t (MulP _ a b)) | isExact a = MulP t a (NegP t b)+-- Move literals to the right.+simplifyUp (AddP t a@(LitP _ _) b@NonLitP) | isExact a = AddP t b a+simplifyUp (SubP t a@(LitP _ _) b@NonLitP) | isExact a = AddP t (NegP t b) a+simplifyUp (MulP t a@(LitP _ _) b@NonLitP) | isExact a = MulP t b a+-- Simplify not-expressions.+-- Not sure (yet) why I can't write `simplifyUp (NotP _ (NotP _ a)) = a`+simplifyUp (SymP _ Not :$ (SymP _ Not :$ a)) = a+simplifyUp (SymP t Not :$ (SymP _ Lt :$ a :$ b))+  = simplifyUp $ SymP t Gte :$ a :$ b+simplifyUp (SymP t Not :$ (SymP _ Gt :$ a :$ b))+  = simplifyUp $ SymP t Lte :$ a :$ b+simplifyUp (SymP t Not :$ (SymP _ Lte :$ a :$ b))+  = simplifyUp $ SymP t Gt :$ a :$ b+simplifyUp (SymP t Not :$ (SymP _ Gte :$ a :$ b))+  = simplifyUp $ SymP t Lt :$ a :$ b+-- Simplify and-expressions.+simplifyUp (SymP _ And :$ LitP t False :$ _) = LitP t False+simplifyUp (SymP _ And :$ _ :$ LitP t False) = LitP t False+simplifyUp (SymP _ And :$ LitP t True :$ b)  = b+simplifyUp (SymP _ And :$ a :$ LitP t True)  = a+-- Simplify or-expressions.+simplifyUp (SymP _ Or :$ LitP t False :$ b) = b+simplifyUp (SymP _ Or :$ a :$ LitP t False) = a+simplifyUp (SymP _ Or :$ LitP t True :$ _)  = LitP t True+simplifyUp (SymP _ Or :$ _ :$ LitP t True)  = LitP t True+-- Simplify conditional expressions.+simplifyUp (SymP _ Cond :$ LitP _ True  :$ t :$ _)  = t+simplifyUp (SymP _ Cond :$ LitP _ False :$ _ :$ f)  = f+simplifyUp (SymP _ Cond :$ c :$ t :$ f) | equal t f = t+-- Simplify pairs.+simplifyUp (SymP t Pair :$ (SymP _ Fst :$ a) :$ (SymP _ Snd :$ b))+    | alphaEq a b+    , ValT t' <- getDecor a+    , Just Dict <- softwareTypeEq t t' = a+simplifyUp (SymP t Fst :$ (SymP _ Pair :$ a :$ _)) = a+simplifyUp (SymP t Snd :$ (SymP _ Pair :$ _ :$ a)) = a+-- +simplifyUp a = constFold a+  -- `constFold` here ensures that `simplifyUp` does not produce any expressions+  -- that can be statically constant folded. This property is needed, e.g. to+  -- fully simplify the expression `negate (2*x)`. The simplification should go+  -- as follows:+  --+  --     negate (2*x)  ->  negate (x*2)  ->  x * negate 2  ->  x*(-2)+  --+  -- There is no explicit rule for the last step; it is done by `constFold`.+  -- Furthermore, this constant folding would not be performed by `simplifyM`+  -- since it never sees the sub-expression `negate 2`. (Note that the constant+  -- folding in `simplifyM` is still needed, because constructs such as+  -- `ForLoop` cannot be folded by simple literal propagation.)+  --+  -- In order to see that `simplifyUp` doesn't produce any "junk"+  -- (sub-expressions that can be folded by `constFold`), we reason as follows:+  --+  --   * Assume that the arguments of the top-level node are junk-free+  --   * `simplifyUp` will either apply an explicit rewrite or apply `constFold`+  --   * In the latter case, the result will be junk-free+  --   * In case of an explicit rewrite, the resulting expression is constructed+  --     by applying `simplifyUp` to each newly introduced node; thus the+  --     resulting expression must be junk-free+++--------------------------------------------------------------------------------++-- | Reduce an expression to a literal if the following conditions are met:+--+-- * The top-most symbol can be evaluated statically (i.g. not a variable or a+--   lifted side-effecting program)+-- * All immediate sub-terms are literals+-- * The type of the expression is an allowed type for literals (e.g. not a+--   function)+--+-- Note that this function only folds the top-level node of an expressions (if+-- possible). It does not reduce an expression like @1+(2+3)@ where the+-- sub-expression @2+3@ is not a literal.+constFold :: ASTF SoftwareDomain a -> ASTF SoftwareDomain a+constFold e+    | constArgs e, canFold e, ValT t@(Node _) <- getDecor e+    = LitP t (evalClosed e)+  where+    canFold :: ASTF SoftwareDomain a -> Bool+    canFold = simpleMatch (\(s :&: ValT _) _ -> go s)+      where+        go :: SoftwareConstructs sig+           -> Bool+        go var | Just (FreeVar _)         <- prj var = False+        go ix  | Just (ArrIx _)           <- prj ix  = False+        go bid | Just (_ :: BindingT sig) <- prj bid = False+        go _   = True+constFold e = e++-- | Check whether all arguments of a symbol are literals+constArgs :: AST SoftwareDomain sig -> Bool+constArgs (Sym _)         = True+constArgs (s :$ LitP _ _) = constArgs s+constArgs _               = False+++--------------------------------------------------------------------------------++type Opt = Writer (Set Name, Monoid.Any)++freeVar :: Name -> Opt ()+freeVar v = tell (Set.singleton v, mempty)++bindVar :: Name -> Opt a -> Opt a+bindVar v = censor (\(vars, unsafe) -> (Set.delete v vars, unsafe))++tellUnsafe :: Opt ()+tellUnsafe = tell (mempty, Monoid.Any True)++simplifyM :: ASTF SoftwareDomain a -> Opt (ASTF SoftwareDomain a)+simplifyM exp = case exp of+    (VarP _ v)      -> freeVar v >> return exp+    (LamP t v body) -> bindVar v $ fmap (LamP t v) $ simplifyM body+    _               -> simpleMatch (\s@(v :&: t) args ->+      do (exp', (vars, Monoid.Any unsafe)) <- listen+           (simplifyUp . appArgs (Sym s) <$> mapArgsM simplifyM args)+         case () of+           _ | Just (FreeVar _) <- prj v -> tellUnsafe >> return exp'+           _ | Just (ArrIx _)   <- prj v -> tellUnsafe >> return exp'+           _ | null vars && not unsafe, ValT t'@(Node _) <- t+             -> return $ LitP t' $ evalClosed exp'+           _ -> return exp'+      )+      exp+  -- Array indexing is actually not unsafe. It's more like+  -- an expression with a free variable. But setting the+  -- unsafe flag does the trick.+  -- Constant fold if expression is closed and does not+  -- contain unsafe operations.+++--------------------------------------------------------------------------------++optimize :: ASTF SoftwareDomain a -> ASTF SoftwareDomain a+optimize = fst . runWriter . simplifyM+++--------------------------------------------------------------------------------
+ src/Feldspar/Software/Primitive.hs view
@@ -0,0 +1,441 @@+{-# language GADTs                 #-}+{-# language StandaloneDeriving    #-}+{-# language TypeOperators         #-}+{-# language FlexibleInstances     #-}+{-# language FlexibleContexts      #-}+{-# language UndecidableInstances  #-}+{-# language MultiParamTypeClasses #-}+{-# language TypeFamilies          #-}++{-# options_ghc -fwarn-incomplete-patterns #-}++module Feldspar.Software.Primitive where++import Feldspar.Representation+import Data.Struct++import Data.Array ((!))+import Data.Bits (Bits)+import Data.Complex+import Data.Int+import Data.Word+import Data.List (genericTake)+import Data.Typeable hiding (TypeRep)+import Data.Constraint hiding (Sub)+import qualified Data.Bits as Bits++-- syntactic.+import Language.Syntactic+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Tuple+import qualified Language.Syntactic as Syn++-- imperative-edsl.+import Language.Embedded.Expression+import qualified Language.Embedded.Imperative.CMD as Imp (IArr(..))++--------------------------------------------------------------------------------+-- * Software primitives.+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- ** Software primitive types.++-- | Representation of supported, primitive software types.+data SoftwarePrimTypeRep a+  where+    -- booleans+    BoolST   :: SoftwarePrimTypeRep Bool+    -- signed numbers.+    Int8ST   :: SoftwarePrimTypeRep Int8+    Int16ST  :: SoftwarePrimTypeRep Int16+    Int32ST  :: SoftwarePrimTypeRep Int32+    Int64ST  :: SoftwarePrimTypeRep Int64+    -- unsigned numbers.+    Word8ST  :: SoftwarePrimTypeRep Word8+    Word16ST :: SoftwarePrimTypeRep Word16+    Word32ST :: SoftwarePrimTypeRep Word32+    Word64ST :: SoftwarePrimTypeRep Word64+    -- floating point numbers.+    FloatST  :: SoftwarePrimTypeRep Float+    DoubleST :: SoftwarePrimTypeRep Double+    -- complex numbers.+    ComplexFloatST  :: SoftwarePrimTypeRep (Complex Float)+    ComplexDoubleST :: SoftwarePrimTypeRep (Complex Double)++deriving instance Eq       (SoftwarePrimTypeRep a)+deriving instance Show     (SoftwarePrimTypeRep a)+deriving instance Typeable (SoftwarePrimTypeRep a)++instance Inhabited (Complex Float)+  where+    reset = 0 :+ 0++instance Inhabited (Complex Double)+  where+    reset = 0 :+ 0++--------------------------------------------------------------------------------++-- | Class of supported, primitive software types.+class (Eq a, Show a, Typeable a, Inhabited a) => SoftwarePrimType a+  where+    softwareRep :: SoftwarePrimTypeRep a++instance SoftwarePrimType Bool   where softwareRep = BoolST+instance SoftwarePrimType Int8   where softwareRep = Int8ST+instance SoftwarePrimType Int16  where softwareRep = Int16ST+instance SoftwarePrimType Int32  where softwareRep = Int32ST+instance SoftwarePrimType Int64  where softwareRep = Int64ST+instance SoftwarePrimType Word8  where softwareRep = Word8ST+instance SoftwarePrimType Word16 where softwareRep = Word16ST+instance SoftwarePrimType Word32 where softwareRep = Word32ST+instance SoftwarePrimType Word64 where softwareRep = Word64ST+instance SoftwarePrimType Float  where softwareRep = FloatST+instance SoftwarePrimType Double where softwareRep = DoubleST+instance SoftwarePrimType (Complex Float)  where softwareRep = ComplexFloatST+instance SoftwarePrimType (Complex Double) where softwareRep = ComplexDoubleST++-- | Compare two primitive software types for equality.+softwarePrimTypeEq :: SoftwarePrimTypeRep a -> SoftwarePrimTypeRep b -> Maybe (Dict (a ~ b))+softwarePrimTypeEq (BoolST)   (BoolST)   = Just Dict+softwarePrimTypeEq (Int8ST)   (Int8ST)   = Just Dict+softwarePrimTypeEq (Int16ST)  (Int16ST)  = Just Dict+softwarePrimTypeEq (Int32ST)  (Int32ST)  = Just Dict+softwarePrimTypeEq (Int64ST)  (Int64ST)  = Just Dict+softwarePrimTypeEq (Word8ST)  (Word8ST)  = Just Dict+softwarePrimTypeEq (Word16ST) (Word16ST) = Just Dict+softwarePrimTypeEq (Word32ST) (Word32ST) = Just Dict+softwarePrimTypeEq (Word64ST) (Word64ST) = Just Dict+softwarePrimTypeEq (FloatST)  (FloatST)  = Just Dict+softwarePrimTypeEq (DoubleST) (DoubleST) = Just Dict+softwarePrimTypeEq (ComplexFloatST)  (ComplexFloatST)  = Just Dict+softwarePrimTypeEq (ComplexDoubleST) (ComplexDoubleST) = Just Dict+softwarePrimTypeEq _          _          = Nothing++-- | Construct the primitive software type representation of 'a'.+softwarePrimTypeOf :: SoftwarePrimType a => a -> SoftwarePrimTypeRep a+softwarePrimTypeOf _ = softwareRep++-- | Construct a primitive software type witness from its representation.+softwarePrimWitType :: SoftwarePrimTypeRep a -> Dict (SoftwarePrimType a)+softwarePrimWitType BoolST   = Dict+softwarePrimWitType Int8ST   = Dict+softwarePrimWitType Int16ST  = Dict+softwarePrimWitType Int32ST  = Dict+softwarePrimWitType Int64ST  = Dict+softwarePrimWitType Word8ST  = Dict+softwarePrimWitType Word16ST = Dict+softwarePrimWitType Word32ST = Dict+softwarePrimWitType Word64ST = Dict+softwarePrimWitType FloatST  = Dict+softwarePrimWitType DoubleST = Dict+softwarePrimWitType ComplexFloatST  = Dict+softwarePrimWitType ComplexDoubleST = Dict++--------------------------------------------------------------------------------+-- ** Software primitive expressions.++-- | Software primitive symbols.+data SoftwarePrim sig+  where+    -- free variables and literals.+    FreeVar :: (SoftwarePrimType a) => String -> SoftwarePrim (Full a)+    Lit     :: (Show a, Eq a)       => a      -> SoftwarePrim (Full a)+    -- numerical operations.+    Neg  :: (SoftwarePrimType a, Num a) => SoftwarePrim (a :-> Full a)+    Abs  :: (SoftwarePrimType a, Num a) => SoftwarePrim (a :-> Full a)+    Sign :: (SoftwarePrimType a, Num a) => SoftwarePrim (a :-> Full a)+    Add  :: (SoftwarePrimType a, Num a) => SoftwarePrim (a :-> a :-> Full a)+    Sub  :: (SoftwarePrimType a, Num a) => SoftwarePrim (a :-> a :-> Full a)+    Mul  :: (SoftwarePrimType a, Num a) => SoftwarePrim (a :-> a :-> Full a)+    -- integral operations.+    Div  :: (SoftwarePrimType a, Integral a) => SoftwarePrim (a :-> a :-> Full a)+    Mod  :: (SoftwarePrimType a, Integral a) => SoftwarePrim (a :-> a :-> Full a)+    Quot :: (SoftwarePrimType a, Integral a) => SoftwarePrim (a :-> a :-> Full a)+    Rem  :: (SoftwarePrimType a, Integral a) => SoftwarePrim (a :-> a :-> Full a)+    --+    FDiv :: (SoftwarePrimType a, Fractional a) => SoftwarePrim (a :-> a :-> Full a)+    -- floating point operators.+    Pi    :: (SoftwarePrimType a, Floating a) => SoftwarePrim (Full a)+    Exp   :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Log   :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Sqrt  :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Pow   :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> a :-> Full a)+    Sin   :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Cos   :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Tan   :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Asin  :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Acos  :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Atan  :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Sinh  :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Cosh  :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Tanh  :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Asinh :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Acosh :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    Atanh :: (SoftwarePrimType a, Floating a) => SoftwarePrim (a :-> Full a)+    -- complex operators.+    Complex   :: (SoftwarePrimType a, SoftwarePrimType (Complex a), Num a) =>+      SoftwarePrim (a :-> a :-> Full (Complex a))+    Real      :: (SoftwarePrimType a, SoftwarePrimType (Complex a)) =>+      SoftwarePrim (Complex a :-> Full a)+    Imag      :: (SoftwarePrimType a, SoftwarePrimType (Complex a)) =>+      SoftwarePrim (Complex a :-> Full a)+    Polar     :: (SoftwarePrimType a, SoftwarePrimType (Complex a), Floating a) =>+      SoftwarePrim (a :-> a :-> Full (Complex a))+    Magnitude :: (SoftwarePrimType a, SoftwarePrimType (Complex a), RealFloat a) =>+      SoftwarePrim (Complex a :-> Full a)+    Phase     :: (SoftwarePrimType a, SoftwarePrimType (Complex a), RealFloat a) =>+      SoftwarePrim (Complex a :-> Full a)+    Conjugate :: (SoftwarePrimType a, SoftwarePrimType (Complex a), Num a) =>+      SoftwarePrim (Complex a :-> Full (Complex a))+    -- type casting.+    I2N   :: (SoftwarePrimType a, Integral a, SoftwarePrimType b, Num b) =>+      SoftwarePrim (a :-> Full b)+    I2B   :: (SoftwarePrimType a, Integral a) =>+      SoftwarePrim (a :-> Full Bool)+    B2I   :: (SoftwarePrimType a, Integral a) =>+      SoftwarePrim (Bool :-> Full a)+    Round :: (SoftwarePrimType a, RealFrac a, SoftwarePrimType b, Num b) =>+      SoftwarePrim (a :-> Full b)+    -- logical operations.+    Not     :: SoftwarePrim (Bool :-> Full Bool)+    And     :: SoftwarePrim (Bool :-> Bool :-> Full Bool)+    Or      :: SoftwarePrim (Bool :-> Bool :-> Full Bool)+    -- bitwise logical operations.+    BitAnd   :: (SoftwarePrimType a, Bits a) => SoftwarePrim (a :-> a :-> Full a)+    BitOr    :: (SoftwarePrimType a, Bits a) => SoftwarePrim (a :-> a :-> Full a)+    BitXor   :: (SoftwarePrimType a, Bits a) => SoftwarePrim (a :-> a :-> Full a)+    BitCompl :: (SoftwarePrimType a, Bits a) => SoftwarePrim (a :-> Full a)+    ShiftL   :: (SoftwarePrimType a, Bits a, SoftwarePrimType b, Integral b) =>+      SoftwarePrim (a :-> b :-> Full a)+    ShiftR   :: (SoftwarePrimType a, Bits a, SoftwarePrimType b, Integral b) =>+      SoftwarePrim (a :-> b :-> Full a)+    RotateL  :: (SoftwarePrimType a, Bits a, SoftwarePrimType b, Integral b) =>+      SoftwarePrim (a :-> b :-> Full a)+    RotateR  :: (SoftwarePrimType a, Bits a, SoftwarePrimType b, Integral b) =>+      SoftwarePrim (a :-> b :-> Full a)+    -- relational operations.+    Eq  :: (SoftwarePrimType a, Eq a)  => SoftwarePrim (a :-> a :-> Full Bool)+    Neq :: (SoftwarePrimType a, Eq a)  => SoftwarePrim (a :-> a :-> Full Bool)+    Lt  :: (SoftwarePrimType a, Ord a) => SoftwarePrim (a :-> a :-> Full Bool)+    Lte :: (SoftwarePrimType a, Ord a) => SoftwarePrim (a :-> a :-> Full Bool)+    Gt  :: (SoftwarePrimType a, Ord a) => SoftwarePrim (a :-> a :-> Full Bool)+    Gte :: (SoftwarePrimType a, Ord a) => SoftwarePrim (a :-> a :-> Full Bool)+    -- conditional.+    Cond :: SoftwarePrim (Bool :-> a :-> a :-> Full a)+    -- array indexing.+    ArrIx :: (SoftwarePrimType a) => Imp.IArr Index a ->+      SoftwarePrim (Index :-> Full a)++deriving instance Show     (SoftwarePrim a)+deriving instance Typeable (SoftwarePrim a)++--------------------------------------------------------------------------------++-- | Software primitive symbols.+type SoftwarePrimConstructs = SoftwarePrim++-- | Software primitive symbols tagged with their type representation.+type SoftwarePrimDomain = SoftwarePrimConstructs :&: SoftwarePrimTypeRep++-- | Software primitive expressions.+newtype Prim a = Prim { unPrim :: ASTF SoftwarePrimDomain a }++-- | Evaluate a closed, software primitive expression.+evalPrim :: Prim a -> a+evalPrim = go . unPrim+  where+    go :: AST SoftwarePrimDomain sig -> Denotation sig+    go (Sym (s :&: _)) = evalSym s+    go (f :$ a)        = go f $ go a++-- | Sugar a software primitive symbol as a smart constructor.+sugarSymPrim+  :: ( Signature sig+     , fi  ~ SmartFun dom sig+     , sig ~ SmartSig fi+     , dom ~ SmartSym fi+     , dom ~ SoftwarePrimDomain+     , SyntacticN f fi+     , sub :<: SoftwarePrimConstructs+     , SoftwarePrimType (DenResult sig)+     )+  => sub sig -> f+sugarSymPrim = sugarSymDecor softwareRep++--------------------------------------------------------------------------------++instance Syntactic (Prim a)+  where+    type Domain   (Prim a) = SoftwarePrimDomain+    type Internal (Prim a) = a+    desugar = unPrim+    sugar   = Prim++instance FreeExp Prim+  where+    type FreePred Prim = SoftwarePrimType+    constExp = sugarSymPrim . Lit+    varExp   = sugarSymPrim . FreeVar++instance EvalExp Prim+  where+    evalExp = evalPrim++--------------------------------------------------------------------------------+-- front-end.++instance (SoftwarePrimType a, Num a) => Num (Prim a)+  where+    fromInteger = constExp . fromInteger+    (+)         = sugarSymPrim Add+    (-)         = sugarSymPrim Sub+    (*)         = sugarSymPrim Mul+    negate      = sugarSymPrim Neg+    abs         = error "Num (Prim a): abs."+    signum      = error "Num (Prim a): signum."++--------------------------------------------------------------------------------+-- syntactic instances.++instance Eval SoftwarePrim+  where+    evalSym (FreeVar v) = error $ "evaluating free variable " ++ show v+    evalSym (Lit a)     = a+    evalSym Cond        = \c t f -> if c then t else f+    evalSym Neg         = negate+    evalSym Abs         = abs+    evalSym Sign        = signum+    evalSym Add         = (+)+    evalSym Sub         = (-)+    evalSym Mul         = (*)+    evalSym Div         = div+    evalSym Mod         = mod+    evalSym Quot        = quot+    evalSym Rem         = rem+    evalSym FDiv        = (/)+    evalSym Pi          = pi+    evalSym Exp         = exp+    evalSym Log         = log+    evalSym Sqrt        = sqrt+    evalSym Pow         = (**)+    evalSym Sin         = sin+    evalSym Cos         = cos+    evalSym Tan         = tan+    evalSym Asin        = asin+    evalSym Acos        = acos+    evalSym Atan        = atan+    evalSym Sinh        = sinh+    evalSym Cosh        = cosh+    evalSym Tanh        = tanh+    evalSym Asinh       = asinh+    evalSym Acosh       = acosh+    evalSym Atanh       = atanh+    evalSym Complex     = (:+)+    evalSym Polar       = mkPolar+    evalSym Real        = realPart+    evalSym Imag        = imagPart+    evalSym Magnitude   = magnitude+    evalSym Phase       = phase+    evalSym Conjugate   = conjugate+    evalSym I2N         = fromIntegral+    evalSym I2B         = (/=0)+    evalSym B2I         = \a -> if a then 1 else 0+    evalSym Round       = fromInteger . round+    evalSym Not         = not+    evalSym And         = (&&)+    evalSym Or          = (||)+    evalSym BitAnd      = (Bits..&.)+    evalSym BitOr       = (Bits..|.)+    evalSym BitXor      = Bits.xor+    evalSym BitCompl    = Bits.complement+    evalSym ShiftL      = \b i -> Bits.shiftL  b (fromIntegral i)+    evalSym ShiftR      = \b i -> Bits.shiftR  b (fromIntegral i)+    evalSym RotateL     = \b i -> Bits.rotateL b (fromIntegral i)+    evalSym RotateR     = \b i -> Bits.rotateR b (fromIntegral i)+    evalSym Eq          = (==)+    evalSym Neq         = (/=)+    evalSym Lt          = (<)+    evalSym Lte         = (<=)+    evalSym Gt          = (>)+    evalSym Gte         = (>=)+    evalSym (ArrIx (Imp.IArrRun arr)) = \i -> arr ! i+    evalSym (ArrIx _)   = error "eval of variable."++instance Symbol SoftwarePrim+  where+    symSig (FreeVar v) = signature+    symSig (Lit a)     = signature+    symSig Cond        = signature+    symSig Neg         = signature+    symSig Abs         = signature+    symSig Sign        = signature+    symSig Add         = signature+    symSig Sub         = signature+    symSig Mul         = signature+    symSig Div         = signature+    symSig Mod         = signature+    symSig Quot        = signature+    symSig Rem         = signature+    symSig FDiv        = signature+    symSig Pi          = signature+    symSig Exp         = signature+    symSig Log         = signature+    symSig Sqrt        = signature+    symSig Pow         = signature+    symSig Sin         = signature+    symSig Cos         = signature+    symSig Tan         = signature+    symSig Asin        = signature+    symSig Acos        = signature+    symSig Atan        = signature+    symSig Sinh        = signature+    symSig Cosh        = signature+    symSig Tanh        = signature+    symSig Asinh       = signature+    symSig Acosh       = signature+    symSig Atanh       = signature+    symSig Complex     = signature+    symSig Real        = signature+    symSig Imag        = signature+    symSig Polar       = signature+    symSig Magnitude   = signature+    symSig Phase       = signature+    symSig Conjugate   = signature+    symSig I2N         = signature+    symSig I2B         = signature+    symSig B2I         = signature+    symSig Round       = signature+    symSig Not         = signature+    symSig And         = signature+    symSig Or          = signature+    symSig BitAnd      = signature+    symSig BitOr       = signature+    symSig BitXor      = signature+    symSig BitCompl    = signature+    symSig ShiftL      = signature+    symSig ShiftR      = signature+    symSig RotateL     = signature+    symSig RotateR     = signature+    symSig Eq          = signature+    symSig Neq         = signature+    symSig Lt          = signature+    symSig Lte         = signature+    symSig Gt          = signature+    symSig Gte         = signature+    symSig (ArrIx a)   = signature++instance Render SoftwarePrim+  where+    renderSym  = show+    renderArgs = renderArgsSmart++instance Equality SoftwarePrim+  where+    equal s1 s2 = show s1 == show s2++instance StringTree SoftwarePrim+instance EvalEnv SoftwarePrim env++--------------------------------------------------------------------------------
+ src/Feldspar/Software/Primitive/Backend.hs view
@@ -0,0 +1,439 @@+{-# language GADTs #-}+{-# language QuasiQuotes #-}+{-# language ScopedTypeVariables #-}+{-# language FlexibleContexts #-}++module Feldspar.Software.Primitive.Backend where++import Feldspar.Software.Primitive++import Data.Complex (Complex (..))+import Data.Constraint (Dict (..))+import Data.Proxy++-- syntactic.+import Language.Syntactic++-- language-c-quote.+import Language.C.Quote.C+import qualified Language.C.Syntax as C++--imperative-edsl.+import Language.C.Monad+import Language.Embedded.Backend.C++--------------------------------------------------------------------------------+-- * Compilation of software primitives.+--------------------------------------------------------------------------------++viewLitPrim :: ASTF SoftwarePrimDomain a -> Maybe a+viewLitPrim (Sym (Lit a :&: _)) = Just a+viewLitPrim _                   = Nothing++--------------------------------------------------------------------------------++instance CompTypeClass SoftwarePrimType+  where+    compType _ (_ :: proxy a) = case softwareRep :: SoftwarePrimTypeRep a of+      BoolST   -> addInclude "<stdbool.h>" >> return [cty| typename bool |]+      Int8ST   -> addInclude "<stdint.h>"  >> return [cty| typename int8_t |]+      Int16ST  -> addInclude "<stdint.h>"  >> return [cty| typename int16_t |]+      Int32ST  -> addInclude "<stdint.h>"  >> return [cty| typename int32_t |]+      Int64ST  -> addInclude "<stdint.h>"  >> return [cty| typename int64_t |]+      Word8ST  -> addInclude "<stdint.h>"  >> return [cty| typename uint8_t |]+      Word16ST -> addInclude "<stdint.h>"  >> return [cty| typename uint16_t |]+      Word32ST -> addInclude "<stdint.h>"  >> return [cty| typename uint32_t |]+      Word64ST -> addInclude "<stdint.h>"  >> return [cty| typename uint64_t |]+      FloatST  -> return [cty| float |]+      DoubleST -> return [cty| double |]+      ComplexFloatST  ->+        addInclude "<tgmath.h>" >> return [cty| float  _Complex |]+      ComplexDoubleST ->+        addInclude "<tgmath.h>" >> return [cty| double _Complex |]++    compLit _ a = case softwarePrimTypeOf a of+      BoolST  ->+        do addInclude "<stdbool.h>"+           return $ if a then [cexp| true |] else [cexp| false |]+      Int8ST   -> return [cexp| $a |]+      Int16ST  -> return [cexp| $a |]+      Int32ST  -> return [cexp| $a |]+      Int64ST  -> return [cexp| $a |]+      Word8ST  -> return [cexp| $a |]+      Word16ST -> return [cexp| $a |]+      Word32ST -> return [cexp| $a |]+      Word64ST -> return [cexp| $a |]+      FloatST  -> return [cexp| $a |]+      DoubleST -> return [cexp| $a |]+      ComplexFloatST  -> return $ compComplexLit a+      ComplexDoubleST -> return $ compComplexLit a++instance CompExp Prim+  where+    compExp = compPrim++--------------------------------------------------------------------------------++compUnOp+  :: MonadC m+  => C.UnOp+  -> ASTF SoftwarePrimDomain a+  -> m C.Exp+compUnOp op a = do+  a' <- compPrim $ Prim a+  return $ C.UnOp op a' mempty++compBinOp+  :: MonadC m+  => C.BinOp+  -> ASTF SoftwarePrimDomain a+  -> ASTF SoftwarePrimDomain b+  -> m C.Exp+compBinOp op a b = do+  a' <- compPrim $ Prim a+  b' <- compPrim $ Prim b+  return $ C.BinOp op a' b' mempty  ++compCast+  :: MonadC m+  => SoftwarePrimTypeRep a+  -> ASTF SoftwarePrimDomain b+  -> m C.Exp+compCast t a = do+  p <- compPrim $ Prim a+  compCastExp t p++compCastExp+  :: MonadC m+  => SoftwarePrimTypeRep a+  -> C.Exp+  -> m C.Exp+compCastExp t p = case softwarePrimWitType t of+  Dict -> do+    typ <- compType (Proxy :: Proxy SoftwarePrimType) t+    return [cexp|($ty:typ) $p|]+        +compFun+  :: MonadC m+  => String+  -> Args (AST SoftwarePrimDomain) sig+  -> m C.Exp+compFun fun args = do+  as <- sequence $ listArgs (compPrim . Prim) args+  return [cexp| $id:fun($args:as) |]++compRotateL_def = [cedecl|+unsigned int feld_rotl(const unsigned int value, int shift) {+    if ((shift &= sizeof(value)*8 - 1) == 0)+      return value;+    return (value << shift) | (value >> (sizeof(value)*8 - shift));+} |]++compRotateR_def = [cedecl|+unsigned int feld_rotr(const unsigned int value, int shift) {+    if ((shift &= sizeof(value)*8 - 1) == 0)+      return value;+    return (value >> shift) | (value << (sizeof(value)*8 - shift));+} |]++compComplexLit :: (Eq a, Num a, ToExp a) => Complex a -> C.Exp+compComplexLit (r :+ 0) = [cexp| $r |]+compComplexLit (0 :+ i) = [cexp| $i * I |]+compComplexLit (r :+ i) = [cexp| $r + $i * I |]+  +compAbs+  :: MonadC m+  => SoftwarePrimTypeRep a+  -> ASTF SoftwarePrimDomain a+  -> m C.Exp+compAbs t a + | boolType t    = error "compAbs: type BoolT not supported"+ | integerType t = addInclude "<stdlib.h>" >> compFun "abs" (a :* Nil)+ | wordType t    = compPrim $ Prim a+ | otherwise     = addInclude "<tgmath.h>" >> compFun "fabs" (a :* Nil)++compSign+  :: MonadC m+  => SoftwarePrimTypeRep a+  -> ASTF SoftwarePrimDomain a+  -> m C.Exp+compSign t a | boolType t = do+  error "compSign: type BoolST not supported"+compSign t a | integerType t = do+  addTagMacro+  a' <- compPrim $ Prim a+  return [cexp| TAG("signum", ($a' > 0) - ($a' < 0)) |]+compSign t a | wordType t = do+  addTagMacro+  a' <- compPrim $ Prim a+  return [cexp| TAG("signum", $a' > 0) |]+compSign FloatST a = do+  addTagMacro+  a' <- compPrim $ Prim a+  return [cexp| TAG("signum", (float) (($a' > 0) - ($a' < 0))) |]+compSign DoubleST a = do+  addTagMacro+  a' <- compPrim $ Prim a+  return [cexp| TAG("signum", (double) (($a' > 0) - ($a' < 0))) |]+compSign ComplexFloatST a = do+  addInclude "<complex.h>"+  addGlobal complexSignf_def+  a' <- compPrim $ Prim a+  return [cexp| feld_complexSignf($a') |]+compSign ComplexDoubleST a = do+  addInclude "<tgmath.h>"+  addGlobal complexSign_def+  a' <- compPrim $ Prim a+  return [cexp| feld_complexSign($a') |]+  -- todo: The floating point cases give `sign (-0.0) = 0.0`, which is (slightly)+  -- wrong. They should return -0.0. I don't know whether it's correct for other+  -- strange values.++complexSignf_def = [cedecl|+float _Complex feld_complexSignf(float _Complex c) {+    float z = cabsf(c);+    if (z == 0)+      return 0;+    else+      return (crealf(c)/z + I*(cimagf(c)/z));+} |]+    +complexSign_def = [cedecl|+double _Complex feld_complexSign(double _Complex c) {+    double z = cabs(c);+    if (z == 0)+      return 0;+    else+      return (creal(c)/z + I*(cimag(c)/z));+} |]++compDiv+  :: MonadC m+  => SoftwarePrimTypeRep a+  -> ASTF SoftwarePrimDomain a+  -> ASTF SoftwarePrimDomain b+  -> m C.Exp+compDiv Int64ST a b = do+  addGlobal ldiv_def+  compFun "feld_ldiv" (a :* b :* Nil)+compDiv t a b | integerType t = do+  addGlobal div_def+  compFun "feld_div" (a :* b :* Nil)+compDiv t a b | wordType t = compBinOp C.Div a b+compDiv t a b = error $ "compDiv: type " ++ show t ++ " not supported"++ldiv_def = [cedecl|+long int feld_ldiv(long int x, long int y) {+    int q = x/y;+    int r = x%y;+    if ((r!=0) && ((r<0) != (y<0))) --q;+    return q;+} |]++div_def = [cedecl|+int feld_div(int x, int y) {+    int q = x/y;+    int r = x%y;+    if ((r!=0) && ((r<0) != (y<0))) --q;+    return q;+} |]++compMod+  :: MonadC m+  => SoftwarePrimTypeRep a+  -> ASTF SoftwarePrimDomain a+  -> ASTF SoftwarePrimDomain b+  -> m C.Exp+compMod Int64ST a b = do+  addGlobal lmod_def+  compFun "feld_lmod" (a :* b :* Nil)+compMod t a b | integerType t = do+  addGlobal div_def+  compFun "feld_mod" (a :* b :* Nil)+compMod t a b | wordType t = compBinOp C.Mod a b+compMod t a b = error $ "compMod: type " ++ show t ++ " not supported"++lmod_def = [cedecl|+long int feld_lmod(long int x, long int y) {+    int r = x%y;+    if ((r!=0) && ((r<0) != (y<0))) { r += y; }+    return r;+} |]++mod_def = [cedecl|+int feld_mod(int x, int y) {+    int r = x%y;+    if ((r!=0) && ((r<0) != (y<0))) { r += y; }+    return r;+} |]++compRound :: (SoftwarePrimType a, Num a, RealFrac b, MonadC m)+  => SoftwarePrimTypeRep a+  -> ASTF SoftwarePrimDomain b+  -> m C.Exp+compRound t a | integerType t || wordType t = do+  addInclude "<tgmath.h>"+  p <- compFun "lround" (a :* Nil)+  compCastExp t p+compRound t a | floatingType t || complexType t = do+  addInclude "<tgmath.h>"+  p <- compFun "round"  (a :* Nil)+  compCastExp t p+compRound t a = do+  error $ "compSign: type " ++ show t ++ " not supported"+  +--------------------------------------------------------------------------------++compPrim :: MonadC m => Prim a -> m C.Exp+compPrim = simpleMatch (\(s :&: t) -> go t s) . unPrim+  where+    go :: forall m sig+       .  MonadC m+       => SoftwarePrimTypeRep (DenResult sig)+       -> SoftwarePrimConstructs sig+       -> Args (AST SoftwarePrimDomain) sig+       -> m C.Exp+    go _ (FreeVar v) Nil = touchVar v >> return [cexp| $id:v |]+    go t (Lit a)     Nil | Dict <- softwarePrimWitType t+                         = compLit (Proxy :: Proxy SoftwarePrimType) a+                         +    go _ Neg  (a :* Nil)      = compUnOp  C.Negate a+    go _ Add  (a :* b :* Nil) = compBinOp C.Add a b+    go _ Sub  (a :* b :* Nil) = compBinOp C.Sub a b+    go _ Mul  (a :* b :* Nil) = compBinOp C.Mul a b+    go t Div  (a :* b :* Nil) = compDiv t a b+    go _ Quot (a :* b :* Nil) = compBinOp C.Div a b+    go _ Rem  (a :* b :* Nil) = compBinOp C.Mod a b+    go t Mod  (a :* b :* Nil) = compMod t a b+    go t Abs  (a :* Nil)      = compAbs t a+    go t Sign (a :* Nil)      = compSign t a+    go _ FDiv (a :* b :* Nil) = compBinOp C.Div a b++    go _ Exp   args = addInclude "<tgmath.h>" >> compFun "exp" args+    go _ Log   args = addInclude "<tgmath.h>" >> compFun "log" args+    go _ Sqrt  args = addInclude "<tgmath.h>" >> compFun "sqrt" args+    go _ Pow   args = addInclude "<tgmath.h>" >> compFun "pow" args++    go _ Sin   args = addInclude "<tgmath.h>" >> compFun "sin" args+    go _ Cos   args = addInclude "<tgmath.h>" >> compFun "cos" args+    go _ Tan   args = addInclude "<tgmath.h>" >> compFun "tan" args+    go _ Asin  args = addInclude "<tgmath.h>" >> compFun "asin" args+    go _ Acos  args = addInclude "<tgmath.h>" >> compFun "acos" args+    go _ Atan  args = addInclude "<tgmath.h>" >> compFun "atan" args+    go _ Sinh  args = addInclude "<tgmath.h>" >> compFun "sinh" args+    go _ Cosh  args = addInclude "<tgmath.h>" >> compFun "cosh" args+    go _ Tanh  args = addInclude "<tgmath.h>" >> compFun "tanh" args+    go _ Asinh args = addInclude "<tgmath.h>" >> compFun "asinh" args+    go _ Acosh args = addInclude "<tgmath.h>" >> compFun "acosh" args+    go _ Atanh args = addInclude "<tgmath.h>" >> compFun "atanh" args++    go t I2N   (a :* Nil) = compCast t a+    go t I2B   (a :* Nil) = compCast t a+    go t B2I   (a :* Nil) = compCast t a+    go t Round (a :* Nil) = compRound t a++    go _ Complex (a :* b :* Nil) = do+        addInclude "<tgmath.h>"+        a' <- compPrim $ Prim a+        b' <- compPrim $ Prim b+        return $ case (viewLitPrim a, viewLitPrim b) of+          (Just 0, _) -> [cexp| I*$b'       |]+          (_, Just 0) -> [cexp| $a'         |]+          _           -> [cexp| $a' + I*$b' |]++    go _ Polar (m :* p :* Nil)+        | Just 0 <- viewLitPrim m = do+            return [cexp| 0 |]+        | Just 0 <- viewLitPrim p = do+            m' <- compPrim $ Prim m+            return [cexp| $m' |]+        | Just 1 <- viewLitPrim m = do+            p' <- compPrim $ Prim p+            return [cexp| exp(I*$p') |]+        | otherwise = do+            m' <- compPrim $ Prim m+            p' <- compPrim $ Prim p+            return [cexp| $m' * exp(I*$p') |]++    go _ Real      args = addInclude "<tgmath.h>" >> compFun "creal" args+    go _ Imag      args = addInclude "<tgmath.h>" >> compFun "cimag" args+    go _ Magnitude args = addInclude "<tgmath.h>" >> compFun "cabs"  args+    go _ Phase     args = addInclude "<tgmath.h>" >> compFun "carg"  args+    go _ Conjugate args = addInclude "<tgmath.h>" >> compFun "conj"  args+    +    go _ Not (a :* Nil)      = compUnOp  C.Lnot a+    go _ And (a :* b :* Nil) = compBinOp C.Land a b+    go _ Or  (a :* b :* Nil) = compBinOp C.Lor  a b+    go _ Eq  (a :* b :* Nil) = compBinOp C.Eq   a b+    go _ Neq (a :* b :* Nil) = compBinOp C.Ne   a b+    go _ Lt  (a :* b :* Nil) = compBinOp C.Lt   a b+    go _ Lte (a :* b :* Nil) = compBinOp C.Le   a b+    go _ Gt  (a :* b :* Nil) = compBinOp C.Gt   a b+    go _ Gte (a :* b :* Nil) = compBinOp C.Ge   a b++    go _ Pi Nil = addGlobal pi_def >> return [cexp| FELD_PI |]+      where pi_def = [cedecl|$esc:("#define FELD_PI 3.141592653589793")|]++    go _ BitAnd   (a :* b :* Nil) = compBinOp C.And a b+    go _ BitOr    (a :* b :* Nil) = compBinOp C.Or  a b+    go _ BitXor   (a :* b :* Nil) = compBinOp C.Xor a b+    go _ BitCompl (a :* Nil)      = compUnOp  C.Not a+    go _ ShiftL   (a :* b :* Nil) = compBinOp C.Lsh a b+    go _ ShiftR   (a :* b :* Nil) = compBinOp C.Rsh a b+    +    go _ RotateL  (a :* b :* Nil) = do+      addGlobal compRotateL_def+      a' <- compPrim $ Prim a+      b' <- compPrim $ Prim b+      return [cexp| feld_rotl($a', $b') |]+    go _ RotateR  (a :* b :* Nil) = do+      addGlobal compRotateR_def+      a' <- compPrim $ Prim a+      b' <- compPrim $ Prim b+      return [cexp| feld_rotr($a', $b') |]+    +    go _ (ArrIx arr) (i :* Nil) = do+      i' <- compPrim $ Prim i+      touchVar arr+      return [cexp| $id:arr[$i'] |]++    go _ Cond (c :* t :* f :* Nil) = do+      c' <- compPrim $ Prim c+      t' <- compPrim $ Prim t+      f' <- compPrim $ Prim f+      return $ C.Cond c' t' f' mempty++--------------------------------------------------------------------------------++addTagMacro :: MonadC m => m ()+addTagMacro = addGlobal [cedecl| $esc:("#define TAG(tag,exp) (exp)") |]+  +boolType :: SoftwarePrimTypeRep a -> Bool+boolType BoolST     = True+boolType _          = False++integerType :: SoftwarePrimTypeRep a -> Bool+integerType Int8ST  = True+integerType Int16ST = True+integerType Int32ST = True+integerType Int64ST = True+integerType _       = False++wordType :: SoftwarePrimTypeRep a -> Bool+wordType Word8ST    = True+wordType Word16ST   = True+wordType Word32ST   = True+wordType Word64ST   = True+wordType _          = False++floatingType :: SoftwarePrimTypeRep a -> Bool+floatingType FloatST  = True+floatingType DoubleST = True+floatingType _        = False++complexType :: SoftwarePrimTypeRep a -> Bool+complexType ComplexFloatST  = True+complexType ComplexDoubleST = True+complexType _               = False++--------------------------------------------------------------------------------
+ src/Feldspar/Software/Representation.hs view
@@ -0,0 +1,271 @@+{-# language GADTs                      #-}+{-# language ConstraintKinds            #-}+{-# language TypeOperators              #-}+{-# language TypeFamilies               #-}+{-# language MultiParamTypeClasses      #-}+{-# language FlexibleContexts           #-}+{-# language FlexibleInstances          #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language PolyKinds                  #-}+{-# language DataKinds #-}++module Feldspar.Software.Representation where++import Feldspar.Sugar+import Feldspar.Representation+import Feldspar.Frontend+import Feldspar.Storable+import Feldspar.Array.Buffered (ArraysEq(..))+import Feldspar.Software.Primitive+import Feldspar.Software.Expression hiding (Hint)++import Feldspar.Verify.Monad (Verify)+import qualified Feldspar.Verify.FirstOrder as FO+import qualified Feldspar.Verify.Monad as V+import qualified Feldspar.Verify.SMT as SMT+import qualified Feldspar.Verify.Abstract as A++import Data.Array (Ix)+import Data.Constraint hiding ((\\))+import Data.Function (on)+import Data.Functor.Identity+import Data.Maybe (fromMaybe)+import Data.Ord+import Data.IORef+import Data.Int+import Data.Word+import Data.List (genericTake, (\\), sort, sortBy, group, groupBy, intersect, nub)+import Data.Typeable (Typeable, cast, typeOf)+import Data.Struct+import qualified Data.Map.Strict as Map++import Control.Monad.Reader (ReaderT(..), runReaderT, lift)++-- syntactic.+import Language.Syntactic hiding (Signature, Args)+import Language.Syntactic.Functional hiding (Lam)+import Language.Syntactic.Functional.Tuple+import qualified Language.Syntactic as Syn++-- operational-higher.+import Control.Monad.Operational.Higher as Oper++-- imperative-edsl.+import qualified Language.Embedded.Expression as Imp+import qualified Language.Embedded.Imperative as Imp+import qualified Language.Embedded.Imperative.CMD as Imp++-- hardware-edsl.+import Language.Embedded.Hardware.Command (Signal, Mode)+import qualified Language.Embedded.Hardware.Command as Hard+import qualified Language.Embedded.Hardware.Expression.Represent as Hard++import Prelude hiding ((==))+import qualified Prelude as P++-- hmm!+import Feldspar.Hardware.Frontend (HSig)++--------------------------------------------------------------------------------+-- * Programs.+--------------------------------------------------------------------------------++data AssertCMD fs a+  where+    Assert :: AssertionLabel+           -> exp Bool+           -> String+           -> AssertCMD (Oper.Param3 prog exp pred) ()++instance Oper.HFunctor AssertCMD+  where+    hfmap _ (Assert lbl cond msg) = Assert lbl cond msg++instance Oper.HBifunctor AssertCMD+  where+    hbimap _ g (Assert lbl cond msg) = Assert lbl (g cond) msg++instance Oper.InterpBi AssertCMD IO (Oper.Param1 SoftwarePrimType)+  where+    interpBi (Assert _ cond msg) = do+      cond' <- cond+      unless cond' $ error $ "Assertion failed: " ++ msg++instance (Imp.ControlCMD Oper.:<: instr) => Oper.Reexpressible AssertCMD instr env+  where+    reexpressInstrEnv reexp (Assert lbl cond msg) = do+      cond' <- reexp cond+      lift $ Imp.assert cond' msg++instance FO.HTraversable AssertCMD++instance FO.Symbol AssertCMD+  where+    dry (Assert {}) = return ()++--------------------------------------------------------------------------------++data ControlCMD inv fs a+  where+    If :: exp Bool -> prog () -> prog () ->+      ControlCMD inv (Oper.Param3 prog exp pred) ()+    While :: Maybe inv -> prog (exp Bool) -> prog () ->+      ControlCMD inv (Oper.Param3 prog exp pred) ()+    For :: (pred i, Integral i) =>+      Maybe inv -> Imp.IxRange (exp i) -> Imp.Val i -> prog () ->+      ControlCMD inv (Oper.Param3 prog exp pred) ()+    Break :: ControlCMD inv (Oper.Param3 prog exp pred) ()+    --+    Test :: Maybe (exp Bool) -> String ->+      ControlCMD inv (Oper.Param3 prog exp pred) ()+    Hint :: pred a => exp a ->+      ControlCMD inv (Oper.Param3 prog exp pred) ()+    Comment :: String ->+      ControlCMD inv (Oper.Param3 prog exp pred) ()++instance Oper.HFunctor (ControlCMD inv)+  where+    hfmap f ins = runIdentity (FO.htraverse (pure . f) ins)++instance FO.HTraversable (ControlCMD inv)+  where+    htraverse f (If cond tru fls) = (If cond) <$> f tru <*> f fls+    htraverse f (While inv cond body) = (While inv) <$> f cond <*> f body+    htraverse f (For inv range val body) = (For inv range val) <$> f body+    htraverse _ (Break) = pure Break+    htraverse _ (Test cond msg) = pure (Test cond msg)+    htraverse _ (Hint val) = pure (Hint val)+    htraverse _ (Comment msg) = pure (Comment msg)++--------------------------------------------------------------------------------++-- | Soften the hardware signature of a component into a type that uses the+--   correspoinding data types in software.+type family Soften a where+  Soften ()                   = ()+  Soften (Hard.Signal a -> b) = Ref (SExp a) -> Soften b+  Soften (Hard.Array  a -> b) = Arr (SExp a) -> Soften b++-- | Software argument for a hardware component.+data Argument pred a+  where+    Nil  :: Argument pred ()+    ARef :: (pred a, Integral a, Hard.PrimType a)+         => Ref (SExp a)+         -> Argument pred b+         -> Argument pred (Ref (SExp a) -> b)+    AArr :: (pred a, Integral a, Hard.PrimType a)+         => Arr (SExp a)+         -> Argument pred b+         -> Argument pred (Arr (SExp a) -> b)++-- | Software component, consists of a hardware signature and its address.+data Address a = Address String (HSig a)++-- | ...+data MMapCMD fs a+  where+    MMap :: String+         -> HSig a+         -> MMapCMD (Param3 prog exp pred) String+    Call :: Address a+         -> Argument pred (Soften a)+         -> MMapCMD (Param3 prog exp pred) ()++instance Oper.HFunctor MMapCMD+  where+    hfmap f (MMap s sig)    = MMap s sig+    hfmap f (Call addr arg) = Call addr arg++instance Oper.HBifunctor MMapCMD+  where+    hbimap g f (MMap s sig)    = MMap s sig+    hbimap g f (Call addr arg) = Call addr arg++instance (MMapCMD Oper.:<: instr) => Oper.Reexpressible MMapCMD instr env+  where+    reexpressInstrEnv reexp (MMap s sig)    = lift $ singleInj $ MMap s sig+    reexpressInstrEnv reexp (Call addr arg) = lift $ singleInj $ Call addr arg++instance Oper.InterpBi MMapCMD IO (Param1 SoftwarePrimType)+  where+    interpBi = error "todo: interpBi of mmap."++instance FO.HTraversable MMapCMD++instance FO.Symbol MMapCMD+  where+    dry (MMap s sig)    = show <$> FO.fresh+    dry (Call addr sig) = return ()++--------------------------------------------------------------------------------++-- | Software instructions.+type SoftwareCMD+    -- ^ Computational instructions.+         = Imp.RefCMD+  Oper.:+: Imp.ControlCMD+  Oper.:+: Imp.ArrCMD+    -- ^ Software specific instructions.+  Oper.:+: Imp.FileCMD+  Oper.:+: Imp.PtrCMD+  Oper.:+: Imp.C_CMD+    -- new stuff+  Oper.:+: AssertCMD+  Oper.:+: MMapCMD++-- | Monad for building software programs in Feldspar.+newtype Software a = Software { unSoftware :: Program SoftwareCMD (Param2 SExp SoftwarePrimType) a }+  deriving (Functor, Applicative, Monad)++--------------------------------------------------------------------------------++-- | Software reference.+newtype Ref a = Ref { unRef :: Struct SoftwarePrimType Imp.Ref (Internal a) }++-- | Software array.+data Arr a = Arr+  { arrOffset :: SExp Index+  , arrLength :: SExp Length+  , unArr     :: Struct SoftwarePrimType (Imp.Arr Index) (Internal a)+  }++-- | Immutable software array.+data IArr a = IArr+  { iarrOffset :: SExp Index+  , iarrLength :: SExp Length+  , unIArr     :: Struct SoftwarePrimType (Imp.IArr Index) (Internal a)+  }++--------------------------------------------------------------------------------+-- **+--------------------------------------------------------------------------------++instance ArraysEq Arr IArr+  where+    unsafeArrEq (Arr _ _ arr) (IArr _ _ brr) =+      and (zipListStruct sameId arr brr)+      where+        sameId :: Imp.Arr Index a -> Imp.IArr Index a -> Bool+        sameId (Imp.ArrComp a) (Imp.IArrComp b) = a P.== b+        sameId _ _ = False++--------------------------------------------------------------------------------++type instance Expr     Software = SExp+type instance DomainOf Software = SoftwareDomain++--------------------------------------------------------------------------------++instance (Reference Software ~ Ref, Type SoftwarePrimType a) =>+    Storable Software (SExp a)+  where+    type StoreRep Software (SExp a) = Ref (SExp a)+    type StoreSize Software (SExp a) = ()+    newStoreRep _ _      = newRef+    initStoreRep         = initRef+    readStoreRep         = getRef+    unsafeFreezeStoreRep = unsafeFreezeRef+    writeStoreRep        = setRef++--------------------------------------------------------------------------------
+ src/Feldspar/Software/Verify.hs view
@@ -0,0 +1,102 @@+{-# language Rank2Types #-}+{-# language ScopedTypeVariables #-}+{-# language DataKinds #-}+{-# language TypeOperators #-}+{-# language TypeFamilies #-}+{-# language FlexibleInstances #-}+{-# language FlexibleContexts #-}+{-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language GADTs #-}+{-# language ConstraintKinds #-}+{-# language GeneralizedNewtypeDeriving #-}++module Feldspar.Software.Verify where++import Feldspar.Software.Representation (Software(..), SoftwareCMD, AssertCMD, ControlCMD(..), MMapCMD)+import Feldspar.Software.Primitive (Prim, SoftwarePrimType)+import Feldspar.Software.Compile (ProgC, translate)+import Feldspar.Software.Verify.Command+import Feldspar.Software.Verify.Primitive++import Control.Monad.Trans++import qualified Feldspar.Verify.Monad as V+import qualified Feldspar.Verify.FirstOrder as FO++-- imperative-edsl.+import qualified Language.Embedded.Imperative.CMD as Imp+import qualified Language.Embedded.Backend.C as Imp++-- operational-higher.+import Control.Monad.Operational.Higher++--------------------------------------------------------------------------------+-- * Verification of Software programs.+--------------------------------------------------------------------------------++verifySoft :: Software () -> IO ()+verifySoft = verifiedSoft Imp.icompile++verifiedSoft :: (ProgC () -> IO a) -> Software () -> IO a+verifiedSoft comp prog =+  do (prg, ws) <- V.runVerify $ do+       lift declareFeldsparGlobals+       V.verify $ translate $ prog+     comp prg <* unless (null ws) (do+       putStrLn "Warnings:"+       sequence_ [ putStrLn ('\t' : warn) | warn <- ws])++--------------------------------------------------------------------------------++instance V.Verifiable+    (Program+      (    Imp.RefCMD+       :+: Imp.ArrCMD+       :+: Imp.ControlCMD+       :+: Imp.FileCMD+       :+: Imp.PtrCMD+       :+: Imp.C_CMD+       :+: MMapCMD+      )+      (Param2 Prim SoftwarePrimType))+  where+    verifyWithResult prog = do+      let inv = undefined :: [[SomeLiteral]]+      (p, r) <- V.verifyWithResult (FO.defunctionalise inv prog)+      return (FO.refunctionalise inv p, r)++instance V.Verifiable+    (FO.Sequence+      (    Imp.RefCMD+       :+: Imp.ArrCMD+       :+: ControlCMD [[SomeLiteral]]+       :+: Imp.FileCMD+       :+: Imp.PtrCMD+       :+: Imp.C_CMD+       :+: MMapCMD+      )+      (Param2 Prim SoftwarePrimType))+  where+    verifyWithResult (FO.Val a)     = return (FO.Val a, a)+    verifyWithResult (FO.Seq a m k) = do+      ((m', breaks), warns) <- V.swallowWarns $ +        V.getWarns $ V.withBreaks $ V.verifyInstr m a+      (_, (k', res)) <-+        V.ite breaks (return ()) (V.verifyWithResult k)+      let+        comment msg prog = flip (FO.Seq ()) prog (inj+          (Comment msg :: ControlCMD [[SomeLiteral]] (Param3+            (FO.Sequence prog (Param2 Prim SoftwarePrimType))+            (Prim) (SoftwarePrimType)) ()))+      return (foldr comment (FO.Seq a m' k') warns, res)++--------------------------------------------------------------------------------++instance FO.Defunctionalise inv AssertCMD where refunc = error "todo: assert"+instance FO.Defunctionalise inv MMapCMD   where refunc = error "todo: mmap"++instance V.VerifyInstr AssertCMD exp pred where verifyInstr = error "todo: assert"+instance V.VerifyInstr MMapCMD   exp pred where verifyInstr = error "todo: mmap"++--------------------------------------------------------------------------------
+ src/Feldspar/Software/Verify/Command.hs view
@@ -0,0 +1,1267 @@+{-# language Rank2Types #-}+{-# language ScopedTypeVariables #-}+{-# language DataKinds #-}+{-# language TypeOperators #-}+{-# language TypeFamilies #-}+{-# language FlexibleInstances #-}+{-# language FlexibleContexts #-}+{-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language GADTs #-}+{-# language ConstraintKinds #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module Feldspar.Software.Verify.Command where++import Feldspar.Sugar+import Feldspar.Representation+import Feldspar.Frontend+import Feldspar.Software.Primitive+import Feldspar.Software.Expression+import Feldspar.Software.Representation++import Feldspar.Verify.FirstOrder (FO)+import Feldspar.Verify.Monad (Verify)+import qualified Feldspar.Verify.FirstOrder as FO+import qualified Feldspar.Verify.Monad as V+import qualified Feldspar.Verify.SMT as SMT+import qualified Feldspar.Verify.Abstract as A+import qualified Data.Map.Strict as Map++import Data.Array (Ix)+import Data.Constraint hiding ((\\))+import Data.Functor.Identity+import Data.Function (on)+import Data.Maybe (fromMaybe)+import Data.Ord+import Data.IORef+import Data.Int+import Data.Word+import Data.List (genericTake, (\\), sort, sortBy, group, groupBy, intersect, nub)+import Data.Typeable (Typeable, cast, typeOf)+import Data.Struct++import Data.Typeable++import Control.Monad.Reader (ReaderT(..), runReaderT, lift)+import qualified Control.Monad.RWS.Strict as S++-- syntactic.+import Language.Syntactic hiding (Signature, Args, (:+:), (:<:))+import Language.Syntactic.Functional hiding (Lam, Var)+import Language.Syntactic.Functional.Tuple+import qualified Language.Syntactic as Syn++-- operational-higher.+import Control.Monad.Operational.Higher ((:+:), (:<:))+import Control.Monad.Operational.Higher as Oper++-- imperative-edsl.+import qualified Language.Embedded.Expression as Imp+import qualified Language.Embedded.Imperative as Imp+import qualified Language.Embedded.Imperative.CMD as Imp+import qualified Data.Loc as C+import qualified Language.C.Syntax as C+import qualified Language.C.Quote.C as C++-- hardware-edsl.+import Language.Embedded.Hardware.Command (Signal, Mode)+import qualified Language.Embedded.Hardware.Command as Hard+import qualified Language.Embedded.Hardware.Expression.Represent as Hard++import Prelude hiding ((==))+import qualified Prelude as P++import GHC.Stack+import Control.Monad.IO.Class++--------------------------------------------------------------------------------+-- *+--------------------------------------------------------------------------------++class Verifiable prog+  where+    verifyWithResult :: prog a -> V.Verify (prog a, a)++verify :: Verifiable prog => prog a -> V.Verify (prog a)+verify = fmap fst . verifyWithResult++class VerifyInstr instr exp pred+  where+    verifyInstr :: Verifiable prog =>+      instr '(prog, Param2 exp pred) a -> a ->+      V.Verify (instr '(prog, Param2 exp pred) a)+    verifyInstr instr _ = return instr++instance (VerifyInstr f exp pred, VerifyInstr g exp pred) =>+    VerifyInstr (f :+: g) exp pred+  where+    verifyInstr (Inl m) x = fmap Inl (verifyInstr m x)+    verifyInstr (Inr m) x = fmap Inr (verifyInstr m x)++--------------------------------------------------------------------------------++instance+  ( VerifyInstr (FO [[SomeLiteral]] instr) exp pred+  , ControlCMD [[SomeLiteral]] :<: FO [[SomeLiteral]] instr+  , HFunctor instr+  , FO.HTraversable (FO [[SomeLiteral]] instr)+  , FO.Defunctionalise [[SomeLiteral]] instr+  , FO.Symbol instr+  , FO.TypeablePred pred+  , FO.Substitute exp+  , FO.SubstPred exp ~ pred+  , pred Bool)+  =>+    Verifiable (Program instr (Param2 exp pred))+  where+    verifyWithResult prog = do+      let inv = undefined :: [[SomeLiteral]]+      (prog', res) <- verifyWithResult (FO.defunctionalise inv prog)+      return (FO.refunctionalise inv prog', res)++instance+  ( VerifyInstr instr exp pred+  , ControlCMD [[SomeLiteral]] Imp.:<: instr)+  =>+    Verifiable (FO.Sequence instr (Param2 exp pred))+  where+    verifyWithResult (FO.Val x) = return (FO.Val x, x)+    verifyWithResult (FO.Seq x m k) = do+      ((m',bs),ws) <- V.swallowWarns $ V.getWarns $ V.withBreaks $ verifyInstr m x+      (_,(k',res)) <- V.ite bs (return ()) $ verifyWithResult k+      return (addWarns ws (FO.Seq x m' k'), res)++addWarns :: ControlCMD [[SomeLiteral]] Imp.:<: instr =>+  [String] ->+  FO.Sequence instr (Param2 exp pred) a ->+  FO.Sequence instr (Param2 exp pred) a+addWarns ws prog = foldr addComment prog ws++addComment :: ControlCMD [[SomeLiteral]] Imp.:<: instr =>+  String -> +  FO.Sequence instr (Param2 exp pred) a ->+  FO.Sequence instr (Param2 exp pred) a+addComment msg prog = flip (FO.Seq ()) prog (Oper.inj (Comment msg ::+  ControlCMD [[SomeLiteral]] (Param3 (FO.Sequence prg fs) exp pred) ()))++--------------------------------------------------------------------------------++-- | Bindings for values.+data ValueBinding exp a = ValueBinding {+    vb_value     :: V.SMTExpr exp a+  , vb_reference :: Maybe String+  }+  deriving (Eq, Ord, Show, Typeable)++instance V.SMTEval exp a => V.Mergeable (ValueBinding exp a)+  where+    merge cond (ValueBinding _ (Just l)) (ValueBinding _ (Just r))+      | l P./= r = error "immutable binding bound in two locations"+    merge cond l r = ValueBinding {+        vb_value     = V.merge cond (vb_value l) (vb_value r)+      , vb_reference = (vb_reference l) `mplus` (vb_reference r)+      }++instance V.SMTEval exp a => V.ShowModel (ValueBinding exp a)+  where+    showModel = V.showModel . vb_value++instance V.SMTEval exp a => V.Fresh (ValueBinding exp a)+  where+    fresh name = V.fresh name >>= return . flip ValueBinding Nothing++instance V.SMTEval exp a => V.IsLiteral (V.Literal (ValueBinding exp a))++instance V.SMTEval exp a => V.Invariant (ValueBinding exp a)+  where+    data Literal (ValueBinding exp a) = LitVB+      deriving (Eq, Ord, Show, Typeable)++instance V.SMTEval exp a => V.Exprs (ValueBinding exp a)+  where+    exprs val = V.toSMT (vb_value val) : []++-- | ...+peekValue :: forall exp a . (V.SMTEval exp a, HasCallStack) => String -> V.Verify (V.SMTExpr exp a)+peekValue name =+  do ValueBinding val ref <- V.peek name+     V.warning () $ case ref of+       Nothing -> return ()+       Just rn ->+         do ref <- V.peek rn :: V.Verify (ReferenceBinding exp a)+            ok  <- V.provable "ref. not frozen" $ val V..==. rb_value ref+            unless ok $ V.warn $ "unsafe use of frozen ref. " ++ name+     return val++-- | ...+pokeValue :: V.SMTEval exp a => String -> V.SMTExpr exp a -> V.Verify ()+pokeValue name val = V.poke name (ValueBinding val Nothing)++--------------------------------------------------------------------------------++data ReferenceBinding exp a = ReferenceBinding {+    rb_value :: V.SMTExpr exp a+  , rb_init  :: SMT.SExpr+  }+  deriving (Eq, Ord, Show, Typeable)++instance V.SMTEval exp a => V.Mergeable (ReferenceBinding exp a)+  where+    merge cond (ReferenceBinding vl rl) (ReferenceBinding vr rr) =+      ReferenceBinding (V.merge cond vl vr) (V.merge cond rl rr)++instance V.SMTEval exp a => V.ShowModel (ReferenceBinding exp a)+  where+    showModel = V.showModel . rb_value++instance V.SMTEval exp a => V.Fresh (ReferenceBinding exp a)+  where+    fresh name =+      do val  <- V.fresh name+         init <- V.freshVar (name ++ ".init") SMT.tBool+         return $ ReferenceBinding val init++instance V.SMTEval exp a => V.IsLiteral (V.Literal (ReferenceBinding exp a))+  where+    smtLit _ new (ReferenceInit name) = rb_init ref+      where+        ref :: ReferenceBinding exp a+        ref = V.lookupContext name new+    smtLit old new (ReferenceSame name) =+      V.toSMT (rb_value refNew) `SMT.eq` V.toSMT (rb_value refOld)+      --rb_init refNew `SMT.eq` rb_init refOld+      where+        refNew, refOld :: ReferenceBinding exp a+        refNew = V.lookupContext name new+        refOld = V.lookupContext name old++instance V.SMTEval exp a => V.Invariant (ReferenceBinding exp a)+  where+    data Literal (ReferenceBinding exp a) =+        ReferenceInit String+      | ReferenceSame String+      deriving (Eq, Ord, Show, Typeable)+    +    literals name _ = ReferenceInit name : ReferenceSame name : []++instance V.SMTEval exp a => V.Exprs (ReferenceBinding exp a)+  where+    exprs val = V.toSMT (rb_value val) : []++-- | ...+newReference :: V.SMTEval exp a => String -> exp a -> V.Verify ()+newReference name (_ :: exp a) =+  do ref <- V.fresh name+     V.poke name (ref { rb_init = SMT.bool False } :: ReferenceBinding exp a)++-- | ...+getReference :: V.SMTEval exp a => String -> V.Verify (V.SMTExpr exp a)+getReference name =+  do ref <- V.peek name+     V.warning () $+       do ok <- V.provable "ref. initialised" $ rb_init ref+          unless ok $ V.warn $ "ref. " ++ name ++ " read before initialisation"+     return $ rb_value ref++-- | ...+setReference :: forall exp a . V.SMTEval exp a => String -> V.SMTExpr exp a ->+  V.Verify ()+setReference name val = do+  ref <- V.peek name :: V.Verify (ReferenceBinding exp a)+  V.poke name ref { rb_value = val, rb_init = SMT.bool True}++-- | ...+unsafeFreezeReference :: forall exp a . V.SMTEval exp a => String -> String ->+  exp a -> V.Verify ()+unsafeFreezeReference nameRef nameVal (_ :: exp a) =+  do ref <- V.peek nameRef :: V.Verify (ReferenceBinding exp a)+     V.poke nameVal (ValueBinding (rb_value ref) (Just nameRef))++--------------------------------------------------------------------------------++-- | A wrapper to help with fresh name generation.+newtype SMTArray exp i a = SMTArray SMT.SExpr+  deriving (Eq, Ord, Show, V.Mergeable)++instance (V.SMTEval exp a, V.SMTEval exp i) => V.Fresh (SMTArray exp i a)+  where+    fresh = V.freshSExpr++instance (V.SMTEval exp a, V.SMTEval exp i) => V.TypedSExpr (SMTArray exp i a)+  where+    smtType _ = SMT.tArray+      (V.smtType (undefined :: V.SMTExpr exp i))+      (V.smtType (undefined :: V.SMTExpr exp a))+    toSMT (SMTArray arr) = arr+    fromSMT arr = SMTArray arr++-- | A binding that represents the contents of an array.+data ArrayContents exp i a = ArrayContents {+    ac_value :: SMTArray exp i a+  , ac_bound :: V.SMTExpr exp i+  }+  deriving (Eq, Ord, Typeable, Show)++instance (V.SMTEval exp a, V.SMTEval exp i) => V.Mergeable (ArrayContents exp i a)+  where+    merge cond (ArrayContents vl bl) (ArrayContents vr br) =+      ArrayContents (V.merge cond vl vr) (V.merge cond bl br)++instance (V.SMTEval exp a, V.SMTEval exp i) => V.ShowModel (ArrayContents exp i a)+  where+    showModel arr = lift $ do+      bound <- SMT.getExpr (V.toSMT (ac_bound arr))+      SMT.showArray bound (V.toSMT (ac_value arr))++instance (V.SMTEval exp a, V.SMTEval exp i) => V.Fresh (ArrayContents exp i a)+  where+    fresh name = do+      value <- V.fresh (name ++ ".value")+      bound <- V.fresh (name ++ ".bound")+      return $ ArrayContents value bound++instance (V.SMTEval exp a, V.SMTEval exp i) =>+  V.IsLiteral (V.Literal (ArrayContents exp i a))++instance (V.SMTEval exp a, V.SMTEval exp i) => V.Invariant (ArrayContents exp i a)+  where+    data Literal (ArrayContents exp i a) = LitAC+      deriving (Eq, Ord, Show, Typeable)++    havoc name arr = do+      value <- V.fresh name+      return $ ArrayContents { ac_value = value, ac_bound = ac_bound arr }++instance (V.SMTEval exp a, V.SMTEval exp i) => V.Exprs (ArrayContents exp i a)+  where+    exprs arr = V.toSMT (ac_bound arr) : V.toSMT (ac_value arr) : []++-- | A binding that represents a reference to an array.+data ArrayBinding exp i a = ArrayBinding {+    arr_source     :: Maybe String+  , arr_accessible :: SMT.SExpr+  , arr_readable   :: SMT.SExpr+  , arr_failed     :: SMT.SExpr+  }+  deriving (Eq, Ord, Typeable, Show)++instance (V.SMTEval exp a, V.SMTEval exp i) => V.Mergeable (ArrayBinding exp i a)+  where+    merge cond (ArrayBinding sl al rl fl) (ArrayBinding sr ar rr fr) =+      ArrayBinding+        (sl `mplus` sl)+        (V.merge cond al ar)+        (V.merge cond rl rr)+        (V.merge cond fl fr)++instance (V.SMTEval exp a, V.SMTEval exp i) => V.ShowModel (ArrayBinding exp i a)+  where+    showModel (ArrayBinding {arr_source = Nothing}) =+      return "<unbound array>"+    showModel (ArrayBinding {arr_source = Just source}) =+      (V.peek source :: V.Verify (ArrayContents exp i a)) >>= V.showModel++instance (V.SMTEval exp a, V.SMTEval exp i) => V.Exprs (ArrayBinding exp i a)+  where+    exprs (ArrayBinding _ a r f) = [a, r, f]++instance (V.SMTEval exp a, V.SMTEval exp i) => V.Fresh (ArrayBinding exp i a)+  where+    fresh name =+      do accessible <- V.freshVar (name ++ ".ok") SMT.tBool+         readable   <- V.freshVar (name ++ ".read") SMT.tBool+         failed     <- V.freshVar (name ++ ".failed") SMT.tBool+         return $ ArrayBinding Nothing accessible readable failed++instance (V.SMTEval exp a, V.SMTEval exp i) =>+    V.IsLiteral (V.Literal (ArrayBinding exp i a))+  where+    smtLit _ new (ArrayAccessible name) =+      arr_accessible (V.lookupContext name new :: ArrayBinding exp i a)+    smtLit _ new (ArrayReadable name) =+      arr_readable (V.lookupContext name new :: ArrayBinding exp i a)+    smtLit old new (ArraySafetyPreserved name) =+      case V.maybeLookupContext name old of+        Just (arr :: ArrayBinding exp i a) ->+          arr_failed arr SMT..||.+          SMT.bool True+          --SMT.not (arr_failed (V.lookupContext name new :: ArrayBinding exp i a))+        Nothing -> SMT.bool False++instance (V.SMTEval exp a, V.SMTEval exp i) => V.Invariant (ArrayBinding exp i a)+  where+    data Literal (ArrayBinding exp i a) =+        ArrayAccessible String+      | ArrayReadable String+      | ArraySafetyPreserved String+      deriving (Eq, Ord, Show, Typeable)++    literals name _ = ArrayAccessible name +                    : ArrayReadable name+                    : ArraySafetyPreserved name+                    : []++    havoc name src =+      do arr <- V.fresh name :: V.Verify (ArrayBinding exp i a)+         return arr { arr_source = arr_source src }++    warns1 ctx name arr = arr { arr_failed = SMT.bool False }+    warns2 ctx name arr = arr {+        arr_accessible = arr_accessible brr+      , arr_readable = arr_readable brr+      , arr_failed = arr_failed brr+      }+      where+        brr :: ArrayBinding exp i a+        brr = V.lookupContext name ctx++    warnLiterals name arr =+          (ArrayAccessible name, ok)+        : (ArrayReadable name, ok)+        : []+      where ok = SMT.not (arr_failed arr)+    warnLiterals2 name _ = ArraySafetyPreserved name : []++-- | ...+arrayBindings :: Typeable (ArrayBinding exp i a) => V.Context -> String ->+  [(String, ArrayBinding exp i a)]+arrayBindings ctx name = filter pred+  [ (name', y)+  | (V.Name name' _, V.Entry x) <- Map.toList ctx+  , Just y <- [cast x]+  ]+  where+    pred :: (String, ArrayBinding exp i a) -> Bool+    pred (_, arr) = arr_source arr P.== Just name++-- | ...+selectArray :: (V.SMTEval exp a, V.SMTEval exp i) => SMTArray exp i a ->+  V.SMTExpr exp i -> V.SMTExpr exp a+selectArray arr i = V.fromSMT (SMT.select (V.toSMT arr) (V.toSMT i))++-- | ...+storeArray :: (V.SMTEval exp a, V.SMTEval exp i) => V.SMTExpr exp i ->+  V.SMTExpr exp a -> SMTArray exp i a -> SMTArray exp i a+storeArray i x arr = V.fromSMT (SMT.store (V.toSMT arr) (V.toSMT i) (V.toSMT x))++newArray :: forall exp i a .+  ( Num (V.SMTExpr exp i)+  , V.SMTOrd (V.SMTExpr exp i)+  , V.SMTEval exp i+  , V.SMTEval exp a+  ) => String -> V.SMTExpr exp i -> V.Verify (SMTArray exp i a)+newArray name n = do+  value <- V.fresh name :: V.Verify (SMTArray exp i a)+  let arr :: ArrayBinding exp i a+      arr = ArrayBinding+              (Just name)+              (SMT.bool True)+              (SMT.bool True)+              (SMT.bool False)+  V.poke name (ArrayContents value n)+  V.poke name arr+  return value++peekArray :: forall exp i a .+  ( V.SMTEval exp i+  , V.SMTEval exp a+  ) => String -> V.Verify (Maybe (+      ArrayBinding exp i a+    , String+    , ArrayContents exp i a))+peekArray name =+  do ctx <- S.get+     arr <- V.peek name+     ok  <- V.provable "array accessible" (arr_accessible arr)+     if ok then+       do let+            source = fromMaybe+              (error "array accessible but has no source")+              (arr_source arr)+          src <- V.peek source+          return (Just (arr, source, src))+     else+       do -- invalidate everything to help with computing the frame+          V.warn ("unsafe use of inaccessible array " ++ name)+          let+            refs = case arr_source arr of+              Nothing  -> (name, arr) : []+              Just src -> arrayBindings ctx src+          forM_ refs $ \(name, arr) ->+            do arr <- V.havoc name arr+               V.poke name (+                 arr { arr_failed = SMT.bool True } :: ArrayBinding exp i a)+          return Nothing++readArray :: forall exp i a .+  ( V.SMTOrd (V.SMTExpr exp i)+  , Ix i+  , V.SMTEval exp i+  , V.SMTEval exp a+  ) => String -> V.SMTExpr exp i -> V.Verify (V.SMTExpr exp a)+readArray name ix = do+  hintArr ix+  marr <- peekArray name+  case marr of+    Nothing -> V.fresh "unbound"+    Just (arr :: ArrayBinding exp i a, _, src) ->+      do V.warning () $+           do ok <- V.provable "array not modified" $+                SMT.not (ix V..==. V.skolemIndex) SMT..||. arr_readable arr+              unless ok $+                do V.warn ("Unsafe use of frozen array " ++ name)+                   V.poke name (+                     arr { arr_failed = SMT.bool True } :: ArrayBinding exp i a)+         return (selectArray (ac_value src) ix)++updateArray :: forall exp i a . (Ix i, V.SMTEval exp i, V.SMTEval exp a) =>+  String ->+  (SMTArray exp i a -> SMTArray exp i a) ->+  (V.SMTExpr exp i -> SMT.SExpr) ->+  V.Verify ()+updateArray name update touched =+  do marr <- peekArray name+     case marr of+       Nothing -> return ()+       Just (arr :: ArrayBinding exp i a, source, src) ->+         do ctx <- S.get+            forM_ (arrayBindings ctx source \\ [(name, arr)]) $ \(name, arr) ->+              do let+                   readable = SMT.not (touched V.skolemIndex) SMT..&&.+                     arr_readable arr+                 V.poke name (+                   arr { arr_readable = readable } :: ArrayBinding exp i a)+            V.poke name (+              arr { arr_readable = SMT.bool True } :: ArrayBinding exp i a)+            V.poke source (+              src { ac_value = update (ac_value src) } :: ArrayContents exp i a)++hintArr :: forall exp i . (V.SMTEval exp i, V.SMTOrd (V.SMTExpr exp i), Ix i) =>+  V.SMTExpr exp i -> V.Verify ()+hintArr ix =+  do V.hintFormula (ix V..<. V.skolemIndex)+     V.hintFormula (ix V..>. V.skolemIndex)++--------------------------------------------------------------------------------+-- ** ...+--------------------------------------------------------------------------------++withWitness :: forall instr prog exp pred a b .+  (V.SMTEval1 exp, V.Pred exp a) =>+  a ->+  instr '(prog, Param2 exp pred) b ->+  (V.SMTEval exp a => V.Verify ()) ->+  V.Verify (instr '(prog, Param2 exp pred) b)+withWitness (x :: a) instr m+  | Dict <- V.witnessPred (undefined :: exp a) = m >> return instr++producesValue :: forall instr prog exp pred a .+  (V.SMTEval1 exp, V.Pred exp a, V.Pred exp ~ pred) =>+  instr '(prog, Param2 exp pred) (Imp.Val a) ->+  Imp.Val a ->+  V.Verify (instr '(prog, Param2 exp pred) (Imp.Val a))+producesValue instr (Imp.ValComp name :: Imp.Val a) =+  withWitness (undefined :: a) instr $+    do val <- V.fresh name+       pokeValue name (val :: V.SMTExpr exp a)++--------------------------------------------------------------------------------++instance (V.SMTEval1 exp, V.Pred exp ~ pred) =>+    V.VerifyInstr Imp.RefCMD exp pred+  where+    verifyInstr i@(Imp.NewRef _) (Imp.RefComp name :: Imp.Ref a) =+      withWitness (undefined :: a) i $+        do newReference name (undefined :: exp a)+    verifyInstr i@(Imp.InitRef _ exp) (Imp.RefComp name :: Imp.Ref a) =+      withWitness (undefined :: a) i $+        do newReference name (undefined :: exp a)+           val <- V.eval exp+           setReference name val+    verifyInstr i@(Imp.GetRef (Imp.RefComp ref)) (Imp.ValComp name :: Imp.Val a) =+      withWitness (undefined :: a) i $+        do val :: V.SMTExpr exp a <- getReference ref+           pokeValue name val+    verifyInstr i@(Imp.SetRef (Imp.RefComp ref :: Imp.Ref a) exp) () =+      withWitness (undefined :: a) i $+        do val <- V.eval exp+           setReference ref val+    verifyInstr i@(Imp.UnsafeFreezeRef (Imp.RefComp ref)) (Imp.ValComp name :: Imp.Val a) =+      withWitness (undefined :: a) i $+        do unsafeFreezeReference ref name (undefined :: exp a)++--------------------------------------------------------------------------------++instance (V.SMTEval1 exp, V.Pred exp ~ pred) =>+    V.VerifyInstr Imp.ArrCMD exp pred+  where+    verifyInstr i@(Imp.NewArr _ n) a@(Imp.ArrComp name :: Imp.Arr i a)+      | Dict <- V.witnessPred (undefined :: exp i)+      , Dict <- V.witnessNum  (undefined :: exp i)+      , Dict <- V.witnessOrd  (undefined :: exp i) =+      withWitness (undefined :: a) i $+        do len <- V.eval n+           arr <- newArray name len :: V.Verify (SMTArray exp i a)+           return ()+    verifyInstr i@(Imp.ConstArr _ xs) a@(Imp.ArrComp name :: Imp.Arr i a)+      | Dict <- V.witnessPred (undefined :: exp i)+      , Dict <- V.witnessNum  (undefined :: exp i)+      , Dict <- V.witnessOrd  (undefined :: exp i) =+      withWitness (undefined :: a) i $+        do let+             is  :: [V.SMTExpr exp i]+             is  = map V.fromConstant [0..]+             ys  :: [V.SMTExpr exp a]+             ys  = map V.fromConstant xs+             len :: Num b => b+             len = fromIntegral (P.length xs)+           arr :: SMTArray exp i a <- newArray name len+           forM_ (P.zip is ys) $ \(i, y) ->+             V.assume "array initialisation" (selectArray arr i V..==. y)+    verifyInstr i@(Imp.GetArr (Imp.ArrComp arr :: Imp.Arr i a) ix) (Imp.ValComp name)+      | Dict <- V.witnessPred (undefined :: exp i)+      , Dict <- V.witnessOrd  (undefined :: exp i) =+      withWitness (undefined :: a) i $+        do ix' <- V.eval ix+           val :: V.SMTExpr exp a <- readArray arr ix'+           pokeValue name val+    verifyInstr i@(Imp.SetArr (Imp.ArrComp arr :: Imp.Arr i a) ix val) ()+      | Dict <- V.witnessPred (undefined :: exp i)+      , Dict <- V.witnessOrd  (undefined :: exp i) =+      withWitness (undefined :: a) i $+        do ix'  <- V.eval ix+           val' <- V.eval val+           updateArray arr (storeArray ix' val') (V..==. ix')+           hintArr ix'+    verifyInstr i@(Imp.CopyArr (Imp.ArrComp dest :: Imp.Arr i a, destOffs) (Imp.ArrComp src, srcOffs) len) ()+      | Dict <- V.witnessPred (undefined :: exp i)+      , Dict <- V.witnessNum  (undefined :: exp i)+      , Dict <- V.witnessOrd  (undefined :: exp i) =+      withWitness (undefined :: a) i $+        do dest' :: ArrayBinding exp i a <- V.peek dest+           src'  :: ArrayBinding exp i a <- V.peek src+           destOffs' <- V.eval destOffs+           srcOffs'  <- V.eval srcOffs+           len'      <- V.eval len+           ix :: V.SMTExpr exp i <- V.fresh "index"+           V.assume "index in bounds" $+             (len' V..<=. 0) SMT..||.+             (srcOffs' V..<=. ix) SMT..&&. (ix V..<. (destOffs' + len'))+           val :: V.SMTExpr exp a <- readArray src ix+           -- todo: interpret destination array.+           dest' :: SMTArray exp i a <- V.fresh "copy"+           updateArray dest (P.const dest') $ \i ->+             (destOffs' V..<=. i) SMT..&&. (i V..<. (destOffs' + len'))+    verifyInstr i@(Imp.UnsafeFreezeArr (Imp.ArrComp arr :: Imp.Arr i a)) (Imp.IArrComp name)+      | Dict <- V.witnessPred (undefined :: exp i) =+      withWitness (undefined :: a) i $+        do arr' :: ArrayBinding exp i a <- V.peek arr+           V.poke name arr'+    verifyInstr i@(Imp.UnsafeThawArr (Imp.IArrComp iarr :: Imp.IArr i a)) (Imp.ArrComp name)+      | Dict <- V.witnessPred (undefined :: exp i) =+      withWitness (undefined :: a) i $+        do iarr' :: ArrayBinding exp i a <- V.peek iarr+           V.poke name iarr'++--------------------------------------------------------------------------------++instance (V.SMTEval1 exp, V.Pred exp ~ pred) =>+    V.VerifyInstr Imp.FileCMD exp pred+  where+    verifyInstr i@(Imp.FPrintf _ _ as) _ =+      do let+           evalArg :: Imp.PrintfArg exp pred -> V.Verify ()+           evalArg (Imp.PrintfArg (exp :: exp a)) =+             case V.witnessPred (undefined :: exp a) of+               Dict -> void (V.eval exp)+         mapM_ evalArg as+         return i+    verifyInstr i@(Imp.FGet{}) val = producesValue i val+    verifyInstr i _ = return i++--------------------------------------------------------------------------------++instance (V.SMTEval1 exp, V.Pred exp ~ pred) =>+    V.VerifyInstr Imp.PtrCMD exp pred+  where+    verifyInstr instr@(Imp.SwapPtr _ _) () = error "oh no!"+    verifyInstr instr@(Imp.SwapArr (Imp.ArrComp x :: Imp.Arr i a) (Imp.ArrComp y)) ()+      | Dict <- V.witnessPred (undefined :: exp i),+        Dict <- V.witnessPred (undefined :: exp a) = do+        ctx  <- S.get+        marr1 <- peekArray x+        marr2 <- peekArray y+        case (marr1, marr2) of+          (Just (arr1 :: ArrayBinding exp i a, source1, src1),+           Just (arr2 :: ArrayBinding exp i a, source2, src2)) -> do+            -- Invalidate all existing references to the arrays+            forM_ (arrayBindings ctx source1 ++ arrayBindings ctx source2) $+              \(name, arr :: ArrayBinding exp i a) ->+                V.poke name (arr { arr_accessible = SMT.bool False }+                             :: ArrayBinding exp i a)+            -- Swap the two arrays around+            V.poke x arr2+            V.poke y arr1+          _ -> return ()+        return instr++instance V.VerifyInstr Imp.C_CMD exp pred+  where+    verifyInstr = error "don't know how to verify C commands."++--------------------------------------------------------------------------------++instance (V.SMTEval1 exp, V.SMTEval exp Bool, V.Pred exp ~ pred, pred Bool) =>+    V.VerifyInstr (ControlCMD [[SomeLiteral]]) exp pred+  where+    verifyInstr (Test (Nothing) msg) () =+      return (Test (Nothing) msg)+    verifyInstr (Test (Just cond) msg) () =+      do b   <- V.eval cond+         res <- V.provable "assertion" (V.toSMT b)+         if res then do+           return (Test (Nothing) msg)+         else do+           V.assume "assertion" (V.toSMT b)+           return (Test (Just cond) msg)+    verifyInstr i@(Hint (exp :: exp a)) () =+      withWitness (undefined :: a) i $ +        do V.eval exp >>= V.hint+    verifyInstr (If cond t f) () =+      do b <- V.eval cond+         (vt, vf) <- V.ite (V.toSMT b) (V.verify t) (V.verify f)+         --V.hintFormula (V.toSMT b)+         --V.hintFormula (SMT.not (V.toSMT b))+         return (If cond vt vf)+    verifyInstr (While inv cond body) () =+      do let+           loop =+             do b   <- V.verifyWithResult cond+                res <- V.eval (snd b)+                V.ite (V.toSMT res) (V.verify body) V.break+                return ()+         (done, new, _) <- discoverInvariant inv loop+         (vcond, vbody) <- V.stack $+           do (vcond, b) <- V.verifyWithResult cond+              res        <- V.eval b+              V.assume "loop guard" (V.toSMT res)+              vbody      <- V.verify body+              return (vcond, vbody)+         done+         return (While new vcond vbody)+    verifyInstr (For inv range@(lo, step, hi) val@(Imp.ValComp name :: Imp.Val a) body) ()+      | Dict <- V.witnessPred (undefined :: exp a)+      , Dict <- V.witnessNum  (undefined :: exp a)+      , Dict <- V.witnessOrd  (undefined :: exp a) =+      do let+           cond =+             do unsafeFreezeReference name name (undefined :: exp a)+                i <- peekValue name+                n <- V.eval (Imp.borderVal hi)+                m <- V.eval lo+                guard <-+                  if step P.>= 0 then do+                    V.hintFormula (m V..<=. i)+                    return (if Imp.borderIncl hi then i V..<=. n else i V..<. n)+                  else do+                    V.hintFormula (i V..<=. m)+                    return (if Imp.borderIncl hi then n V..<=. i else i V..<. n)+                V.hintFormula guard+                return guard+         let+           loop body =+             do cond <- cond+                V.ite (SMT.not cond) V.break $+                  do breaks <- V.breaks (V.verify body)+                     V.ite breaks (return ()) $+                       do i <- peekValue name :: V.Verify (V.SMTExpr exp a)+                          setReference name (i + P.fromIntegral step)+                return ()+         old <- S.get+         m   <- V.eval lo+         newReference name (undefined :: exp a)+         setReference name m+         (done, inv, ass) <- discoverInvariant inv (loop body)+         body <- V.noWarn $ V.stack $+           do cond <- cond+              V.assume "loop guard" cond+              V.verify body+         let+           updateCtx :: V.Context ->+                        (forall a. V.Invariant a =>+                          V.Context ->+                          String ->+                          a ->+                          a) ->+                        Verify ()+           updateCtx old f = forM_ (Map.toList old) $+             \(V.Name name _, V.Entry (_ :: b)) ->+               do (x :: b) <- V.peek name+                  V.poke name (f old name x)+         let+           getLits :: (forall a. V.Invariant a =>+                        String ->+                        a ->+                        [(V.Literal a, SMT.SExpr)]) ->+                      V.Verify [SomeLiteral]+           getLits f =+             do new <- S.get+                let cands = [ (SomeLiteral l, e)+                            | (var@(V.Name name _), V.Entry x) <- Map.toList new+                            , var `Map.member` old+                            , (l, e) <- f name x+                            ]+                let ok (SomeLiteral _, e) = V.provable "magic safety invariant" e+                fmap (map fst) (filterM ok cands)+         (lits, lits') <- V.warning ([], []) $ V.stack $+           do -- Iteration 1.+              i :: V.SMTExpr exp a <- getReference name+              updateCtx old (\ctx x -> V.warns1 ctx x . V.warns2 ctx x)+              pre    <- S.get+              breaks <- V.breaks (loop body)+              mid    <- S.get+              lits1  <- getLits V.warnLiterals+              -- Iteration 2.+              V.assume "loop didn't break" (SMT.not breaks)+              ass+              j :: V.SMTExpr exp a <- getReference name+              updateCtx mid V.warns2+              V.assume "distinct iterations" (i V..<. j)+              loop body+              lits2 <- getLits V.warnLiterals+              ctx   <- S.get+              lits' <- getLits $ \name x ->+                map (\x -> (x, V.smtLit pre ctx x)) (V.warnLiterals2 name x)+              return (lits1 `intersect` lits2, lits')+         --+         S.liftIO (putStrLn ("Magic safety literals (body): " ++ show lits))+         S.liftIO (putStrLn ("Magic safety literals (invariant): " ++ show lits'))+         --+         ctx <- S.get+         forM_ lits $ \(SomeLiteral lit) ->+           V.assume "magic safety invariant" (V.smtLit old ctx lit)+         body <- V.stack $+           do forM_ lits $ \(SomeLiteral lit) ->+                V.assume "magic safety invariant" (V.smtLit old ctx lit)+              cond <- cond+              V.assume "loop guard" cond+              V.verify body+         done+         return (For (fmap (++ map return lits') inv) range val body)++--------------------------------------------------------------------------------++-- | The literals used in predicate abstraction.+data SomeLiteral = forall a . V.IsLiteral a => SomeLiteral a++instance Eq SomeLiteral+  where+    x == y = compare x y P.== EQ++instance Show SomeLiteral+  where+    show (SomeLiteral x) = show x++instance Ord SomeLiteral+  where+  compare (SomeLiteral x) (SomeLiteral y) =+    compare (typeOf x) (typeOf y) `mappend`+    case cast y of+      Just y  -> compare x y+      Nothing -> error "weird type error"++-- Takes a loop body, which should break on exit, and does predicate abstraction.+-- Leaves the verifier in a state which represents an arbitrary loop iteration.+-- Returns a value which when run leaves the verifier in a state where the loop+-- has terminated.+discoverInvariant ::+  Maybe [[SomeLiteral]] ->+  V.Verify () ->+  V.Verify (+      V.Verify ()+    , Maybe [[SomeLiteral]]+    , V.Verify ()+    )+discoverInvariant minv body = do+  (frame, hints) <- findFrameAndHints+  (_, _, mode)   <- S.ask+  case minv of+    Nothing | mode P./= V.Execute ->+      do ctx <- S.get+         abs <- abstract ctx frame hints+         refine frame hints abs+    _ ->+      do let+           ass = assumeLiterals frame (fromMaybe [] minv)+           brk = V.noBreak (V.breaks body) >>= V.assume "loop terminated"+         ass >> return (brk, minv, ass)+  where+    -- Suppose we have a while-loop while(E) S, and we know a formula+    -- I(0) which describes the initial state of the loop.+    --+    -- We can describe the state after one iteration by the formula+    --   I(1) := sp(S, I(0) /\ ~E)+    -- where sp(S, P) is the strongest postcondition function.+    -- Likewise, we can describe the state after n+1 iterations by:+    --   I(n+1) := sp(S, I(n) /\ ~E)+    -- The invariant of the loop is then simply+    --   I := I(0) \/ I(1) \/ I(2) \/ ...+    --+    -- Of course, this invariant is infinite and not very useful.+    --+    -- The idea of predicate abstraction is this: if we restrict the+    -- invariant to be a boolean formula built up from a fixed set of+    -- literals, then there are only a finite number of possible+    -- invariants and we can in fact compute an invariant using the+    -- procedure above - at some point I(n+1) = I(n) and then I(n) is+    -- the invariant. We just need to be able to compute the strongest+    -- boolean formula provable in the current verifier state -+    -- something which Abstract.hs provides.+    --+    -- Often a variable is not modified by the loop body, and in that+    -- case we don't need to bother finding an invariant for that+    -- variable - its value is the same as on entry to the loop. We+    -- therefore also compute the set of variables modified by the+    -- loop body, which we call the frame, and only consider literals+    -- that mention frame variables. We do not need to do anything+    -- explicitly for non-frame variables - it is enough to leave them+    -- unchanged in the context when verifying the loop body.+    --+    -- Recall that the goal is to put the verifier in a state+    -- representing an arbitrary loop iteration. Here is how we do+    -- that:+    --   * Find n such that I(n) = I(n+1).+    --   * Havoc the frame variables (update the context to turn them+    --     into fresh SMT variables). This puts the SMT solver in a+    --     state where it knows nothing about those variables, but it+    --     still knows the values of the non-frame variables.+    --   * Assert that I(n) holds.+    --+    -- To find the invariant we must be able to compute I(0),+    -- and to go from I(n) to I(n+1). To compute I(0), we just run+    -- predicate abstraction in the state we initially find ourselves+    -- in. To get from I(n) to I(n+1) we do the following:+    --   * Havoc the frame variables and then assert I(n). Similar to+    --     above, this tells the verifier that we are in an arbitrary+    --     state in which I(n) holds.+    --   * Assert that the loop has not terminated yet, execute the+    --     loop body once, and use predicate abstraction to compute a+    --     new formula P describing the state we are in now.+    --     This corresponds to sp(S, I(n) /\ ~E). Then let+    --     I(n+1) = I(n) \/ P.+    -- Note that we do all this inside a call to "stack" so that+    -- it doesn't permanently change the verifier state.+    findFrameAndHints = V.stack $ V.quietly $ V.noWarn $ V.quickly $ do+      -- Put the verifier in an arbitrary state.+      ctx <- S.get+      let+        op ctx (V.Name name _, V.Entry (x :: a)) = do+          val <- V.havoc name x+          return (V.insertContext name (val :: a) ctx)+      before <- foldM op Map.empty (Map.toList ctx)+      S.put before++      -- Run the program and see what changed.+      (_, _, hints, decls) <- fmap snd (S.listen body)+      after <- S.get++      let+        atoms (SMT.Atom x) = [x]+        atoms (SMT.List xs) = concatMap atoms xs++        hints' =+          [ V.Hint before hint+          | hint <- nub hints,+            null (intersect decls (atoms (V.hb_exp hint))) ]++      return (Map.toList (V.modified before after), hints')++    refine frame hints clauses = do+      ctx <- S.get+      clauses' <- V.stack $ V.quietly $ V.noWarn $ do+        assumeLiterals frame clauses+        V.noBreak (V.breaks body) >>= V.assume "loop not terminated" . SMT.not+        fmap (disjunction clauses) (V.chattily (abstract ctx frame hints))++      if clauses P.== clauses' then do+        printInvariant "Invariant" frame clauses+        let ass = assumeLiterals frame clauses+        ass+        return (V.noBreak (V.breaks body) >>= V.assume "loop terminated", Just clauses, ass)+      else refine frame hints clauses'++    assumeLiterals :: [(V.Name, V.Entry)] -> [[SomeLiteral]] -> Verify ()+    assumeLiterals frame clauses = do+      ctx <- S.get+      forM_ frame $ \(V.Name name _, V.Entry (_ :: a)) -> do+        val <- V.peek name >>= V.havoc name+        V.poke name (val :: a)+      mapM_ (\clause -> (evalClause ctx >=> V.assume (show clause)) clause) clauses++    abstract old frame hints = fmap (usort . map usort) $ do+      res <- V.quietly $ fmap concat $ mapM (A.abstract (\clause -> (evalClause old >=> V.provable (show clause)) clause)) (lits frame)+      printInvariant "Candidate invariant" frame res+      return res+      where+        lits frame =+          partitionBy (\(SomeLiteral x) -> V.phase x) $+          concat [ map SomeLiteral (V.literals name x) | (V.Name name _, V.Entry x) <- frame ] +++          [ SomeLiteral hint | hint <- hints, V.hb_type (V.hint_body hint) P.== SMT.tBool ]++    printInvariant kind frame [] =+      S.liftIO $+        putStrLn ("No invariant found over frame " ++ show (map fst frame))+    printInvariant kind frame clauses = S.liftIO $ do+      putStrLn (kind ++ " over frame " ++ show (map fst frame) ++ ":")+      sequence_ [ putStrLn ("  " ++ show clause) | clause <- clauses ]++    disjunction cs1 cs2 = prune (usort [ usort (c1 ++ c2) | c1 <- cs1, c2 <- cs2 ])+      where+        prune cs = [ c | c <- cs, and [ c P.== c' P.|| c' \\ c P./= [] | c' <- cs ] ]++    usort :: Ord a => [a] -> [a]+    usort = map head . group . sort++    partitionBy :: Ord b => (a -> b) -> [a] -> [[a]]+    partitionBy f xs = groupBy ((P.==) `on` f) (sortBy (comparing f) xs)++evalClause :: V.Context -> [SomeLiteral] -> V.Verify SMT.SExpr+evalClause old clause = do+  ctx <- S.get+  return (SMT.disj [ V.smtLit old ctx lit | SomeLiteral lit <- clause ])++--------------------------------------------------------------------------------++-- reveal :: Typeable a => Variable -> a+-- reveal (Variable a _) = fromMaybe (error "substitution type error") (cast a)++instance FO.Name (Imp.Handle)   where name a = show $ C.toIdent a C.noLoc+instance FO.Name (Imp.Ref a)    where name a = show $ C.toIdent a C.noLoc+instance FO.Name (Imp.Val a)    where name a = show $ C.toIdent a C.noLoc+instance FO.Name (Imp.Arr  i a) where name a = show $ C.toIdent a C.noLoc+instance FO.Name (Imp.IArr i a) where name a = show $ C.toIdent a C.noLoc++instance FO.Ex (Imp.Handle)     where hide = FO.E+instance FO.Ex (Imp.Ref a)      where hide = FO.E+instance FO.Ex (Imp.Val a)      where hide = FO.E+instance FO.Ex (Imp.Arr  i a)   where hide = FO.E+instance FO.Ex (Imp.IArr i a)   where hide = FO.E++witnessF1 :: forall f instr prog exp pred a b .+     (FO.TypeablePred pred, Typeable f) => f a+  -> (Typeable a => FO.HO instr (Param3 prog exp pred) b)+  -> (pred a     => FO.HO instr (Param3 prog exp pred) b)+witnessF1 _ x = case FO.witnessTypeable (Dict :: Dict (pred a)) of+  Dict -> x++witnessF2 :: forall f instr prog exp pred a b c .+     (FO.TypeablePred pred, Typeable f) => f a b+  -> (Typeable a => Typeable b => FO.HO instr (Param3 prog exp pred) c)+  -> (pred a     => pred b     => FO.HO instr (Param3 prog exp pred) c)+witnessF2 f x = case FO.witnessTypeable (Dict :: Dict (pred a)) of+  Dict -> witnessF1 f x++--------------------------------------------------------------------------------++named1 :: forall f instr prog exp pred a .+     (FO.TypeablePred pred, Typeable f, FO.Ex (f a))+  => (Typeable a =>       instr (Param3 prog exp pred) (f a))+  -> (pred a     => FO.HO instr (Param3 prog exp pred) (f a))+named1 instr = witnessF1 (undefined :: f a) (FO.Named instr)++named2 :: forall f instr prog exp pred a b .+     (FO.TypeablePred pred, Typeable f, FO.Ex (f a b))+  => (Typeable a => Typeable b =>       instr (Param3 prog exp pred) (f a b))+  -> (pred a     => pred b     => FO.HO instr (Param3 prog exp pred) (f a b))+named2 instr = witnessF2 (undefined :: f a b) (FO.Named instr)++unnamed1 :: forall f instr prog exp pred a .+     (FO.TypeablePred pred, Typeable f) => f a+  -> (Typeable a =>       instr (Param3 prog exp pred) ())+  -> (pred a     => FO.HO instr (Param3 prog exp pred) ())+unnamed1 f instr = witnessF1 f (FO.Unnamed instr)++unnamed2 :: forall f instr prog exp pred a b .+     (FO.TypeablePred pred, Typeable f) => f a b+  -> (Typeable a => Typeable b =>       instr (Param3 prog exp pred) ())+  -> (pred a     => pred b     => FO.HO instr (Param3 prog exp pred) ())+unnamed2 f instr = witnessF2 f (FO.Unnamed instr)++--------------------------------------------------------------------------------++instance FO.Defunctionalise inv Imp.RefCMD+  where+    refunc _ sub (Imp.NewRef name) =+      named1 $ Imp.NewRef name+    refunc _ sub (Imp.InitRef name exp) =+      named1 $ Imp.InitRef name $ FO.subst sub exp+    refunc _ sub (Imp.GetRef ref) =+      named1 $ Imp.GetRef $ FO.lookupSubst sub ref+    refunc _ sub (Imp.SetRef ref exp) =+      unnamed1 ref $ Imp.SetRef (FO.lookupSubst sub ref) (FO.subst sub exp)+    refunc _ sub (Imp.UnsafeFreezeRef ref) =+      named1 $ Imp.UnsafeFreezeRef $ FO.lookupSubst sub ref++instance FO.Defunctionalise inv Imp.ArrCMD+  where+    refunc _ sub (Imp.NewArr name n) =+      named2 $ Imp.NewArr name $ FO.subst sub n+    refunc _ sub (Imp.ConstArr name xs) =+      named2 $ Imp.ConstArr name xs+    refunc _ sub (Imp.GetArr arr i) =+      witnessF2 arr $ FO.Named $+        Imp.GetArr (FO.lookupSubst sub arr) (FO.subst sub i)+    refunc _ sub (Imp.SetArr arr i exp) =+      unnamed2 arr $ Imp.SetArr+        (FO.lookupSubst sub arr)+        (FO.subst sub i)+        (FO.subst sub exp)+    refunc _ sub (Imp.CopyArr (arr, i) (brr, j) n) =+      unnamed2 arr $ Imp.CopyArr+        (FO.lookupSubst sub arr, FO.subst sub i)+        (FO.lookupSubst sub brr, FO.subst sub j)+        (FO.subst sub n)+    refunc _ sub (Imp.UnsafeFreezeArr arr) =+      named2 $ Imp.UnsafeFreezeArr (FO.lookupSubst sub arr)+    refunc _ sub (Imp.UnsafeThawArr iarr) =+      named2 $ Imp.UnsafeThawArr (FO.lookupSubst sub iarr)++instance FO.Defunctionalise inv Imp.FileCMD+  where+    refunc _ sub (Imp.FOpen name mode) =+      FO.Named $ Imp.FOpen name mode+    refunc _ sub (Imp.FClose h) =+      FO.Unnamed $ Imp.FClose $ FO.lookupSubst sub h+    refunc _ sub (Imp.FEof h) =+      FO.Named $ Imp.FEof $ FO.lookupSubst sub h+    refunc _ sub (Imp.FPrintf h msg args) =+      FO.Unnamed $ Imp.FPrintf+        (FO.lookupSubst sub h) msg+        (map (Imp.mapPrintfArg (FO.subst sub)) args)+    refunc _ sub (Imp.FGet h) =+      named1 $ Imp.FGet (FO.lookupSubst sub h)++instance FO.Defunctionalise inv Imp.PtrCMD+  where+    refunc inv sub (Imp.SwapPtr a b) = error "oh no!"+    refunc inv sub (Imp.SwapArr a b) =+      FO.Unnamed $ Imp.SwapArr (FO.lookupSubst sub a) (FO.lookupSubst sub b)++instance FO.Defunctionalise inv Imp.ControlCMD+  where+    type FO inv Imp.ControlCMD = ControlCMD inv++    defunc _ (Imp.If cond t f) =+      return (If cond t f)+    defunc _ (Imp.While cond body) =+      return (While Nothing cond body)+    defunc _ (Imp.For range body) = do+      ix <- fmap (Imp.ValComp . ('v':) . show) FO.fresh+      return (For Nothing range ix (body ix))+    defunc _ (Imp.Break) =+      return Break+    defunc _ (Imp.Assert cond msg) =+      return (Test (Just cond) msg)+    defunc _ (Imp.Hint exp) =+      return (Hint exp)+    defunc _ (Imp.Comment msg) =+      return (Comment msg)++    refunc inv sub (If cond t f) =+      FO.Unnamed $ Imp.If+        (FO.subst sub cond)+        (FO.refunctionaliseM inv sub t)+        (FO.refunctionaliseM inv sub f)+    refunc inv sub (While _ cond body) =+      FO.Unnamed $ Imp.While+        (FO.refunctionaliseM inv sub cond)+        (FO.refunctionaliseM inv sub body)+    refunc inv sub (For _ (lo :: exp i, step, hi) ix body) =+      witnessF1 ix $ FO.Unnamed $ Imp.For+        (FO.subst sub lo, step, fmap (FO.subst sub) hi)+        (\jx -> FO.refunctionaliseM inv (FO.extendSubst ix jx sub) body)+    refunc inv sub (Break) =+      FO.Unnamed $ Imp.Break+    refunc inv sub (Test (Just cond) msg) =+      FO.Unnamed $ Imp.Assert (FO.subst sub cond) msg+    refunc inv sub (Test Nothing msg) =+      FO.Unnamed $ Imp.Comment $ "proved: " ++ msg+    refunc inv sub (Hint exp) =+      FO.Unnamed $ Imp.Hint $ FO.subst sub exp+    refunc inv sub (Comment msg) =+      FO.Unnamed $ Imp.Comment msg++instance FO.Defunctionalise inv Imp.C_CMD+  where+    refunc = error "don't know how to refunc. C commands."++--------------------------------------------------------------------------------++instance FO.HTraversable Imp.RefCMD+instance FO.HTraversable Imp.ArrCMD+instance FO.HTraversable Imp.FileCMD+instance FO.HTraversable Imp.PtrCMD+instance FO.HTraversable Imp.C_CMD++instance FO.Symbol Imp.RefCMD+  where+    dry (Imp.NewRef base)    = liftM Imp.RefComp $ FO.freshStr base+    dry (Imp.InitRef base _) = liftM Imp.RefComp $ FO.freshStr base+    dry (Imp.GetRef _)       = liftM Imp.ValComp $ FO.freshStr "v"+    dry (Imp.SetRef _ _)     = return ()+    dry (Imp.UnsafeFreezeRef (Imp.RefComp ref)) =+      liftM Imp.ValComp $ FO.freshStr (ref ++ ".")++instance FO.Symbol Imp.ArrCMD+  where+    dry (Imp.NewArr base _)   = liftM Imp.ArrComp $ FO.freshStr base+    dry (Imp.ConstArr base _) = liftM Imp.ArrComp $ FO.freshStr base+    dry (Imp.GetArr _ _)      = liftM Imp.ValComp $ FO.freshStr "v"+    dry (Imp.SetArr _ _ _)    = return ()+    dry (Imp.CopyArr _ _ _)   = return ()+    dry (Imp.UnsafeFreezeArr (Imp.ArrComp arr)) =+      liftM Imp.IArrComp $ FO.freshStr (arr ++ ".")+    dry (Imp.UnsafeThawArr (Imp.IArrComp iarr)) =+      liftM Imp.ArrComp  $ FO.freshStr (iarr ++ ".")++instance FO.Symbol Imp.ControlCMD+  where+    dry (Imp.If _ _ _)   = return ()+    dry (Imp.While _ _)  = return ()+    dry (Imp.For _ _)    = return ()+    dry (Imp.Break)      = return ()+    dry (Imp.Assert _ _) = return ()+    dry (Imp.Hint _)     = return ()++instance FO.Symbol Imp.FileCMD+  where+    dry (Imp.FOpen _ _)     = liftM Imp.HandleComp $ FO.freshStr "h"+    dry (Imp.FClose _)      = return ()+    dry (Imp.FPrintf _ _ _) = return ()+    dry (Imp.FGet _)        = liftM Imp.ValComp $ FO.freshStr "v"+    dry (Imp.FEof _)        = liftM Imp.ValComp $ FO.freshStr "v"++instance FO.Symbol Imp.PtrCMD+  where+    dry (Imp.SwapPtr _ _) = return ()+    dry (Imp.SwapArr _ _) = return ()++instance FO.Symbol Imp.C_CMD+  where+    dry (Imp.NewCArr base _ _)     = liftM Imp.ArrComp $ FO.freshStr base+    dry (Imp.ConstCArr base _ _)   = liftM Imp.ArrComp $ FO.freshStr base+    dry (Imp.NewPtr base)          = liftM Imp.PtrComp $ FO.freshStr base+    dry (Imp.PtrToArr (Imp.PtrComp p)) = return $ Imp.ArrComp p+    dry (Imp.NewObject base t p)   =+      liftM (Imp.Object p t) $ FO.freshStr base+    dry (Imp.AddInclude _)         = return ()+    dry (Imp.AddDefinition _)      = return ()+    dry (Imp.AddExternFun _ _ _)   = return ()+    dry (Imp.AddExternProc _ _)    = return ()+    dry (Imp.CallFun _ _)          = liftM Imp.ValComp $ FO.freshStr "v"+    dry (Imp.CallProc _ _ _)       = return ()+    dry (Imp.InModule _ _)         = return ()++--------------------------------------------------------------------------------
+ src/Feldspar/Software/Verify/Primitive.hs view
@@ -0,0 +1,701 @@+{-# language Rank2Types #-}+{-# language ScopedTypeVariables #-}+{-# language DataKinds #-}+{-# language TypeOperators #-}+{-# language TypeFamilies #-}+{-# language FlexibleInstances #-}+{-# language FlexibleContexts #-}+{-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language GADTs #-}+{-# language ConstraintKinds #-}+{-# language GeneralizedNewtypeDeriving #-}++module Feldspar.Software.Verify.Primitive where++import Feldspar.Sugar+import Feldspar.Representation+import Feldspar.Software.Primitive+import Feldspar.Software.Expression+import Feldspar.Software.Representation hiding (Nil)+import Feldspar.Software.Verify.Command+import Feldspar.Verify.Arithmetic++import Feldspar.Verify.Monad (Verify)+import qualified Feldspar.Verify.FirstOrder as FO+import qualified Feldspar.Verify.Monad as V+import qualified Feldspar.Verify.SMT as SMT+import qualified Feldspar.Verify.Abstract as A++import Data.Struct+import qualified Data.Map.Strict as Map++import qualified Control.Monad.RWS.Strict as S++import qualified SimpleSMT as SMT hiding (not, declareFun)++import qualified Language.Embedded.Expression as Imp+import qualified Language.Embedded.Imperative.CMD as Imp++import qualified Data.Bits as Bits+import qualified Data.Complex as Complex+import Data.Constraint hiding (Sub)+import Data.Int+import Data.Word+import Data.Typeable++import Language.Syntactic++import GHC.Stack++--------------------------------------------------------------------------------+-- *+--------------------------------------------------------------------------------++newtype Symbolic a = Symbolic { unSymbolic :: Rat }+  deriving (Eq, Ord, Show, V.TypedSExpr, V.SMTOrd)++instance V.Fresh (Symbolic a)+  where+    fresh = V.freshSExpr++symbCast :: Symbolic a -> Symbolic b+symbCast = Symbolic . unSymbolic++symbFun :: SymbParam a => String -> [Symbolic a] -> Symbolic a+symbFun name (args :: [Symbolic a]) = V.fromSMT $+  SMT.fun (symbType (undefined :: a) ++ "-" ++ name) (map V.toSMT args)++fromComplexConstant :: (RealFrac a, SymbParam b) => Complex.Complex a -> Symbolic b+fromComplexConstant c = symbFun "complex" [real, imag]+  where+    real = Symbolic $ fromRational $ toRational $ Complex.realPart c+    imag = Symbolic $ fromRational $ toRational $ Complex.imagPart c++--------------------------------------------------------------------------------++data SymbFloat+data SymbDouble+data SymbComplexFloat+data SymbComplexDouble++class SymbParam a+  where+    symbType :: a -> String++instance SymbParam SymbFloat  where symbType _ = "float"+instance SymbParam SymbDouble where symbType _ = "double"+instance SymbParam SymbComplexFloat  where symbType _ = "cfloat"+instance SymbParam SymbComplexDouble where symbType _ = "cdouble"++instance SymbParam a => Num (Symbolic a)+  where+    fromInteger = Symbolic . fromInteger+    x + y  = symbFun "+" [x, y]+    x - y  = symbFun "-" [x, y]+    x * y  = symbFun "*" [x, y]+    abs    = smtAbs+    signum = smtSignum++instance SymbParam a => Fractional (Symbolic a) where+  fromRational = Symbolic . fromRational+  x / y = symbFun "/" [x, y]++instance SymbParam a => Floating (Symbolic a) where+  pi      = fromRational (toRational pi)+  exp x   = symbFun "exp" [x]+  log x   = symbFun "log" [x]+  sqrt x  = symbFun "sqrt" [x]+  x ** y  = symbFun "pow" [x, y]+  sin x   = symbFun "sin" [x]+  cos x   = symbFun "cos" [x]+  tan x   = symbFun "tan" [x]+  asin x  = symbFun "asin" [x]+  acos x  = symbFun "acos" [x]+  atan x  = symbFun "atan" [x]+  sinh x  = symbFun "sinh" [x]+  cosh x  = symbFun "cosh" [x]+  tanh x  = symbFun "tanh" [x]+  asinh x = symbFun "asinh" [x]+  acosh x = symbFun "acosh" [x]+  atanh x = symbFun "atanh" [x]++--------------------------------------------------------------------------------++class Floating a => Complex a+  where+    type RealPart a+    complex   :: RealPart a -> RealPart a -> a+    polar     :: RealPart a -> RealPart a -> a+    real      :: a -> RealPart a+    imag      :: a -> RealPart a+    magnitude :: a -> RealPart a+    phase     :: a -> RealPart a+    conjugate :: a -> a++instance Complex (V.SMTExpr Prim (Complex.Complex Float))+  where+    type RealPart (V.SMTExpr Prim (Complex.Complex Float)) = V.SMTExpr Prim Float+    complex   (Float x) (Float y) = ComplexFloat (complex x y)+    polar     (Float x) (Float y) = ComplexFloat (polar x y)+    real      (ComplexFloat x)    = Float (real x)+    imag      (ComplexFloat x)    = Float (imag x)+    magnitude (ComplexFloat x)    = Float (magnitude x)+    phase     (ComplexFloat x)    = Float (phase x)+    conjugate (ComplexFloat x)    = ComplexFloat (conjugate x)++instance Complex (V.SMTExpr Prim (Complex.Complex Double))+  where+    type RealPart (V.SMTExpr Prim (Complex.Complex Double)) = V.SMTExpr Prim Double+    complex   (Double x) (Double y) = ComplexDouble (complex x y)+    polar     (Double x) (Double y) = ComplexDouble (polar x y)+    real      (ComplexDouble x)     = Double (real x)+    imag      (ComplexDouble x)     = Double (imag x)+    magnitude (ComplexDouble x)     = Double (magnitude x)+    phase     (ComplexDouble x)     = Double (phase x)+    conjugate (ComplexDouble x)     = ComplexDouble (conjugate x)++witnessComplex :: (SoftwarePrimType a, SoftwarePrimType (Complex.Complex a)) =>+  Prim (Complex.Complex a) ->+  Dict ( Floating (V.SMTExpr Prim a)+       , Complex  (V.SMTExpr Prim (Complex.Complex a))+       , RealPart (V.SMTExpr Prim (Complex.Complex a)) ~ V.SMTExpr Prim a)+witnessComplex (_ :: Prim (Complex.Complex a)) =+  case softwareRep :: SoftwarePrimTypeRep (Complex.Complex a) of+    ComplexFloatST  -> Dict+    ComplexDoubleST -> Dict++witnessFractional :: (SoftwarePrimType a, Fractional a) =>+  Prim a ->+  Dict (Floating (V.SMTExpr Prim a))+witnessFractional (_ :: Prim a) = case softwareRep :: SoftwarePrimTypeRep a of+    FloatST         -> Dict+    DoubleST        -> Dict+    ComplexFloatST  -> Dict+    ComplexDoubleST -> Dict++witnessIntegral :: (SoftwarePrimType a, Integral a) =>+  Prim a ->+  Dict (Integral (V.SMTExpr Prim a), Bits (V.SMTExpr Prim a))+witnessIntegral (_ :: Prim a) = case softwareRep :: SoftwarePrimTypeRep a of+  Int8ST   -> Dict+  Int16ST  -> Dict+  Int32ST  -> Dict+  Int64ST  -> Dict+  Word8ST  -> Dict+  Word16ST -> Dict+  Word32ST -> Dict+  Word64ST -> Dict++witnessBits :: (SoftwarePrimType a, Bits.Bits a) =>+  Prim a ->+  Dict ( Num a+       , Integral (V.SMTExpr Prim a)+       , Bits (V.SMTExpr Prim a))+witnessBits (_ :: Prim a) = case softwareRep :: SoftwarePrimTypeRep a of+  Int8ST   -> Dict+  Int16ST  -> Dict+  Int32ST  -> Dict+  Int64ST  -> Dict+  Word8ST  -> Dict+  Word16ST -> Dict+  Word32ST -> Dict+  Word64ST -> Dict++--------------------------------------------------------------------------------++toRat :: (SoftwarePrimType a, Fractional a) => V.SMTExpr Prim a -> Rat+toRat (x :: V.SMTExpr Prim a) = case softwareRep :: SoftwarePrimTypeRep a of+  FloatST         -> let Float         (Symbolic y) = x in y+  DoubleST        -> let Double        (Symbolic y) = x in y+  ComplexFloatST  -> let ComplexFloat  (Symbolic y) = x in y+  ComplexDoubleST -> let ComplexDouble (Symbolic y) = x in y++fromRat :: forall a. (SoftwarePrimType a, Num a) => Rat -> V.SMTExpr Prim a+fromRat x = case softwareRep :: SoftwarePrimTypeRep a of Int8ST -> Int8 (f2i x)+  where+    f2i :: forall s w. (Sign s, Width w) => Rat -> BV s w+    f2i (Rat x) = BV $ SMT.List [SMT.fam "int2bv" [width (undefined :: w)], SMT.fun "to_int" [x]]++i2n :: forall a b.+  ( V.SMTEval Prim a, SoftwarePrimType a, Integral a+  , V.SMTEval Prim b, SoftwarePrimType b, Num b) =>+  V.SMTExpr Prim a ->+  V.SMTExpr Prim b+i2n x = toBV x $ case softwareRep :: SoftwarePrimTypeRep b of+  Int8ST   -> Int8   . i2i+  Int16ST  -> Int16  . i2i+  Int32ST  -> Int32  . i2i+  Int64ST  -> Int64  . i2i+  Word8ST  -> Word8  . i2i+  Word16ST -> Word16 . i2i+  Word32ST -> Word32 . i2i+  Word64ST -> Word64 . i2i+  FloatST  -> Float  . Symbolic . i2f+  DoubleST -> Double . Symbolic . i2f+  ComplexFloatST  -> ComplexFloat  . Symbolic . i2f+  ComplexDoubleST -> ComplexDouble . Symbolic . i2f+  where+    toBV :: forall a b. (V.SMTEval Prim a, SoftwarePrimType a, Integral a) =>+      V.SMTExpr Prim a -> (forall s w. (Sign s, Width w) => BV s w -> b) -> b+    toBV (x :: V.SMTExpr Prim a) k = case softwareRep :: SoftwarePrimTypeRep a of+      Int8ST   -> let Int8   y = x in k y+      Int16ST  -> let Int16  y = x in k y+      Int32ST  -> let Int32  y = x in k y+      Int64ST  -> let Int64  y = x in k y+      Word8ST  -> let Word8  y = x in k y+      Word16ST -> let Word16 y = x in k y+      Word32ST -> let Word32 y = x in k y+      Word64ST -> let Word64 y = x in k y++    i2f :: (Sign s, Width w) => BV s w -> Rat+    i2f (BV x) = Rat (SMT.fun "to_real" [SMT.fun "bv2int" [x]])++    i2i :: forall s1 w1 s2 w2. (Sign s1, Width w1, Sign s2, Width w2) => BV s1 w1 -> BV s2 w2+    i2i x = case compare m n of+      LT | isSigned x -> V.fromSMT (SMT.signExtend (n-m) (V.toSMT x))+         | otherwise  -> V.fromSMT (SMT.zeroExtend (n-m) (V.toSMT x))+      EQ -> V.fromSMT (V.toSMT x)+      GT -> V.fromSMT (SMT.extract (V.toSMT x) (n-1) 0)+      where+        m = width (undefined :: w1)+        n = width (undefined :: w2)++--------------------------------------------------------------------------------++class SymbParam a => SymbComplex a+  where+    type SymbRealPart a++instance SymbComplex SymbComplexFloat+  where+    type SymbRealPart SymbComplexFloat  = SymbFloat++instance SymbComplex SymbComplexDouble+  where+    type SymbRealPart SymbComplexDouble = SymbDouble++instance SymbComplex a => Complex (Symbolic a)+  where+    type RealPart (Symbolic a) = Symbolic (SymbRealPart a)+    complex x y = symbFun "complex" [symbCast x, symbCast y]+    polar x y   = symbFun "polar" [symbCast x, symbCast y]+    real x      = symbCast (symbFun "real" [x])+    imag x      = symbCast (symbFun "imag" [x])+    magnitude x = symbCast (symbFun "magnitude" [x])+    phase x     = symbCast (symbFun "phase" [x])+    conjugate x = symbFun "conjugate" [x]++--------------------------------------------------------------------------------++declareSymbFun :: SymbParam a => String -> a ->+  [SMT.SExpr] -> SMT.SExpr -> SMT.SMT ()+declareSymbFun name (_ :: a) args res =+  S.void $ SMT.declareFun (symbType (undefined :: a) ++ "-" ++ name) args res++declareSymbArith :: SymbParam a => a -> SMT.SMT ()+declareSymbArith x = do+  declareSymbFun "+" x     [SMT.tReal, SMT.tReal] SMT.tReal+  declareSymbFun "-" x     [SMT.tReal, SMT.tReal] SMT.tReal+  declareSymbFun "*" x     [SMT.tReal, SMT.tReal] SMT.tReal+  declareSymbFun "/" x     [SMT.tReal, SMT.tReal] SMT.tReal+  declareSymbFun "exp" x   [SMT.tReal] SMT.tReal+  declareSymbFun "log" x   [SMT.tReal] SMT.tReal+  declareSymbFun "sqrt" x  [SMT.tReal] SMT.tReal+  declareSymbFun "pow" x   [SMT.tReal, SMT.tReal] SMT.tReal+  declareSymbFun "sin" x   [SMT.tReal] SMT.tReal+  declareSymbFun "cos" x   [SMT.tReal] SMT.tReal+  declareSymbFun "tan" x   [SMT.tReal] SMT.tReal+  declareSymbFun "asin" x  [SMT.tReal] SMT.tReal+  declareSymbFun "acos" x  [SMT.tReal] SMT.tReal+  declareSymbFun "atan" x  [SMT.tReal] SMT.tReal+  declareSymbFun "sinh" x  [SMT.tReal] SMT.tReal+  declareSymbFun "cosh" x  [SMT.tReal] SMT.tReal+  declareSymbFun "tanh" x  [SMT.tReal] SMT.tReal+  declareSymbFun "asinh" x [SMT.tReal] SMT.tReal+  declareSymbFun "acosh" x [SMT.tReal] SMT.tReal+  declareSymbFun "atanh" x [SMT.tReal] SMT.tReal++declareSymbComplex :: SymbParam a => a -> SMT.SMT ()+declareSymbComplex x = do+  declareSymbArith x+  declareSymbFun "complex" x   [SMT.tReal, SMT.tReal] SMT.tReal+  declareSymbFun "polar" x     [SMT.tReal, SMT.tReal] SMT.tReal+  declareSymbFun "real" x      [SMT.tReal] SMT.tReal+  declareSymbFun "imag" x      [SMT.tReal] SMT.tReal+  declareSymbFun "magnitude" x [SMT.tReal] SMT.tReal+  declareSymbFun "phase" x     [SMT.tReal] SMT.tReal+  declareSymbFun "conjugate" x [SMT.tReal] SMT.tReal++declareFeldsparGlobals :: SMT.SMT ()+declareFeldsparGlobals = do+  declareSymbArith   (undefined :: SymbFloat)+  declareSymbArith   (undefined :: SymbDouble)+  declareSymbComplex (undefined :: SymbComplexFloat)+  declareSymbComplex (undefined :: SymbComplexDouble)+  SMT.declareFun "skolem-int8"   [] (SMT.tBits 8)+  SMT.declareFun "skolem-int16"  [] (SMT.tBits 16)+  SMT.declareFun "skolem-int32"  [] (SMT.tBits 32)+  SMT.declareFun "skolem-int64"  [] (SMT.tBits 64)+  SMT.declareFun "skolem-word8"  [] (SMT.tBits 8)+  SMT.declareFun "skolem-word16" [] (SMT.tBits 16)+  SMT.declareFun "skolem-word32" [] (SMT.tBits 32)+  SMT.declareFun "skolem-word64" [] (SMT.tBits 64)+  return ()++instance FO.Substitute Prim+  where+    type SubstPred Prim = SoftwarePrimType+    subst sub (Prim exp) = Prim (everywhereUp f exp)+      where+        f :: ASTF SoftwarePrimDomain a -> ASTF SoftwarePrimDomain a+        f (Sym (FreeVar x :&: ty)) = case FO.lookupSubst sub (Imp.ValComp x) of+          Imp.ValComp y -> Sym (FreeVar y :&: ty)+          Imp.ValRun  z -> Sym (Lit z :&: ty)+        f (Sym (ArrIx iarr :&: ty) :$ i) = Sym (ArrIx iarr' :&: ty) :$ i+          where iarr' = FO.lookupSubst sub iarr+        f x = x++instance FO.TypeablePred SoftwarePrimType+  where+    witnessTypeable Dict = Dict++--------------------------------------------------------------------------------++instance V.SMTEval Prim Bool where+  fromConstant = Bool . SMT.bool+  witnessOrd _ = Dict++instance V.SMTEval Prim Int8 where+  fromConstant = Int8 . fromIntegral+  witnessNum _ = Dict+  witnessOrd _ = Dict+  skolemIndex  = V.fromSMT (SMT.fun "skolem-int8" [])++instance V.SMTEval Prim Int16 where+  fromConstant = Int16 . fromIntegral+  witnessNum _ = Dict+  witnessOrd _ = Dict+  skolemIndex  = V.fromSMT (SMT.fun "skolem-int16" [])++instance V.SMTEval Prim Int32 where+  fromConstant = Int32 . fromIntegral+  witnessNum _ = Dict+  witnessOrd _ = Dict+  skolemIndex  = V.fromSMT (SMT.fun "skolem-int32" [])++instance V.SMTEval Prim Int64 where+  fromConstant = Int64 . fromIntegral+  witnessNum _ = Dict+  witnessOrd _ = Dict+  skolemIndex  = V.fromSMT (SMT.fun "skolem-int64" [])++instance V.SMTEval Prim Word8 where+  fromConstant = Word8 . fromIntegral+  witnessNum _ = Dict+  witnessOrd _ = Dict+  skolemIndex  = V.fromSMT (SMT.fun "skolem-word8" [])++instance V.SMTEval Prim Word16 where+  fromConstant = Word16 . fromIntegral+  witnessNum _ = Dict+  witnessOrd _ = Dict+  skolemIndex  = V.fromSMT (SMT.fun "skolem-word16" [])++instance V.SMTEval Prim Word32 where+  fromConstant = Word32 . fromIntegral+  witnessNum _ = Dict+  witnessOrd _ = Dict+  skolemIndex  = V.fromSMT (SMT.fun "skolem-word32" [])++instance V.SMTEval Prim Word64 where+  fromConstant = Word64 . fromIntegral+  witnessNum _ = Dict+  witnessOrd _ = Dict+  skolemIndex  = V.fromSMT (SMT.fun "skolem-word64" [])++instance V.SMTEval Prim Float where+  fromConstant = Float . fromRational . toRational+  witnessOrd _ = Dict+  witnessNum _ = Dict++instance V.SMTEval Prim Double where+  fromConstant = Double . fromRational . toRational+  witnessOrd _ = Dict+  witnessNum _ = Dict++instance V.SMTEval Prim (Complex.Complex Float) where+  fromConstant = ComplexFloat . fromComplexConstant+  witnessNum _ = Dict++instance V.SMTEval Prim (Complex.Complex Double) where+  fromConstant = ComplexDouble . fromComplexConstant+  witnessNum _ = Dict++--------------------------------------------------------------------------------++instance V.SMTEval1 Prim where+  type Pred Prim = SoftwarePrimType+  newtype SMTExpr Prim Bool   = Bool SMT.SExpr+    deriving (Typeable)+  newtype SMTExpr Prim Float  = Float  (Symbolic SymbFloat)+    deriving (Typeable, Num, Fractional, Floating, V.SMTOrd, V.TypedSExpr)+  newtype SMTExpr Prim Double = Double (Symbolic SymbDouble)+    deriving (Typeable, Num, Fractional, Floating, V.SMTOrd, V.TypedSExpr)+  newtype SMTExpr Prim (Complex.Complex Float) =+      ComplexFloat (Symbolic SymbComplexFloat)+    deriving (Typeable, Num, Fractional, Floating, V.TypedSExpr)+  newtype SMTExpr Prim (Complex.Complex Double) =+      ComplexDouble (Symbolic SymbComplexDouble)+    deriving (Typeable, Num, Fractional, Floating, V.TypedSExpr)+  newtype SMTExpr Prim Int8   = Int8   (BV Signed W8)+    deriving (Typeable, Num, Real, Enum, Integral, Bits, V.SMTOrd, V.TypedSExpr)+  newtype SMTExpr Prim Int16  = Int16  (BV Signed W16)+    deriving (Typeable, Num, Real, Enum, Integral, Bits, V.SMTOrd, V.TypedSExpr)+  newtype SMTExpr Prim Int32  = Int32  (BV Signed W32)+    deriving (Typeable, Num, Real, Enum, Integral, Bits, V.SMTOrd, V.TypedSExpr)+  newtype SMTExpr Prim Int64  = Int64  (BV Signed W64)+    deriving (Typeable, Num, Real, Enum, Integral, Bits, V.SMTOrd, V.TypedSExpr)+  newtype SMTExpr Prim Word8  = Word8  (BV Unsigned W8)+    deriving (Typeable, Num, Real, Enum, Integral, Bits, V.SMTOrd, V.TypedSExpr)+  newtype SMTExpr Prim Word16 = Word16 (BV Unsigned W16)+    deriving (Typeable, Num, Real, Enum, Integral, Bits, V.SMTOrd, V.TypedSExpr)+  newtype SMTExpr Prim Word32 = Word32 (BV Unsigned W32)+    deriving (Typeable, Num, Real, Enum, Integral, Bits, V.SMTOrd, V.TypedSExpr)+  newtype SMTExpr Prim Word64 = Word64 (BV Unsigned W64)+    deriving (Typeable, Num, Real, Enum, Integral, Bits, V.SMTOrd, V.TypedSExpr)++  eval (Prim exp :: Prim a) =+    simpleMatch (\(exp :&: ty) -> case softwarePrimWitType ty of+      Dict -> case V.witnessPred (undefined :: Prim a) of+        Dict -> verifyPrim exp) exp++  witnessPred (_ :: Prim a) = case softwareRep :: SoftwarePrimTypeRep a of+    BoolST   -> Dict+    Int8ST   -> Dict+    Int16ST  -> Dict+    Int32ST  -> Dict+    Int64ST  -> Dict+    Word8ST  -> Dict+    Word16ST -> Dict+    Word32ST -> Dict+    Word64ST -> Dict+    FloatST  -> Dict+    DoubleST -> Dict+    ComplexFloatST  -> Dict+    ComplexDoubleST -> Dict++instance V.SMTOrd (V.SMTExpr Prim Bool) where+  Bool x .<.  Bool y = SMT.not x SMT..&&. y+  Bool x .>.  Bool y = x SMT..&&. SMT.not y+  Bool x .<=. Bool y = SMT.not x SMT..||. y+  Bool x .>=. Bool y = x SMT..||. SMT.not y++instance V.TypedSExpr (V.SMTExpr Prim Bool) where+  smtType _ = SMT.tBool+  toSMT (Bool x) = x+  fromSMT x = Bool x++--------------------------------------------------------------------------------++verifyPrim :: forall a .+  (SoftwarePrimType (DenResult a), V.SMTEval Prim (DenResult a), HasCallStack) =>+  SoftwarePrim a ->+  Args (AST SoftwarePrimDomain) a ->+  V.Verify (V.SMTExpr Prim (DenResult a))+verifyPrim (FreeVar x) _ = peekValue x+verifyPrim (Lit x) _     = return (V.fromConstant x)+verifyPrim Add (x :* y :* Nil)+  | Dict <- V.witnessNum (undefined :: Prim (DenResult a)) =+    S.liftM2 (+) (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim Sub (x :* y :* Nil)+  | Dict <- V.witnessNum (undefined :: Prim (DenResult a)) =+    S.liftM2 (-) (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim Mul (x :* y :* Nil)+  | Dict <- V.witnessNum (undefined :: Prim (DenResult a)) =+    S.liftM2 (*) (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim Neg (x :* Nil)+  | Dict <- V.witnessNum (undefined :: Prim (DenResult a)) =+    fmap negate (V.eval (Prim x))+verifyPrim Abs (x :* Nil)+  | Dict <- V.witnessNum (undefined :: Prim (DenResult a)) =+    fmap abs (V.eval (Prim x))+verifyPrim Sign (x :* Nil)+  | Dict <- V.witnessNum (undefined :: Prim (DenResult a)) =+    fmap signum (V.eval (Prim x))+verifyPrim Div (x :* y :* Nil)+  | Dict <- witnessIntegral (undefined :: Prim (DenResult a)) =+    S.liftM2 div (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim Mod (x :* y :* Nil)+  | Dict <- witnessIntegral (undefined :: Prim (DenResult a)) =+    S.liftM2 mod (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim Quot (x :* y :* Nil)+  | Dict <- witnessIntegral (undefined :: Prim (DenResult a)) =+    S.liftM2 quot (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim Rem (x :* y :* Nil)+  | Dict <- witnessIntegral (undefined :: Prim (DenResult a)) =+    S.liftM2 rem (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim FDiv (x :* y :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    S.liftM2 (/) (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim Pi Nil+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    return pi+verifyPrim Exp (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap exp (V.eval (Prim x))+verifyPrim Log (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap log (V.eval (Prim x))+verifyPrim Sqrt (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap sqrt (V.eval (Prim x))+verifyPrim Pow (x :* y :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    S.liftM2 (**) (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim Sin (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap sin (V.eval (Prim x))+verifyPrim Cos (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap cos (V.eval (Prim x))+verifyPrim Tan (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap tan (V.eval (Prim x))+verifyPrim Asin (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap asin (V.eval (Prim x))+verifyPrim Acos (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap acos (V.eval (Prim x))+verifyPrim Atan (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap atan (V.eval (Prim x))+verifyPrim Sinh (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap sinh (V.eval (Prim x))+verifyPrim Cosh (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap cosh (V.eval (Prim x))+verifyPrim Tanh (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap tanh (V.eval (Prim x))+verifyPrim Asinh (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap asinh (V.eval (Prim x))+verifyPrim Acosh (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap acosh (V.eval (Prim x))+verifyPrim Atanh (x :* Nil)+  | Dict <- witnessFractional (undefined :: Prim (DenResult a)) =+    fmap atanh (V.eval (Prim x))+verifyPrim Complex (x :* y :* Nil)+  | Dict <- witnessComplex (undefined :: Prim (DenResult a)) =+    S.liftM2 complex (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim Polar (x :* y :* Nil)+  | Dict <- witnessComplex (undefined :: Prim (DenResult a)) =+    S.liftM2 polar (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim Real ((x :: ASTF SoftwarePrimDomain b) :* Nil)+  | Dict <- witnessComplex (undefined :: Prim b) =+    fmap real (V.eval (Prim x))+verifyPrim Imag ((x :: ASTF SoftwarePrimDomain b) :* Nil)+  | Dict <- witnessComplex (undefined :: Prim b) =+    fmap imag (V.eval (Prim x))+verifyPrim Magnitude ((x :: ASTF SoftwarePrimDomain b) :* Nil)+  | Dict <- witnessComplex (undefined :: Prim b) =+    fmap magnitude (V.eval (Prim x))+verifyPrim Phase ((x :: ASTF SoftwarePrimDomain b) :* Nil)+  | Dict <- witnessComplex (undefined :: Prim b) =+    fmap phase (V.eval (Prim x))+verifyPrim Conjugate ((x :: ASTF SoftwarePrimDomain b) :* Nil)+  | Dict <- witnessComplex (undefined :: Prim b) =+    fmap conjugate (V.eval (Prim x))+verifyPrim I2N ((x :: ASTF SoftwarePrimDomain b) :* Nil)+  | Dict <- V.witnessPred (undefined :: Prim b),+    Dict <- V.witnessNum (undefined :: Prim b) = do+    fmap i2n (V.eval (Prim x))+verifyPrim I2B ((x :: ASTF SoftwarePrimDomain b) :* Nil)+  | Dict <- V.witnessPred (undefined :: Prim b),+    Dict <- V.witnessNum (undefined :: Prim b) = do+    x <- V.eval (Prim x)+    return (V.fromSMT (SMT.not (x V..==. 0)))+verifyPrim B2I (x :* Nil)+  | Dict <- V.witnessNum (undefined :: Prim (DenResult a)) = do+    x <- V.eval (Prim x)+    return (V.smtIte (V.toSMT x) 1 0)+verifyPrim Round ((x :: ASTF SoftwarePrimDomain b) :* Nil) = do+  x <- V.eval (Prim x)+  return (fromRat (toRat x))+verifyPrim Not (x :* Nil) =+  fmap (V.fromSMT . SMT.not . V.toSMT) (V.eval (Prim x))+verifyPrim And (x :* y :* Nil) = do+  x <- V.eval (Prim x)+  y <- V.eval (Prim y)+  return (V.fromSMT (V.toSMT x SMT..&&. V.toSMT y))+verifyPrim Or (x :* y :* Nil) = do+  x <- V.eval (Prim x)+  y <- V.eval (Prim y)+  return (V.fromSMT (V.toSMT x SMT..||. V.toSMT y))+verifyPrim Eq ((x :: ASTF SoftwarePrimDomain b) :* y :* Nil)+  | Dict <- V.witnessPred (undefined :: Prim b) =+    fmap V.fromSMT (S.liftM2 (V..==.) (V.eval (Prim x)) (V.eval (Prim y)))+verifyPrim Neq ((x :: ASTF SoftwarePrimDomain b) :* y :* Nil)+  | Dict <- V.witnessPred (undefined :: Prim b) =+    fmap V.fromSMT (S.liftM2 (./=.) (V.eval (Prim x)) (V.eval (Prim y)))+  where+    x ./=. y = SMT.not (x V..==. y)+verifyPrim Lt ((x :: ASTF SoftwarePrimDomain b) :* y :* Nil)+  | Dict <- V.witnessPred (undefined :: Prim b),+    Dict <- V.witnessOrd  (undefined :: Prim b) =+    fmap V.fromSMT (S.liftM2 (V..<.) (V.eval (Prim x)) (V.eval (Prim y)))+verifyPrim Gt ((x :: ASTF SoftwarePrimDomain b) :* y :* Nil)+  | Dict <- V.witnessPred (undefined :: Prim b),+    Dict <- V.witnessOrd  (undefined :: Prim b) =+    fmap V.fromSMT (S.liftM2 (V..>.) (V.eval (Prim x)) (V.eval (Prim y)))+verifyPrim Lte ((x :: ASTF SoftwarePrimDomain b) :* y :* Nil)+  | Dict <- V.witnessPred (undefined :: Prim b),+    Dict <- V.witnessOrd  (undefined :: Prim b) =+    fmap V.fromSMT (S.liftM2 (V..<=.) (V.eval (Prim x)) (V.eval (Prim y)))+verifyPrim Gte ((x :: ASTF SoftwarePrimDomain b) :* y :* Nil)+  | Dict <- V.witnessPred (undefined :: Prim b),+    Dict <- V.witnessOrd  (undefined :: Prim b) =+    fmap V.fromSMT (S.liftM2 (V..>=.) (V.eval (Prim x)) (V.eval (Prim y)))+verifyPrim BitAnd (x :* y :* Nil)+  | Dict <- witnessBits (undefined :: Prim (DenResult a)) =+    S.liftM2 (.&.) (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim BitOr (x :* y :* Nil)+  | Dict <- witnessBits (undefined :: Prim (DenResult a)) =+    S.liftM2 (.|.) (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim BitXor (x :* y :* Nil)+  | Dict <- witnessBits (undefined :: Prim (DenResult a)) =+    S.liftM2 xor (V.eval (Prim x)) (V.eval (Prim y))+verifyPrim BitCompl (x :* Nil)+  | Dict <- witnessBits (undefined :: Prim (DenResult a)) =+    fmap complement (V.eval (Prim x))+verifyPrim ShiftL (x :* (y :: ASTF SoftwarePrimDomain b) :* Nil)+  | Dict <- witnessBits (undefined :: Prim (DenResult a)),+    Dict <- V.witnessPred (undefined :: Prim b),+    Dict <- witnessIntegral (undefined :: Prim b) = do+    -- todo: should check for undefined behaviour+    x <- V.eval (Prim x)+    y <- V.eval (Prim y)+    return (shiftL x (i2n y))+verifyPrim ShiftR (x :* (y :: ASTF SoftwarePrimDomain b) :* Nil)+  | Dict <- witnessBits (undefined :: Prim (DenResult a)),+    Dict <- V.witnessPred (undefined :: Prim b),+    Dict <- witnessIntegral (undefined :: Prim b) = do+    -- todo: should check for undefined behaviour+    x <- V.eval (Prim x)+    y <- V.eval (Prim y)+    return (shiftR x (i2n y))+verifyPrim (ArrIx (Imp.IArrComp name :: Imp.IArr Index b)) (i :* Nil) = do+  i <- V.eval (Prim i)+  readArray name i+verifyPrim Cond (cond :* x :* y :* Nil) =+  S.liftM3 V.smtIte+    (fmap V.toSMT (V.eval (Prim cond)))+    (V.eval (Prim x))+    (V.eval (Prim y))+verifyPrim exp _ = error ("Unimplemented: " ++ show exp)++--------------------------------------------------------------------------------
+ src/Feldspar/Storable.hs view
@@ -0,0 +1,100 @@+{-# language TypeFamilies          #-}+{-# language FlexibleInstances     #-}+{-# language MultiParamTypeClasses #-}+{-# language ScopedTypeVariables   #-}++module Feldspar.Storable where++import Feldspar.Frontend+import Data.Struct++import Data.Proxy++--------------------------------------------------------------------------------+-- * Storable.+--------------------------------------------------------------------------------++class Storable m a+  where+    -- | Memory representation+    type StoreRep m a+    -- | Size of memory representation+    type StoreSize m a++    -- | Creat a fresh memory store. It is usually better to use 'newStore'+    --   instead of this function as it improves type inference.+    newStoreRep :: MonadComp m => proxy a -> StoreSize m a -> m (StoreRep m a)++    -- | Store a value to a fresh memory store. It is usually better to use+    --   'initStore' instead of this function as it improves type inference.+    initStoreRep :: MonadComp m => a -> m (StoreRep m a)++    -- | Read from a memory store. It is usually better to use 'readStore'+    --   instead of this function as it improves type inference.+    readStoreRep :: MonadComp m => StoreRep m a -> m a++    -- | Unsafe freezing of a memory store. It is usually better to use+    --   'unsafeFreezeStore' instead of this function as it improves type+    --   inference.+    unsafeFreezeStoreRep :: MonadComp m => StoreRep m a -> m a++    -- | Write to a memory store. It is usually better to use 'writeStore'+    --   instead of this function as it improves type inference.+    writeStoreRep :: MonadComp m => StoreRep m a -> a -> m ()++instance Storable m ()+  where+    type StoreRep m ()  = ()+    type StoreSize m () = ()+    newStoreRep _ _        = return ()+    initStoreRep _         = return ()+    readStoreRep _         = return ()+    unsafeFreezeStoreRep _ = return ()+    writeStoreRep _ _      = return ()++instance forall m a b . (Storable m a, Storable m b) => Storable m (a,b)+  where+    type StoreRep m (a,b) = (StoreRep m a, StoreRep m b)+    type StoreSize m (a,b) = (StoreSize m a, StoreSize m b)+    newStoreRep _ (a,b)          = (,) <$> newStoreRep (Proxy :: Proxy a) a <*> newStoreRep (Proxy :: Proxy b) b+    initStoreRep (a,b)           = (,) <$> initStoreRep a <*> initStoreRep b+    readStoreRep (la,lb)         = (,) <$> readStoreRep la <*> readStoreRep lb+    unsafeFreezeStoreRep (la,lb) = (,) <$> unsafeFreezeStoreRep la <*> unsafeFreezeStoreRep lb+    writeStoreRep (la,lb) (a,b)  = writeStoreRep la a >> writeStoreRep lb b++--------------------------------------------------------------------------------+-- ** User interface.+--------------------------------------------------------------------------------++-- | Memory for storing values.+newtype Store m a = Store { unStore :: StoreRep m a }++-- | Create a fresh 'Store'.+newStore :: forall a m . (MonadComp m, Storable m a)+  => StoreSize m a+  -> m (Store m a)+newStore = fmap Store . newStoreRep (Proxy :: Proxy a)++-- | Store a value to a fresh 'Store'.+initStore :: (MonadComp m, Storable m a) => a -> m (Store m a)+initStore = fmap Store . initStoreRep++-- | Read from a 'Store'.+readStore :: (MonadComp m, Storable m a) => Store m a -> m a+readStore = readStoreRep . unStore++-- | Write to a 'Store'.+writeStore :: (MonadComp m, Storable m a) => Store m a -> a -> m ()+writeStore = writeStoreRep . unStore++-- | Unsafe freezeing of a 'Store'. This operation is only safe if the 'Store'+--   is not updated as long as the returned value is alive.+unsafeFreezeStore :: (MonadComp m, Storable m a) => Store m a -> m a+unsafeFreezeStore = unsafeFreezeStoreRep . unStore++-- | Update a 'Store' in-place, that is, a update that won't produce any+--   temporary variable to store values read from the 'Store'.+inplace :: (MonadComp m, Storable m a) => Store m a -> (a -> a) -> m ()+inplace store f = writeStore store . f =<< unsafeFreezeStore store++--------------------------------------------------------------------------------
+ src/Feldspar/Sugar.hs view
@@ -0,0 +1,112 @@+{-# language GADTs #-}+{-# language MultiParamTypeClasses #-}+{-# language FlexibleInstances #-}+{-# language FlexibleContexts #-}+{-# language TypeOperators #-}+{-# language TypeFamilies #-}+{-# language ScopedTypeVariables #-}+{-# language RankNTypes #-}+-- todo : is this bad? comes from how I use `sup` in the `Syntactic`+--        instance for pairs.+{-# language UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-}++module Feldspar.Sugar where++import Feldspar.Representation+import Data.Struct++import Data.Constraint (Constraint)+import Data.Typeable (Typeable)+import Data.Proxy (Proxy(..))++import qualified Language.Haskell.TH as TH++-- syntactic.+import Language.Syntactic+import Language.Syntactic.TH+import Language.Syntactic.Syntax+import Language.Syntactic.Sugar+import Language.Syntactic.Decoration+import Language.Syntactic.Functional+import Language.Syntactic.Functional.Tuple++--------------------------------------------------------------------------------+-- ** Tuples.+--------------------------------------------------------------------------------++-- | Domains that support tuple expressions.+class Tuples dom+  where+    pair   :: ( Type (Pred dom) a+              , Type (Pred dom) b+              , SyntacticN f (ASTF dom a -> ASTF dom b -> ASTF dom (a, b)))+           => f+    first  :: ( Type (Pred dom) a+              , SyntacticN f (ASTF dom (a, b) -> ASTF dom a))+           => f+    second :: ( Type (Pred dom) b+              , SyntacticN f (ASTF dom (a, b) -> ASTF dom b))+           => f++instance+    ( Syntactic a, Type (Pred (Domain a)) (Internal a)+    , Syntactic b, Type (Pred (Domain b)) (Internal b)+    , Domain a ~ Domain b+    , Tuples (Domain a)+    )+    => Syntactic (a, b)+  where+    type Domain   (a, b) = Domain a+    type Internal (a, b) = (Internal a, Internal b)++    desugar (a, b) = pair (desugar a) (desugar b)+    sugar   ab     = (first ab, second ab)++--------------------------------------------------------------------------------+-- ** Functions.+--------------------------------------------------------------------------------++-- *** todo: replace current fix with comments once DTC bug is fixed.+instance+    ( Syntactic a+    , Syntactic b+--    , Domain a ~ (expr :&: TypeRepF pred (RepresentationOf pred))+--    , Domain b ~ (expr :&: TypeRepF pred (RepresentationOf pred))+    , (Domain a) ~ ((BindingT :+: sym) :&: TypeRepF pred (RepresentationOf pred))+    , (Domain b) ~ ((BindingT :+: sym) :&: TypeRepF pred (RepresentationOf pred))+--    , BindingT :<: expr+    , Type pred (Internal a)+    )+    => Syntactic (a -> b)+  where+    type Domain   (a -> b) = Domain a+    type Internal (a -> b) = Internal a -> Internal b++    desugar f = bepa varSym lamSym (desugar . f . sugar)+--                lamT_template varSym lamSym (desugar . f . sugar)+      where+--        varSym v   = inj (VarT v) :&: ValT typeRep+--        lamSym v b = Sym (inj (LamT v) :&: FunT typeRep (getDecor b)) :$ b+        varSym v   = InjL (VarT v) :&: ValT typeRep+        lamSym v b = Sym (InjL (LamT v) :&: FunT typeRep (getDecor b)) :$ b++    sugar = error "sugar not implemented for (a -> b)"++--------------------------------------------------------------------------------++apa :: (sym ~ ((BindingT :+: sym0) :&: decor)) => AST sym a -> Name+apa (Sym ((InjL (LamT n)) :&: _) :$ _) = n+apa (s :$ a) = apa s `Prelude.max` apa a+apa _ = 0++bepa :: (sym ~ ((BindingT :+: sym0) :&: decor))+  => (Name -> sym (Full a))+  -> (Name -> ASTF sym b -> ASTF sym (a -> b))+  -> (ASTF sym a -> ASTF sym b) -> ASTF sym (a -> b)+bepa mkVar mkLam f = mkLam v body+  where+    body = f $ Sym $ mkVar v+    v    = succ $ apa body++--------------------------------------------------------------------------------
+ src/Feldspar/Verify/Abstract.hs view
@@ -0,0 +1,76 @@+module Feldspar.Verify.Abstract where++import Control.Monad.Trans+import Control.Monad.Exception+import Control.Monad.Writer++import Data.List++import MiniSat hiding (withNewSolver)++--------------------------------------------------------------------------------+-- https://github.com/nick8325/imperative-edsl/blob/master/src/Language/Embedded/Verify/Abstract.hs+--------------------------------------------------------------------------------++-- Given a list of literals, and a function which checks whether a+-- disjunction of literals is provable, return the strongest provable+-- boolean formula made up from those literals (expressed as a set+-- of clauses).+abstract ::+  (Ord a, MonadIO m, MonadAsyncException m) => ([a] -> m Bool) -> [a] -> m [[a]]+abstract provable preds0 =+  fmap (filter (\ls -> length ls <= 3)) $+  execWriterT $+  withNewSolver $ \sat -> do+    let preds = nub preds0+    lits <- mapM (const (liftIO (fmap neg (newLit sat)))) preds+    let+      getClause = do+        vals <- mapM (liftIO . modelValue sat) lits+        return+          [ (pred, lit)+          | (pred, lit, val) <- zip3 preds lits vals, val /= Just False]++      predsOf clause = map fst clause+      litsOf clause  = map snd clause++      abs = do+        res <- liftIO (solve sat [])+        when res $ do+          clause <- getClause >>= maximise+          prv    <- lift (provable (predsOf clause))+          if prv then do+            shrunk <- lift (shrink (provable . predsOf) clause)+            liftIO (addClause sat (map neg (litsOf shrunk)))+            tell [predsOf shrunk]+          else do+            void (liftIO (addClause sat (lits \\ litsOf clause)))+          abs++      maximise ls = fmap (domain \\) (shrink p (domain \\ ls))+        where+          domain = zip preds lits+          p ls = liftIO (solve sat (litsOf (domain \\ ls)))++      shrink _ [] = return []+      shrink provable [l] = do+        res <- provable []+        if res then return [] else return [l]+      shrink provable ls = do+        res <- provable ls2+        if res then shrink provable ls2 else do+          ls1' <- shrink (\ls1' -> provable (ls1' ++ ls2)) ls1+          ls2' <- shrink (\ls2' -> provable (ls1' ++ ls2')) ls2+          return (ls1' ++ ls2')+        where+          (ls1, ls2) = splitAt (length ls `div` 2) ls++    abs++-- A replacement for MiniSat.withNewSolver which works in any MonadIO.+withNewSolver :: (MonadIO m, MonadAsyncException m) => (Solver -> m a) -> m a+withNewSolver h =+  do s <- liftIO newSolver+     h s `finally` liftIO (deleteSolver s)++--------------------------------------------------------------------------------
+ src/Feldspar/Verify/Arithmetic.hs view
@@ -0,0 +1,157 @@+{-# language ScopedTypeVariables #-}++module Feldspar.Verify.Arithmetic where++import Data.Typeable++import Feldspar.Verify.Monad hiding (ite)+import Feldspar.Verify.SMT+import qualified Feldspar.Verify.SMT as SMT++--------------------------------------------------------------------------------+-- Wrapper around simple-SMT types for signed and unsigned arithmetic.+--+-- https://github.com/nick8325/imperative-edsl/blob/master/src/Language/Embedded/Verify/Arithmetic.hs+--------------------------------------------------------------------------------++data W8+data W16+data W32+data W64++class Width w where width :: Num a => w -> a+instance Width W8  where width _ = 8+instance Width W16 where width _ = 16+instance Width W32 where width _ = 32+instance Width W64 where width _ = 64++--------------------------------------------------------------------------------++data Signed+data Unsigned++class Sign s where isSigned :: BV s w -> Bool+instance Sign Signed   where isSigned _ = True+instance Sign Unsigned where isSigned _ = False++--------------------------------------------------------------------------------++newtype BV s w = BV { unBV :: SExpr }+  deriving (Eq, Ord, Typeable, Show)++instance (Sign s, Width w) => Num (BV s w) where+  fromInteger n = BV (bits (width (undefined :: w)) n)+  x + y | x == 0 = y+  x + y | y == 0 = x+  BV x + BV y = BV (bvAdd x y)+  x - y | y == 0 = x+  BV x - BV y = BV (bvSub x y)++  -- Feldspar uses the idiom b * x (where b is a boolean) to mean+  -- b ? x : 0. But the SMT solver doesn't like multiplication.+  -- Here are some transformations which simplify away that idiom.+  BV (List [Atom "ite", b, x, y]) * z = BV (ite b (unBV (BV x * z)) (unBV (BV y * z)))+  x * BV (List [Atom "ite", b, y, z]) = BV (ite b (unBV (x * BV y)) (unBV (x * BV z)))+  x * y | x == 0 || y == 0 = 0+  x * y | x == 1 = y+  x * y | x == 2 = y + y+  x * y | y == 1 = x+  x * y | y == 2 = x + x+  BV x * BV y = error "no Mult for BV"+  negate (BV x) = BV (bvNeg x)+  abs = smtAbs+  signum = smtSignum++instance Enum (BV s w) where+  toEnum   = error "no Enum for BV"+  fromEnum = error "no Enum for BV"++instance (Sign s, Width w) => Real (BV s w) where+  toRational = error "no toRational for BV"++instance (Sign s, Width w) => Integral (BV s w) where+  toInteger = error "no toInteger for BV"+  n0@(BV n) `quotRem` d0@(BV d)+    | d0 == 1 = (n0, 0)+    | d0 == 2 = (shiftR n0 2, n0 .&. 1)+    | otherwise = error "no"++-- A slightly lighter version of Data.Bits.+class Bits a where+  (.&.), (.|.) :: a -> a -> a+  complement :: a -> a+  xor :: a -> a -> a+  shiftL :: a -> a -> a+  shiftR :: a -> a -> a++instance (Sign s, Width w) => Bits (BV s w) where+  BV x .&. BV y = BV (bvAnd x y)+  BV x .|. BV y = BV (bvOr x y)+  complement (BV x) = BV (bvNot x)+  BV x `xor` BV y = BV (bvXOr x y)+  shiftL (BV x) (BV n) = BV (bvShl x n)+  shiftR x0@(BV x) (BV n)+    | isSigned x0 = BV (bvAShr x n)+    | otherwise   = BV (bvLShr x n)++instance (Sign s, Width w) => SMTOrd (BV s w) where+  x .<. y+    | isSigned x = bvSLt (unBV x) (unBV y)+    | otherwise  = bvULt (unBV x) (unBV y)+  x .<=. y+    | isSigned x = bvSLeq (unBV x) (unBV y)+    | otherwise  = bvULeq (unBV x) (unBV y)+  x .>.  y = y .<.  x+  x .>=. y = y .<=. x++instance (Sign s, Width w) => Fresh (BV s w) where+  fresh = freshSExpr++instance (Sign s, Width w) => TypedSExpr (BV s w) where+  smtType _ = tBits (width (undefined :: w))+  toSMT = unBV+  fromSMT = BV++newtype Rat = Rat { unRat :: SExpr }+  deriving (Eq, Ord, Typeable)+instance Show Rat where+  show (Rat x) = show x++instance Fresh Rat where+  fresh = freshSExpr+instance TypedSExpr Rat where+  smtType _ = tReal+  toSMT = unRat+  fromSMT = Rat++instance Num Rat where+  fromInteger = Rat . real . fromInteger+  Rat x + Rat y = Rat (add x y)+  Rat x - Rat y = Rat (sub x y)+  Rat x * Rat y = Rat (mul x y)+  negate (Rat x) = Rat (neg x)+  abs (Rat x) = Rat (SMT.abs x)+  signum = smtSignum++instance Fractional Rat where+  Rat x / Rat y = Rat (realDiv x y)+  fromRational = Rat . real++instance SMTOrd Rat where+  Rat x .<.  Rat y = lt  x y+  Rat x .<=. Rat y = leq x y+  Rat x .>.  Rat y = gt  x y+  Rat x .>=. Rat y = geq x y++smtAbs :: (Num a, SMTOrd a, TypedSExpr a) => a -> a+smtAbs (x :: a) =+  fromSMT (ite (x .<. 0) (toSMT (negate x)) (toSMT x))++smtSignum :: (Num a, SMTOrd a, TypedSExpr a) => a -> a+smtSignum (x :: a) =+  fromSMT $+    ite (x .<. 0) (toSMT (-1 :: a)) $+    ite (x .>. 0) (toSMT  (1 :: a))+    (toSMT (0 :: a))++--------------------------------------------------------------------------------
+ src/Feldspar/Verify/FirstOrder.hs view
@@ -0,0 +1,224 @@+{-# language DataKinds #-}+{-# language GADTs #-}+{-# language TypeFamilies #-}+{-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language DefaultSignatures #-}+{-# language FlexibleInstances #-}+{-# language TypeOperators #-}+{-# language RankNTypes #-}+{-# language FlexibleContexts #-}+{-# language ConstraintKinds #-}++module Feldspar.Verify.FirstOrder where++import Control.Monad.Identity+import Control.Monad.State+import Control.Monad.Trans+import Control.Monad.Operational.Higher++import Data.Constraint+import Data.Maybe (fromMaybe)+import Data.Typeable++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++--------------------------------------------------------------------------------+-- * First-order representation of programs.+--------------------------------------------------------------------------------++-- | First-Order representation of programs, as a sequence of instructions.+data Sequence instr fs a+  where+    Val :: a -> Sequence instr fs a+    Seq :: b                                -- Binder.+        -> instr '(Sequence instr fs, fs) b -- Value.+        -> Sequence instr fs a+        -> Sequence instr fs a+  deriving Typeable++--------------------------------------------------------------------------------++data HO instr fs a+  where+    Skip    :: HO instr fs ()+    Unnamed :: instr fs a -> HO instr fs a+    Named   :: (Ex a, Typeable a) => instr fs a -> HO instr fs a++class Defunctionalise inv instr+  where+    type FO inv instr :: (* -> *, (* -> *, (* -> Constraint, *))) -> * -> *+    type FO inv instr = instr++    defunc :: Fresh m => inv -> instr fs a -> m (FO inv instr fs a)++    default defunc :: (FO inv instr ~ instr, Fresh m) =>+      inv -> instr fs a -> m (FO inv instr fs a)+    defunc _ = return++    refunc :: (Defunctionalise inv jnstr, Sub exp pred, pred Bool) => inv -> Subst ->+      FO inv instr (Param3 (Sequence (FO inv jnstr) (Param2 exp pred)) exp pred) a ->+      HO     instr (Param3 (Program jnstr (Param2 exp pred)) exp pred) a++instance (Defunctionalise inv instr, Defunctionalise inv jnstr) =>+    Defunctionalise inv (instr :+: jnstr)+  where+    type FO inv (instr :+: jnstr) = FO inv instr :+: FO inv jnstr++    defunc inv (Inl instr) = fmap Inl $ defunc inv instr+    defunc inv (Inr jnstr) = fmap Inr $ defunc inv jnstr++    refunc inv sub (Inl instr) = case refunc inv sub instr of+      Named i   -> Named $ Inl i+      Unnamed i -> Unnamed $ Inl i+      Skip      -> Skip++    refunc inv sub (Inr jnstr) = case refunc inv sub jnstr of+      Named j   -> Named $ Inr j+      Unnamed j -> Unnamed $ Inr j+      Skip      -> Skip++--------------------------------------------------------------------------------++defunctionalise ::+  ( HFunctor instr+  , Symbol instr+  , Defunctionalise inv instr+  , HTraversable (FO inv instr)+  ) =>+  inv -> Program instr fs a -> Sequence (FO inv instr) fs a+defunctionalise inv prg = evalState (defunctionaliseM inv prg) (0 :: Integer)++defunctionaliseM ::+  ( Monad m+  , Fresh m+  , HFunctor instr+  , Symbol instr+  , Defunctionalise inv instr+  , HTraversable (FO inv instr)+  ) =>+  inv -> Program instr fs a -> m (Sequence (FO inv instr) fs a)+defunctionaliseM inv prg = case view prg of+  Return val     -> return (Val val)+  (:>>=) instr f -> do+    binder <- dry instr+    instr' <- defunc inv instr+    fonstr <- htraverse (defunctionaliseM inv) instr'+    tail   <- defunctionaliseM inv (f binder)+    return (Seq binder fonstr tail)++--------------------------------------------------------------------------------++refunctionalise :: (Defunctionalise inv instr, Sub exp pred, pred Bool) =>+  inv ->+  Sequence (FO inv instr) (Param2 exp pred) a ->+  Program instr (Param2 exp pred) a+refunctionalise inv = refunctionaliseM inv Map.empty++refunctionaliseM :: (Defunctionalise inv instr, Sub exp pred, pred Bool) =>+  inv ->+  Subst ->+  Sequence (FO inv instr) (Param2 exp pred) a ->+  Program instr (Param2 exp pred) a+refunctionaliseM _   _   (Val val)       = return val+refunctionaliseM inv sub (Seq n fo tail) =+  case refunc inv sub fo of+    Unnamed instr -> do+      singleton instr+      refunctionaliseM inv sub tail+    Named instr -> do+      new <- singleton instr+      refunctionaliseM inv (extendSubst n new sub) tail+    Skip -> do +      refunctionaliseM inv sub tail++--------------------------------------------------------------------------------++class HFunctor instr => HTraversable instr+  where+    htraverse :: Applicative f+      => (forall b . prog1 b -> f (prog2 b))+      ->    instr '(prog1, fs) a+      -> f (instr '(prog2, fs) a)+    htraverse _ i = pure (hfmap (\_ -> error "traverse compound instruction") i)++instance (HTraversable f, HTraversable g) => HTraversable (f :+: g)+  where+    htraverse f (Inl x) = fmap Inl (htraverse f x)+    htraverse f (Inr x) = fmap Inr (htraverse f x)+      +--------------------------------------------------------------------------------++class Monad m => Fresh m+  where+    fresh :: m Integer++    default fresh :: (m ~ t n, MonadTrans t, Fresh n) => m Integer+    fresh = lift fresh++instance Monad m => Fresh (StateT Integer m)+  where+    fresh = do i <- get; put (i + 1); return i++freshStr :: Fresh m => String -> m String+freshStr base = do i <- fresh; return (base ++ show i)++--------------------------------------------------------------------------------++class Symbol instr+  where+    dry :: Fresh m => instr fs a -> m a++instance (Symbol instr, Symbol jnstr) => Symbol (instr :+: jnstr)+  where+    dry (Inl instr) = dry instr+    dry (Inr jnstr) = dry jnstr++--------------------------------------------------------------------------------++class Name a+  where+    name :: a -> String++data E+  where+    E :: (Typeable a, Name a) => a -> E++instance Eq E+  where+    x == y = compare x y == EQ++instance Ord E+  where+    compare (E a) (E b) = compare (name a) (name b) `mappend`+      compare (typeOf a) (typeOf b)++class Ex a+  where+    hide :: Typeable a => a -> E++--------------------------------------------------------------------------------++type Subst = Map E E++class Substitute exp+  where+    type SubstPred exp :: * -> Constraint+    subst :: SubstPred exp a => Subst -> exp a -> exp a++class TypeablePred pred+  where+    witnessTypeable :: Dict (pred a) -> Dict (Typeable a)++type Sub exp pred = (Substitute exp, SubstPred exp ~ pred, TypeablePred pred)++extendSubst :: (Ex a, Typeable a) => a -> a -> Subst -> Subst+extendSubst x y = Map.insert (hide x) (hide y)++lookupSubst :: (Ex a, Typeable a) => Subst -> a -> a+lookupSubst sub x = fromMaybe x $ case Map.lookup (hide x) sub of+  Just (E y) -> cast y+  Nothing    -> Nothing++--------------------------------------------------------------------------------
+ src/Feldspar/Verify/Monad.hs view
@@ -0,0 +1,671 @@+{-# language GADTs #-}+{-# language TypeOperators #-}+{-# language DataKinds #-}+{-# language ScopedTypeVariables #-}+{-# language TypeFamilies #-}+{-# language FlexibleInstances #-}+{-# language FlexibleContexts #-}+{-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language BangPatterns #-}++module Feldspar.Verify.Monad where++import Control.Monad.RWS.Strict+import Control.Monad.Exception+import Control.Monad.Operational.Higher (Program)++import Data.List hiding (break)+import Data.Map (Map)+import qualified Data.Map.Strict as Map+import Data.Ord+import Data.Function+import Data.Typeable+import Data.Constraint (Constraint, Dict(..))+import Data.Maybe+import Data.Array+import Data.ALaCarte++import Feldspar.Verify.SMT hiding (not, ite, stack, concat)+import qualified Feldspar.Verify.SMT as SMT+import qualified Feldspar.Verify.Abstract as Abstract++import GHC.Stack+import Debug.Trace (traceShowM, traceShow)++import Prelude hiding (break)++--------------------------------------------------------------------------------+-- * Verification monad.+--------------------------------------------------------------------------------+-- Based on https://github.com/nick8325/imperative-edsl/blob/master/src/Language/Embedded/Verify.hs+--+-- Our verification algorithm looks a lot like symbolic execution. The+-- difference is that we use an SMT solver to do the symbolic reasoning.+--+-- We model the state of the program as the state of the SMT solver plus a+-- context, which is a map from variable name to SMT value. Symbolically+-- executing a statement modifies this state to become the state after executing+-- the statement. Typically, this modifies the context (when a variable has+-- changed) or adds new axioms to the SMT solver.+--+-- The verification monad allows us to easily manipulate the SMT solver and the+-- context. It also provides three other features:+--+-- First, it supports branching on the value of a formula, executing one branch+-- if the formula is true and the other if the formula is false. The monad takes+-- care of merging the contexts from the two branches afterwards, as well as+-- making sure that any axiom we add inside a branch is only assumed+-- conditionally.+--+-- Second, it supports break statements in a rudimentary way. We can record when+-- we reach a break statement, and ask the monad for a symbolic expression that+-- tells us whether a given statement breaks. However, skipping past statements+-- after a break is the responsibility of the user of the monad.+--+-- Finally, we can emit warnings during verification, for example when we detect+-- a read of an uninitialised reference.+--+--------------------------------------------------------------------------------++-- | The Verify monad itself is a reader/writer/state monad with the following+-- components:+--+-- Read:  list of formulas which are true in the current branch;+--        "chattiness level" (if > 0 then tracing messages are printed);+--        whether to try to prove anything or just evaluate the program.+--+-- Write: disjunction which is true if the program has called break;+--        list of warnings generated;+--        list of hints given;+--        list of names generated (must not appear in hints).+--+-- State: the context, a map from variables to SMT values.+--+type Verify = RWST ([SExpr], Int, Mode) ([SExpr], Warns, [HintBody], [String]) Context SMT++-- | The verification monad can prove (with and without warnings) or simply+-- execute a computation.+data Mode = Prove | ProveAndWarn | Execute deriving Eq++-- | Warnings are either local warnings for a branch or global.+data Warns = Warns {+    warns_here :: [String]+  , warns_all  :: [String] }++instance Semigroup Warns+  where+    (<>) = mappend++instance Monoid Warns+  where+    mempty = Warns [] []+    w1 `mappend` w2 = Warns+      (warns_here w1 `mappend` warns_here w2)+      (warns_all w1 `mappend` warns_all w2)++--------------------------------------------------------------------------------++-- | Run and prove a computation and record all warnings.+runVerify :: Verify a -> IO (a, [String])+runVerify m = runZ3 [] $ do+  SMT.setOption ":produce-models" "false"+  (x, (_, warns, _, _)) <- evalRWST m ([], 0, ProveAndWarn) Map.empty+  return (x, warns_all warns)++-- | Run a computation without proving anything.+quickly :: Verify a -> Verify a+quickly = local (\(branch, chat, _) -> (branch, chat, Execute))++-- | Only run a computation if we are supposed to be proving.+proving :: a -> Verify a -> Verify a+proving def mx = do+  (_, _, mode) <- ask+  case mode of+    Prove        -> mx+    ProveAndWarn -> mx+    Execute      -> return def++-- | Only run a computation if we are supposed to be warning.+warning :: a -> Verify a -> Verify a+warning x mx = do+  (_, _, mode) <- ask+  if (mode == ProveAndWarn) then mx else return x++--------------------------------------------------------------------------------++-- | Assume that a given formula is true.+assume :: String -> SExpr -> Verify ()+assume msg p = proving () $ do+  branch <- branch+  trace msg "Asserted" p+  lift (assert (disj (p:map SMT.not branch)))++-- | Check if a given formula holds.+provable :: String -> SExpr -> Verify Bool+provable msg p = proving False $ do+  branch <- branch+  stack $ do+    res <- lift $ do+      mapM_ assert branch+      assert (SMT.not p)+      check+    chat $+      case res of+        Sat -> stack $ do+          trace msg "Failed to prove" p+          lift $ setOption ":produce-models" "true"+          lift $ check+          context <- get+          model   <- showModel context+          liftIO $ putStrLn (" (countermodel is " ++ model ++ ")")+        Unsat   -> trace msg "Proved" p+        Unknown -> trace msg "Couldn't solve" p+    return (res == Unsat)++-- | Run a computation but undo its effects afterwards.+stack :: Verify a -> Verify a+stack mx = do+  state <- get+  read  <- ask+  fmap fst $ lift $ SMT.stack $ evalRWST mx read state++-- | Branch on the value of a formula.+ite :: SExpr -> Verify a -> Verify b -> Verify (a, b)+ite p mx my = do+  ctx  <- get+  read <- ask+  let+    withBranch p+      | p == bool True  = local id+      | p == bool False = local (\(_,  x, y) -> ([p],  x, y))+      | otherwise       = local (\(xs, x, y) -> (p:xs, x, y))+  (x, ctx1, (break1, warns1, hints1, decls1)) <-+    lift $ runRWST (withBranch p mx) read ctx+  (y, ctx2, (break2, warns2, hints2, decls2)) <-+    lift $ runRWST (withBranch (SMT.not p) my) read ctx+  mergeContext p ctx1 ctx2 >>= put+  let+    break+      | null break1 && null break2 = []+      | otherwise = [SMT.ite p (disj break1) (disj break2)]+  tell (break, warns1 `mappend` warns2, hints1 ++ hints2, decls1 ++ decls2)+  return (x, y)++--------------------------------------------------------------------------------++-- | Read the current branch.+branch :: Verify [SExpr]+branch = asks (\(branch, _, _) -> branch)++-- | Read the context.+peek :: forall a. (Typeable a, Ord a, Mergeable a, Show a, ShowModel a, Invariant a, Exprs a, HasCallStack) => String -> Verify a+peek name = do+  ctx <- get+  return (lookupContext name ctx)++-- | Write to the context.+poke :: (Typeable a, Ord a, Mergeable a, Show a, ShowModel a, Invariant a, Exprs a) => String -> a -> Verify ()+poke name val = modify (insertContext name val)++-- | Record that execution has broken here.+break :: Verify ()+break = do+  branch <- branch+  tell ([conj branch], mempty, [], [])++-- | Check if execution of a statement can break.+withBreaks :: Verify a -> Verify (a, SExpr)+withBreaks mx = do+  (x, (exits, _, _, _)) <- listen mx+  return (x, disj exits)++-- | Check if execution of a statement can break, discarding the statement's+--   result.+breaks :: Verify a -> Verify SExpr+breaks mx = fmap snd (withBreaks mx)++-- | Prevent a statement from breaking.+noBreak :: Verify a -> Verify a+noBreak = censor (\(_, warns, hints, decls) -> ([], warns, hints, decls))++-- | Add a warning to the output.+warn :: String -> Verify ()+warn msg = warning () $ tell ([], Warns [msg] [msg], [], [])++-- | Add a hint to the output.+hint :: TypedSExpr a => a -> Verify ()+hint exp = do+  smt <- lift $ simplify (toSMT exp)+  tell ([], mempty, [HintBody smt (smtType exp)], [])++-- | Add a hint for a `SExpr` to the output.+hintFormula :: SExpr -> Verify ()+hintFormula exp = do+  smt <- lift $ simplify exp+  tell ([], mempty, [HintBody smt tBool],[])++-- | Run a computation but ignoring its warnings.+noWarn :: Verify a -> Verify a+noWarn = local (\(x, y, mode) -> (x, y, f mode))+  where+    f ProveAndWarn = Prove+    f x = x++-- | Run a computation but ignoring its local warnings.+swallowWarns :: Verify a -> Verify a+swallowWarns = censor (\(x, ws, y, z) -> (x, ws { warns_here = [] }, y, z))++-- | Run a computation and get its warnings.+getWarns :: Verify a -> Verify (a, [String])+getWarns mx = do+  (x, (_, warns, _, _)) <- listen mx+  return (x, warns_here warns)++--------------------------------------------------------------------------------+-- ** The API for verifying programs.+--------------------------------------------------------------------------------++-- | A typeclass for things which can be symbolically executed.+class Verifiable prog+  where+    -- Returns the transformed program (in which e.g. proved assertions+    -- may have been removed), together with the result.+    verifyWithResult :: prog a -> Verify (prog a, a)++-- | Symbolically execute a program, ignoring the result.+verify :: Verifiable prog => prog a -> Verify (prog a)+verify = fmap fst . verifyWithResult++--------------------------------------------------------------------------------++-- | A typeclass for instructions which can be symbolically executed.+class VerifyInstr instr exp pred+  where+    verifyInstr :: Verifiable prog => instr '(prog, Param2 exp pred) a -> a ->+      Verify (instr '(prog, Param2 exp pred) a)+    verifyInstr instr _ = return instr++instance (VerifyInstr f exp pred, VerifyInstr g exp pred) => VerifyInstr (f :+: g) exp pred+  where+    verifyInstr (Inl m) x = fmap Inl (verifyInstr m x)+    verifyInstr (Inr m) x = fmap Inr (verifyInstr m x)++--------------------------------------------------------------------------------+-- ** Expressions and invariants.+--------------------------------------------------------------------------------++-- | A typeclass for expressions which can be evaluated under a context.+class Typeable exp => SMTEval1 exp+  where+    -- The result type of evaluating the expression.+    data SMTExpr exp a+    -- A predicate which must be true of the expression type.+    type Pred exp :: * -> Constraint+    -- Evaluate an expression to its SMT expression.+    eval :: HasCallStack => exp a -> Verify (SMTExpr exp a)+    -- Witness the fact that (SMTEval1 exp, Pred exp a) => SMTEval exp a.+    witnessPred :: Pred exp a => exp a -> Dict (SMTEval exp a)++--------------------------------------------------------------------------------++-- | A typeclass for expressions of a particular type.+class (SMTEval1 exp, TypedSExpr (SMTExpr exp a), Typeable a) => SMTEval exp a+  where+    -- Lift a typed constant into a SMT expression.+    fromConstant :: a -> SMTExpr exp a+    -- Witness the numerical type of an expression.+    witnessNum :: Num a => exp a -> Dict (Num (SMTExpr exp a))+    witnessNum = error "witnessNum"+    -- Witness the ordered type of an expression.+    witnessOrd :: Ord a => exp a -> Dict (SMTOrd (SMTExpr exp a))+    witnessOrd = error "witnessOrd"+    -- Produce an index for a type.+    skolemIndex :: Ix a => SMTExpr exp a+    skolemIndex = error "skolemIndex"++--------------------------------------------------------------------------------++-- | A typeclass for values with a representation as an SMT expression. +class Fresh a => TypedSExpr a+  where+    smtType :: a -> SExpr+    toSMT   :: a -> SExpr+    fromSMT :: SExpr -> a++-- | Spawn a new expression, the string is a hint for making a pretty name.+freshSExpr :: forall a. TypedSExpr a => String -> Verify a+freshSExpr name = fmap fromSMT (freshVar name (smtType (undefined :: a)))++--------------------------------------------------------------------------------++-- | A typeclass for values that support uninitialised creation.+class Fresh a+  where+    -- Create an uninitialised value. The String argument is a hint for making+    -- pretty names.+    fresh :: String -> Verify a++-- | Create a fresh variable and initialize it.+freshVar :: String -> SExpr -> Verify SExpr+freshVar name ty = do+  n <- lift freshNum+  let x = name ++ "." ++ show n+  tell ([], mempty, [], [x])+  lift $ declare x ty++--------------------------------------------------------------------------------++-- | A typeclass for values that can undergo predicate abstraction.+class (IsLiteral (Literal a), Fresh a) => Invariant a+  where+    data Literal a++    -- Forget the value of a binding.+    havoc :: String -> a -> Verify a+    havoc name _ = fresh name++    -- Return a list of candidate literals for a value.+    literals :: String -> a -> [Literal a]+    literals _ _ = []++    warns1, warns2 :: Context -> String -> a -> a+    warns1 _ _ x = x+    warns2 _ _ x = x++    warnLiterals :: String -> a -> [(Literal a, SExpr)]+    warnLiterals _ _ = []++    warnLiterals2 :: String -> a -> [Literal a]+    warnLiterals2 _ _ = []++--------------------------------------------------------------------------------++class (Ord a, Typeable a, Show a) => IsLiteral a+  where+    -- Evaluate a literal. The two context arguments are the old and new+    -- contexts (on entry to the loop and now).+  smtLit :: Context -> Context -> a -> SExpr+  smtLit = error "smtLit not defined"++  -- What phase is the literal in? Literals from different phases cannot be+  -- combined in one clause.+  phase :: a -> Int+  phase _ = 0++--------------------------------------------------------------------------------++data HintBody = HintBody {+    hb_exp  :: SExpr+  , hb_type :: SExpr }+  deriving (Eq, Ord)++instance Show HintBody+  where+    show = showSExpr . hb_exp++data Hint = Hint {+    hint_ctx  :: Context+  , hint_body :: HintBody }+  deriving (Eq, Ord)++instance Show Hint+  where+    show = show . hint_body++instance IsLiteral Hint+  where+    smtLit _ ctx hint = subst (hb_exp (hint_body hint))+      where+        subst x | Just y <- lookup x sub = y+        subst (Atom xs) = Atom xs+        subst (List xs) = List (map subst xs)++        sub = equalise (hint_ctx hint) ctx++        equalise ctx1 ctx2 = zip (exprs (fmap fst m)) (exprs (fmap snd m))+          where+            m = Map.intersectionWith (,) ctx1 ctx2++--------------------------------------------------------------------------------++-- | A typeclass for values that contain SMT expressions.+class Exprs a+  where+    -- List SMT expressions contained inside a value.+    exprs :: a -> [SExpr]++instance Exprs SExpr+  where+    exprs x = [x]++instance Exprs Entry+  where+    exprs (Entry x) = exprs x++instance Exprs Context+  where+    exprs = concatMap exprs . Map.elems++----------------------------------------------------------------------+-- ** The context.+----------------------------------------------------------------------++data Name  = forall a. Typeable a => Name String a++instance Eq Name+  where+    x == y = compare x y == EQ++instance Ord Name+  where+    compare = comparing (\(Name name x) -> (name, typeOf x))++instance Show Name+  where+    show (Name name x) = name++data Entry = forall a .+  ( Ord a+  , Show a+  , Typeable a+  , Mergeable a+  , ShowModel a+  , Invariant a+  , Exprs a+  ) =>+  Entry a++instance Eq Entry+  where+    Entry x == Entry y = typeOf x == typeOf y && cast x == Just y++instance Ord Entry+  where+    compare (Entry x) (Entry y) =+      compare (typeOf x) (typeOf y) `mappend` compare (Just x) (cast y)+    +instance Show Entry+  where+    showsPrec n (Entry x) = showsPrec n x++type Context = Map Name Entry++-- | Look up a value in the context.+lookupContext :: forall a . (Typeable a, HasCallStack) => String -> Context -> a+lookupContext name ctx =+  case maybeLookupContext name ctx of+    Nothing -> error $ "variable " ++ name ++ " not found in context" +++      "\nctx:" ++ unlines (map (show) (Map.toList ctx)) +++      "\ntype: " ++ show (typeOf (undefined :: a))+    Just x -> x++-- | ...+maybeLookupContext :: forall a . Typeable a => String -> Context -> Maybe a+maybeLookupContext name ctx = do+  Entry x <- Map.lookup (Name name (undefined :: a)) ctx+  case cast x of+    Nothing -> error "type mismatch in lookup"+    Just x  -> return x++-- | Add a value to the context or modify an existing binding.+insertContext :: forall a . (Typeable a, Ord a, Mergeable a, Show a, ShowModel a, Invariant a, Exprs a) => String -> a -> Context -> Context+insertContext name !x ctx = Map.insert (Name name (undefined :: a)) (Entry x) ctx++-- | Modified ctx1 ctx2 returns a subset of ctx2 that contains only the values+--   that have been changed from ctx1.+modified :: Context -> Context -> Context+modified ctx1 ctx2 =+    Map.mergeWithKey f (const Map.empty) (const Map.empty) ctx1 ctx2+  where+    f _ x y+      | x == y    = Nothing+      | otherwise = Just y++--------------------------------------------------------------------------------++-- | A typeclass for values that support if-then-else.+class Mergeable a+  where+    merge :: SExpr -> a -> a -> a++mergeContext :: SExpr -> Context -> Context -> Verify Context+mergeContext cond ctx1 ctx2 =+  -- If a variable is bound conditionally, put it in the result+  -- context, but only define it conditionally.+  sequence $ Map.mergeWithKey+    (const combine)+    (fmap (definedWhen cond))+    (fmap (definedWhen (SMT.not cond)))+    ctx1+    ctx2+  where+    combine :: Entry -> Entry -> Maybe (Verify Entry)+    combine x y = Just (return (merge cond x y))++    definedWhen :: SExpr -> Entry -> Verify Entry+    definedWhen cond (Entry x) = do+      y <- fresh "unbound"+      return (Entry (merge cond x y))++instance Mergeable Entry+  where+    merge cond (Entry x) (Entry y) = case cast y of+      Just y  -> Entry (merge cond x y)+      Nothing -> error "incompatible types in merge"++instance Mergeable SExpr+  where+    merge cond t e+      | t == e = t+      | cond == bool True  = t+      | cond == bool False = e+      | otherwise = SMT.ite cond t e++--------------------------------------------------------------------------------++-- | A typeclass for values that can be shown given a model from the SMT solver.+class ShowModel a+  where+    showModel :: a -> Verify String++instance ShowModel Context+  where+    showModel ctx = do+      let (keys, values) = unzip (Map.toList ctx)+      values' <- mapM showModel values+      return $ intercalate ", "+             $ zipWith (\(Name k _) v -> k ++ " = " ++ v)+                 keys+                 values'++instance ShowModel Entry+  where+    showModel (Entry x) = showModel x++instance ShowModel SExpr+  where+    showModel x = lift (getExpr x) >>= return . showValue++--------------------------------------------------------------------------------+-- *** A replacement for the SMTOrd class.+--------------------------------------------------------------------------------++class SMTOrd a+  where+    (.<.)  :: a -> a -> SExpr+    (.<=.) :: a -> a -> SExpr+    (.>.)  :: a -> a -> SExpr+    (.>=.) :: a -> a -> SExpr++instance SMTEval exp a => Eq (SMTExpr exp a)+  where+    x == y = toSMT x == toSMT y++instance SMTEval exp a => Ord (SMTExpr exp a)+  where+    compare = comparing toSMT++instance SMTEval exp a => Show (SMTExpr exp a)+  where+    showsPrec n x = showsPrec n (toSMT x)++instance SMTEval exp a => Mergeable (SMTExpr exp a)+  where+    merge cond x y = fromSMT (merge cond (toSMT x) (toSMT y))++instance SMTEval exp a => ShowModel (SMTExpr exp a)+  where+    showModel x = showModel (toSMT x)++instance SMTEval exp a => Fresh (SMTExpr exp a)+  where+    fresh name = fmap fromSMT (freshVar name (smtType (undefined :: SMTExpr exp a)))++(.==.) :: TypedSExpr a => a -> a -> SExpr+x .==. y = toSMT x `eq` toSMT y++smtIte :: TypedSExpr a => SExpr -> a -> a -> a+smtIte cond x y = fromSMT (SMT.ite cond (toSMT x) (toSMT y))++--------------------------------------------------------------------------------++-- | Run a computation more chattily.+chattily :: Verify a -> Verify a+chattily = local (\(ctx, n, prove) -> (ctx, n+1, prove))++-- | Run a computation more quietly.+quietly :: Verify a -> Verify a+quietly = local (\(ctx, n, prove) -> (ctx, n-1, prove))++-- | Produce debug output.+chat :: Verify () -> Verify ()+chat mx = do+  (_, chatty, _) <- ask+  when (chatty > 0) mx++-- | Print a formula for debugging purposes.+trace :: String -> String -> SExpr -> Verify ()+trace msg kind p = chat $ do+  branch <- branch >>= mapM (lift . simplify)+  p <- lift $ simplify p+  liftIO $ do+    putStr (kind ++ " " ++ showSExpr p ++ " (" ++ msg ++ ")")+    case branch of+      []  -> putStrLn ""+      [x] -> putStrLn (" assuming " ++ showSExpr x)+      _   -> do+        putStrLn " assuming:"+        sequence_ [ putStrLn ("  " ++ showSExpr x) | x <- branch ]++-- | Print the context for debugging purposes.+printContext :: String -> Verify ()+printContext msg = do+  ctx <- get+  liftIO $ do+    putStrLn (msg ++ ":")+    forM_ (Map.toList ctx) $ \(name, val) -> putStrLn (" " ++ show name ++ " -> " ++ show val)+    putStrLn ""++--------------------------------------------------------------------------------
+ src/Feldspar/Verify/SMT.hs view
@@ -0,0 +1,146 @@+module Feldspar.Verify.SMT+  ( module Feldspar.Verify.SMT+  , module SimpleSMT+  )+  where++import Data.List++import Control.Monad.State.Strict+import Control.Applicative++import SimpleSMT(+    SExpr(..), Result(..), Value(..)+  , bool, int, real, fun, fam, ite+  , tBool, tInt, tReal, tArray, tBits+  , select, store, concat, extract+  , bvULt, bvULeq, bvSLt, bvSLeq, bvNeg, bvAdd, bvSub, bvMul, bvUDiv+  , bvURem, bvSDiv, bvSRem, bvAnd, bvOr, bvNot, bvXOr, bvShl, bvAShr, bvLShr+  , signExtend, zeroExtend, realDiv+  , add, sub, mul, neg, abs, lt, leq, gt, geq, implies)+--  , newLogger)+import qualified SimpleSMT as SMT++--------------------------------------------------------------------------------+-- * Simple SMT front-end.+--------------------------------------------------------------------------------++type SMT = StateT SMTState IO++data SMTState = SMTState {+    st_solver :: SMT.Solver+  , st_next   :: Integer }++runZ3 :: [String] -> SMT a -> IO a+runZ3 args m = do+  --logger <- fmap Just (SMT.newLogger 0)+  let logger = Nothing+  solver <- SMT.newSolver "z3" (["-smt2", "-in", "-t:10000"] ++ args) logger+  --solver <- SMT.newSolver "cvc4" (["--lang=smt", "--force-logic=ALL", "--incremental","-"] ++ args) logger+  evalStateT m (SMTState solver 0)++freshNum :: SMT Integer+freshNum = do+  st <- get+  put st { st_next = st_next st + 1 }+  return (st_next st)++withSolver :: (SMT.Solver -> SMT a) -> SMT a+withSolver k = do+  st <- get+  k (st_solver st)++stack :: SMT a -> SMT a+stack m = withSolver $ \solver ->+  lift (SMT.push solver) *> m <* lift (SMT.pop solver)++not :: SExpr -> SExpr+not p+  | p == bool True  = bool False+  | p == bool False = bool True+  | otherwise = SMT.not p++conj :: [SExpr] -> SExpr+conj xs | bool False `elem` xs = bool False+conj [] = bool True+conj [x] = x+conj xs = fun "and" xs++disj :: [SExpr] -> SExpr+disj xs | bool True `elem` xs = bool True+disj [] = bool False+disj [x] = x+disj xs = fun "or" xs++(.||.), (.&&.) :: SExpr -> SExpr -> SExpr+x .||. y = disj [x, y]+x .&&. y = conj [x, y]++eq :: SExpr -> SExpr -> SExpr+eq x y+  | x == y = bool True+  | otherwise = SMT.eq x y++setOption :: String -> String -> SMT ()+setOption opt val = withSolver $ \solver -> lift (SMT.setOption solver opt val)++getExpr :: SExpr -> SMT Value+getExpr exp = withSolver $ \solver -> lift (SMT.getExpr solver exp)++assert :: SExpr -> SMT ()+assert expr = withSolver $ \solver -> lift (SMT.assert solver expr)++simplify :: SExpr -> SMT SExpr+simplify expr = withSolver $ \solver -> lift (SMT.command solver (fun "simplify" [expr]))++assertSimp :: SExpr -> SMT ()+assertSimp expr = simplify expr >>= assert++check :: SMT Result+check = withSolver $ \solver -> lift (SMT.check solver)++declare :: String -> SExpr -> SMT SExpr+declare name ty = withSolver $ \solver -> lift (SMT.declare solver name ty)++declareFun :: String -> [SExpr] -> SExpr -> SMT SExpr+declareFun name args res = withSolver $ \solver -> lift (SMT.declareFun solver name args res)++declareSort :: String -> SMT ()+declareSort name = withSolver $ \solver -> lift (SMT.simpleCommand solver ["declare-sort", name])++--------------------------------------------------------------------------------+-- ** Show SMT expressions.+--------------------------------------------------------------------------------++showSExpr :: SExpr -> String+showSExpr exp = SMT.showsSExpr exp ""++showValue :: Value -> String+showValue (Bool x)   = show x+showValue (Int x)    = show x+showValue (Real x)   = show x+showValue (Bits _ x) = show x+showValue (Other x)  = showSExpr x++showArray :: Value -> SExpr -> SMT String+showArray n arr = do+    vals <- sequence [ getExpr (select arr i) | i <- take cutoff (indexes n) ]+    if length (take (cutoff+1) (indexes n)) <= cutoff+    then+      return ("{" ++ intercalate ", " (map showValue vals) ++ "}")+    else+      return ("{" ++ intercalate ", " (map showValue vals) ++ ", ...}")+  where+    cutoff :: Int+    cutoff = 20++    indexes :: Value -> [SExpr]+    indexes (Int n)    = map int [0..n-1]+    indexes (Bits w n) = map (bits w) [0..n-1]++bits :: Int -> Integer -> SExpr+bits w n = List [Atom "_", Atom ("bv" ++ show m), int (fromIntegral w)]+  where+    m = n `mod` (2^w)++--------------------------------------------------------------------------------