co-feldspar-0.1.0.1: src/Feldspar/Software/Frontend.hs
{-# 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
--------------------------------------------------------------------------------