diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for co-feldspar + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/co-feldspar.cabal b/co-feldspar.cabal new file mode 100644 --- /dev/null +++ b/co-feldspar.cabal @@ -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 diff --git a/src/Data/Selection.hs b/src/Data/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Selection.hs @@ -0,0 +1,66 @@ +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 + +-------------------------------------------------------------------------------- diff --git a/src/Data/Struct.hs b/src/Data/Struct.hs new file mode 100644 --- /dev/null +++ b/src/Data/Struct.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar.hs b/src/Feldspar.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar.hs @@ -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) diff --git a/src/Feldspar/Array/Buffered.hs b/src/Feldspar/Array/Buffered.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Array/Buffered.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Array/Queue.hs b/src/Feldspar/Array/Queue.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Array/Queue.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Array/Vector.hs b/src/Feldspar/Array/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Array/Vector.hs @@ -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 +-- +-- +-- The general idea of pull and push vectors is described in +-- "Combining deep and shallow embedding of domain-specific languages" +-- . +-- +-- Push arrays were originally introduced in +-- "Expressive array constructs in an embedded GPU kernel programming language" +-- . +-- +-------------------------------------------------------------------------------- + +-- | 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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Frontend.hs b/src/Feldspar/Frontend.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Frontend.hs @@ -0,0 +1,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 () + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Hardware.hs b/src/Feldspar/Hardware.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Hardware.hs @@ -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) diff --git a/src/Feldspar/Hardware/Compile.hs b/src/Feldspar/Hardware/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Hardware/Compile.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Hardware/Expression.hs b/src/Feldspar/Hardware/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Hardware/Expression.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Hardware/Frontend.hs b/src/Feldspar/Hardware/Frontend.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Hardware/Frontend.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Hardware/Optimize.hs b/src/Feldspar/Hardware/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Hardware/Optimize.hs @@ -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 + + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Hardware/Primitive.hs b/src/Feldspar/Hardware/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Hardware/Primitive.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Hardware/Primitive/Backend.hs b/src/Feldspar/Hardware/Primitive/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Hardware/Primitive/Backend.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Hardware/Representation.hs b/src/Feldspar/Hardware/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Hardware/Representation.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Representation.hs b/src/Feldspar/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Representation.hs @@ -0,0 +1,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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Software.hs b/src/Feldspar/Software.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software.hs @@ -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 diff --git a/src/Feldspar/Software/Compile.hs b/src/Feldspar/Software/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software/Compile.hs @@ -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 "" + C.addInclude "" + C.addInclude "" + C.addInclude "" + C.addInclude "" + C.addInclude "" + 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) + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Software/Expression.hs b/src/Feldspar/Software/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software/Expression.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Software/Frontend.hs b/src/Feldspar/Software/Frontend.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software/Frontend.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Software/Marshal.hs b/src/Feldspar/Software/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software/Marshal.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Software/Optimize.hs b/src/Feldspar/Software/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software/Optimize.hs @@ -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 + + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Software/Primitive.hs b/src/Feldspar/Software/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software/Primitive.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Software/Primitive/Backend.hs b/src/Feldspar/Software/Primitive/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software/Primitive/Backend.hs @@ -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 "" >> return [cty| typename bool |] + Int8ST -> addInclude "" >> return [cty| typename int8_t |] + Int16ST -> addInclude "" >> return [cty| typename int16_t |] + Int32ST -> addInclude "" >> return [cty| typename int32_t |] + Int64ST -> addInclude "" >> return [cty| typename int64_t |] + Word8ST -> addInclude "" >> return [cty| typename uint8_t |] + Word16ST -> addInclude "" >> return [cty| typename uint16_t |] + Word32ST -> addInclude "" >> return [cty| typename uint32_t |] + Word64ST -> addInclude "" >> return [cty| typename uint64_t |] + FloatST -> return [cty| float |] + DoubleST -> return [cty| double |] + ComplexFloatST -> + addInclude "" >> return [cty| float _Complex |] + ComplexDoubleST -> + addInclude "" >> return [cty| double _Complex |] + + compLit _ a = case softwarePrimTypeOf a of + BoolST -> + do addInclude "" + 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 "" >> compFun "abs" (a :* Nil) + | wordType t = compPrim $ Prim a + | otherwise = addInclude "" >> 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 "" + addGlobal complexSignf_def + a' <- compPrim $ Prim a + return [cexp| feld_complexSignf($a') |] +compSign ComplexDoubleST a = do + addInclude "" + 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 "" + p <- compFun "lround" (a :* Nil) + compCastExp t p +compRound t a | floatingType t || complexType t = do + addInclude "" + 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 "" >> compFun "exp" args + go _ Log args = addInclude "" >> compFun "log" args + go _ Sqrt args = addInclude "" >> compFun "sqrt" args + go _ Pow args = addInclude "" >> compFun "pow" args + + go _ Sin args = addInclude "" >> compFun "sin" args + go _ Cos args = addInclude "" >> compFun "cos" args + go _ Tan args = addInclude "" >> compFun "tan" args + go _ Asin args = addInclude "" >> compFun "asin" args + go _ Acos args = addInclude "" >> compFun "acos" args + go _ Atan args = addInclude "" >> compFun "atan" args + go _ Sinh args = addInclude "" >> compFun "sinh" args + go _ Cosh args = addInclude "" >> compFun "cosh" args + go _ Tanh args = addInclude "" >> compFun "tanh" args + go _ Asinh args = addInclude "" >> compFun "asinh" args + go _ Acosh args = addInclude "" >> compFun "acosh" args + go _ Atanh args = addInclude "" >> compFun "atanh" args + + go 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 "" + 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 "" >> compFun "creal" args + go _ Imag args = addInclude "" >> compFun "cimag" args + go _ Magnitude args = addInclude "" >> compFun "cabs" args + go _ Phase args = addInclude "" >> compFun "carg" args + go _ Conjugate args = addInclude "" >> compFun "conj" args + + go _ 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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Software/Representation.hs b/src/Feldspar/Software/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software/Representation.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Software/Verify.hs b/src/Feldspar/Software/Verify.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software/Verify.hs @@ -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" + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Software/Verify/Command.hs b/src/Feldspar/Software/Verify/Command.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software/Verify/Command.hs @@ -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 "" + 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 () + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Software/Verify/Primitive.hs b/src/Feldspar/Software/Verify/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Software/Verify/Primitive.hs @@ -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) + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Storable.hs b/src/Feldspar/Storable.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Storable.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Sugar.hs b/src/Feldspar/Sugar.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Sugar.hs @@ -0,0 +1,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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Verify/Abstract.hs b/src/Feldspar/Verify/Abstract.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Verify/Abstract.hs @@ -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) + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Verify/Arithmetic.hs b/src/Feldspar/Verify/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Verify/Arithmetic.hs @@ -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)) + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Verify/FirstOrder.hs b/src/Feldspar/Verify/FirstOrder.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Verify/FirstOrder.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Verify/Monad.hs b/src/Feldspar/Verify/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Verify/Monad.hs @@ -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 "" + +-------------------------------------------------------------------------------- diff --git a/src/Feldspar/Verify/SMT.hs b/src/Feldspar/Verify/SMT.hs new file mode 100644 --- /dev/null +++ b/src/Feldspar/Verify/SMT.hs @@ -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) + +--------------------------------------------------------------------------------