diff --git a/C2HS.hs b/C2HS.hs new file mode 100644 --- /dev/null +++ b/C2HS.hs @@ -0,0 +1,220 @@ +-- C->Haskell Compiler: Marshalling library +-- +-- Copyright (c) [1999...2005] Manuel M T Chakravarty +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- 1. Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- 2. 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. +-- 3. The name of the author may not be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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. +-- +--- Description --------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- +-- This module provides the marshaling routines for Haskell files produced by +-- C->Haskell for binding to C library interfaces. It exports all of the +-- low-level FFI (language-independent plus the C-specific parts) together +-- with the C->HS-specific higher-level marshalling routines. +-- + +module C2HS ( + + -- * Re-export the language-independent component of the FFI + module Foreign, + + -- * Re-export the C language component of the FFI + module CForeign, + + -- * Composite marshalling functions + withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv, + peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum, + + -- * Conditional results using 'Maybe' + nothingIf, nothingIfNull, + + -- * Bit masks + combineBitMasks, containsBitMask, extractBitMasks, + + -- * Conversion between C and Haskell types + cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum +) where + + +import Foreign + hiding (Word) + -- Should also hide the Foreign.Marshal.Pool exports in + -- compilers that export them +import CForeign + +import Monad (when, liftM) + + +-- Composite marshalling functions +-- ------------------------------- + +-- Strings with explicit length +-- +withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n) +peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n) + +-- Marshalling of numerals +-- + +withIntConv :: (Storable b, Integral a, Integral b) + => a -> (Ptr b -> IO c) -> IO c +withIntConv = with . cIntConv + +withFloatConv :: (Storable b, RealFloat a, RealFloat b) + => a -> (Ptr b -> IO c) -> IO c +withFloatConv = with . cFloatConv + +peekIntConv :: (Storable a, Integral a, Integral b) + => Ptr a -> IO b +peekIntConv = liftM cIntConv . peek + +peekFloatConv :: (Storable a, RealFloat a, RealFloat b) + => Ptr a -> IO b +peekFloatConv = liftM cFloatConv . peek + +-- Passing Booleans by reference +-- + +withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b +withBool = with . fromBool + +peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool +peekBool = liftM toBool . peek + + +-- Passing enums by reference +-- + +withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c +withEnum = with . cFromEnum + +peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a +peekEnum = liftM cToEnum . peek + + +-- Storing of 'Maybe' values +-- ------------------------- + +instance Storable a => Storable (Maybe a) where + sizeOf _ = sizeOf (undefined :: Ptr ()) + alignment _ = alignment (undefined :: Ptr ()) + + peek p = do + ptr <- peek (castPtr p) + if ptr == nullPtr + then return Nothing + else liftM Just $ peek ptr + + poke p v = do + ptr <- case v of + Nothing -> return nullPtr + Just v' -> new v' + poke (castPtr p) ptr + + +-- Conditional results using 'Maybe' +-- --------------------------------- + +-- Wrap the result into a 'Maybe' type. +-- +-- * the predicate determines when the result is considered to be non-existing, +-- ie, it is represented by `Nothing' +-- +-- * the second argument allows to map a result wrapped into `Just' to some +-- other domain +-- +nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b +nothingIf p f x = if p x then Nothing else Just $ f x + +-- |Instance for special casing null pointers. +-- +nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b +nothingIfNull = nothingIf (== nullPtr) + + +-- Support for bit masks +-- --------------------- + +-- Given a list of enumeration values that represent bit masks, combine these +-- masks using bitwise disjunction. +-- +combineBitMasks :: (Enum a, Bits b) => [a] -> b +combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum) + +-- Tests whether the given bit mask is contained in the given bit pattern +-- (i.e., all bits set in the mask are also set in the pattern). +-- +containsBitMask :: (Bits a, Enum b) => a -> b -> Bool +bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm + in + bm' .&. bits == bm' + +-- |Given a bit pattern, yield all bit masks that it contains. +-- +-- * This does *not* attempt to compute a minimal set of bit masks that when +-- combined yield the bit pattern, instead all contained bit masks are +-- produced. +-- +extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b] +extractBitMasks bits = + [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm] + + +-- Conversion routines +-- ------------------- + +-- |Integral conversion +-- +cIntConv :: (Integral a, Integral b) => a -> b +cIntConv = fromIntegral + +-- |Floating conversion +-- +cFloatConv :: (RealFloat a, RealFloat b) => a -> b +cFloatConv = realToFrac +-- As this conversion by default goes via `Rational', it can be very slow... +{-# RULES + "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; + "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x + #-} + +-- |Obtain C value from Haskell 'Bool'. +-- +cFromBool :: Num a => Bool -> a +cFromBool = fromBool + +-- |Obtain Haskell 'Bool' from C value. +-- +cToBool :: Num a => a -> Bool +cToBool = toBool + +-- |Convert a C enumeration to Haskell. +-- +cToEnum :: (Integral i, Enum e) => i -> e +cToEnum = toEnum . cIntConv + +-- |Convert a Haskell enumeration to C. +-- +cFromEnum :: (Enum e, Integral i) => e -> i +cFromEnum = cIntConv . fromEnum diff --git a/Intel/ArbbVM.chs b/Intel/ArbbVM.chs new file mode 100644 --- /dev/null +++ b/Intel/ArbbVM.chs @@ -0,0 +1,878 @@ +{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-} +{-# OPTIONS -XDeriveDataTypeable #-} + +module Intel.ArbbVM ( Context, ErrorDetails, Type, Variable, + GlobalVariable, Binding, Function(..), VMString, + AttributeMap, + + Error(..), ScalarType(..), Opcode(..), + CallOpcode(..), + LoopType(..), LoopBlock(..), RangeAccessMode(..), + AttributeType(..), + + ArbbVMException, + + module Intel.ArbbVM.Debug, + + getDefaultContext, getScalarType, + + getErrorMessage, getErrorCode, freeErrorDetails, + + sizeOf, + + functionToRefCountable,globalVariableToRefCountable, + acquireRef, releaseRef, + + + getDenseType, createGlobal, + getNestedType, + + isBindingNull, getBindingNull, + + createDenseBinding, freeBinding, getFunctionType, + beginFunction, endFunction, + op, opImm, opDynamic, opDynamicImm, + callOp, execute, + + -- Compile has changed into compile_for_args in latest version + --compile, + + finish, createConstant, createLocal, + variableFromGlobal, getParameter, readScalar, + writeScalar, serializeFunction, freeVMString, + getCString, + + beginLoop, beginLoopBlock, loopCondition, + endLoop, break, continue, ifBranch, elseBranch, + endIf, + + mapToHost, +-- REMOVE THIS EVENTUALLY + fromContext +------------------------- + ) where + +import Intel.ArbbVM.Debug + +import Foreign.C.Types +import Foreign.C.String +import Foreign.Ptr +import Foreign.Storable hiding (sizeOf) + +import Control.Exception +import Control.Monad +import Control.Concurrent +import Control.Concurrent.MVar + +import Data.Typeable +import Data.Word +import Data.IORef + +import System.IO.Unsafe (unsafePerformIO) + +import C2HS hiding (sizeOf) + +import Prelude hiding (break) + +-- find this file in the ArBB installation! +-- #include "../cbits/arbb_vmapi.h" +#include +-- ---------------------------------------------------------------------- + +newtype Context = Context {fromContext :: Ptr ()} +newtype ErrorDetails = ErrorDetails {fromErrorDetails :: Ptr ()} +newtype Type = Type {fromType :: Ptr ()} +newtype Variable = Variable {fromVariable :: Ptr ()} +newtype GlobalVariable = GlobalVariable {fromGlobalVariable :: Ptr ()} +newtype Binding = Binding {fromBinding :: Ptr ()} +newtype Function = Function {fromFunction :: Ptr ()} +newtype VMString = VMString {fromVMString :: Ptr ()} + +newtype RefCountable = RefCountable {fromRefCountable :: Ptr () } +-- types to support aux functionality +newtype AttributeMap = AttributeMap {fromAttributeMap :: Ptr ()} +-- TODO: there is a struct called arbb_attribute_key_value_t +-- that needs to be handeld. + +-- ---------------------------------------------------------------------- +-- ENUMS +-- ---------------------------------------------------------------------- +{# enum arbb_error_t as Error + {underscoreToCase} deriving (Show, Eq) #} + +{# enum arbb_scalar_type_t as ScalarType + {underscoreToCase} deriving (Show, Eq) #} + +{# enum arbb_opcode_t as Opcode + {underscoreToCase} deriving (Show, Eq) #} + +{# enum arbb_call_opcode_t as CallOpcode + {underscoreToCase} deriving (Show, Eq) #} + +{# enum arbb_loop_type_t as LoopType + {underscoreToCase} deriving (Show, Eq) #} + +{# enum arbb_loop_block_t as LoopBlock + {underscoreToCase} deriving (Show, Eq) #} + +{# enum arbb_range_access_mode_t as RangeAccessMode + {underscoreToCase} deriving (Show, Eq) #} + +-- enums to support aux functionality +{# enum arbb_attribute_type_t as AttributeType + {underscoreToCase} deriving (Show, Eq) #} + +-- ---------------------------------------------------------------------- +-- Helpers +-- ---------------------------------------------------------------------- +-- Todo: This is code duplication, clean up +peekErrorDet ptr = do { res <- peek ptr; return $ ErrorDetails res} +peekType ptr = do { res <- peek ptr; return $ Type res} +peekFunction ptr = do { res <- peek ptr; return $ Function res} +peekGlobalVariable ptr = do { res <- peek ptr; return $ GlobalVariable res} +peekVariable ptr = do { res <- peek ptr; return $ Variable res} +peekContext ptr = do { res <- peek ptr; return $ Context res} +peekBinding ptr = do { res <- peek ptr; return $ Binding res} +peekVMString ptr = do { res <- peek ptr; return $ VMString res} +peekRefCountable ptr = do { res <- peek ptr; return $ RefCountable res} + +withTypeArray inp = if (length inp) == 0 then withNullPtr + else withArray (fmap fromType inp) + +withVariableArray = withArray . (fmap fromVariable) +withIntArray xs = withArray (fmap fromIntegral xs) + +withNullPtr :: (Ptr b -> IO a) -> IO a +withNullPtr f = f nullPtr + + +-- ---------------------------------------------------------------------- +-- Exception +-- ---------------------------------------------------------------------- + +data ArbbVMException = ArbbVMException Error String + deriving (Eq, Show, Typeable) + + +instance Exception ArbbVMException + +-- Debug + Error handling is changing.. see ArbbVM/Debug +throwIfErrorIO1 :: (Error,a,ErrorDetails) -> IO a +throwIfErrorIO1 (error_code,a,error_det) = + if fromEnum error_code > 0 + then do + str <- getErrorMessage error_det + freeErrorDetails error_det + throwIO (ArbbVMException error_code str) + else return a + +throwIfErrorIO0 :: (Error,ErrorDetails) -> IO () +throwIfErrorIO0 (error_code, error_det) = + throwIfErrorIO1 (error_code, (), error_det) + + + +-- ---------------------------------------------------------------------- +-- BINDINGS +-- ---------------------------------------------------------------------- + +-- ---------------------------------------------------------------------- +-- To and from refCountable + +-- TODO: Include these in debug traces ? +{# fun unsafe arbb_function_to_refcountable as functionToRefCountable + { fromFunction `Function' } -> `RefCountable' RefCountable #} + +{# fun unsafe arbb_global_variable_to_refcountable as globalVariableToRefCountable + { fromGlobalVariable `GlobalVariable' } -> `RefCountable' RefCountable #} + +-- ---------------------------------------------------------------------- +-- acquire and relese references + +acquireRef rc = + acquireRef' rc >>= + dbg0 "arbb_acquire_ref" [("refCountable", show $ fromRefCountable rc)] >>= + throwIfErrorIO0 + + +{# fun unsafe arbb_acquire_ref as acquireRef' + { fromRefCountable `RefCountable' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + +releaseRef rc = + releaseRef' rc >>= + dbg0 "arbb_release_ref" [("refCountable", show $ fromRefCountable rc)] >>= + throwIfErrorIO0 + +{# fun unsafe arbb_release_ref as releaseRef' + { fromRefCountable `RefCountable' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + + + + + +-- ---------------------------------------------------------------------- +-- getDefaultContext +-- Inputs: None +-- Outputs: The default context. + +getDefaultContext :: IO Context +getDefaultContext = + getDefaultContext' >>= + newDBGFile >>= + dbg "arbb_get_default_context" [] ("ctx",fromContext) >>= + throwIfErrorIO1 + +{# fun unsafe arbb_get_default_context as getDefaultContext' + { alloca- `Context' peekContext* , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + -- id `Ptr (Ptr ())' } -> `Error' cToEnum #} + + + + +-- ---------------------------------------------------------------------- +-- getScalarType. + +getScalarType :: Context -> ScalarType -> IO Type +getScalarType ctx st = + getScalarType' ctx st >>= + dbg "arbb_get_scalar_type" [("ctx",show $ fromContext ctx), + ("st" ,show st)] ("type",fromType) >>= + throwIfErrorIO1 + +{# fun unsafe arbb_get_scalar_type as getScalarType' + { fromContext `Context' , + alloca- `Type' peekType* , + cFromEnum `ScalarType' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + -- id `Ptr (Ptr ())' + + + +-- ---------------------------------------------------------------------- +-- Error handling + + +{# fun unsafe arbb_get_error_message as getErrorMessage + { fromErrorDetails `ErrorDetails' } -> `String' #} + + +{# fun unsafe arbb_get_error_code as getErrorCode + { fromErrorDetails `ErrorDetails' } -> `Error' cToEnum #} + + +{# fun unsafe arbb_free_error_details as freeErrorDetails + { fromErrorDetails `ErrorDetails' } -> `()' #} + + +-- ---------------------------------------------------------------------- +-- sizeOf + +sizeOf ctx t = sizeOf' ctx t >>= throwIfErrorIO1 + +{# fun unsafe arbb_sizeof_type as sizeOf' + { fromContext `Context' , + alloca- `Word64' peekCULLong* , + fromType `Type' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + where peekCULLong x = + do + res <- peek x + return (fromIntegral res) + +-- id `Ptr (Ptr ())' + +-- ---------------------------------------------------------------------- +-- getDenseType +getDenseType ctx t dim = + getDenseType' ctx t dim >>= + dbg "arbb_get_dense_type" [("ctx",show $ fromContext ctx), + ("dt" ,show $ fromType t), + ("dim",show dim)] ("type",fromType) >>= + throwIfErrorIO1 + +{# fun unsafe arbb_get_dense_type as getDenseType' + { fromContext `Context' , + alloca- `Type' peekType* , + fromType `Type' , + cIntConv `Int' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} +-- id `Ptr (Ptr ())' + +getNestedType ctx t = + getNestedType' ctx t >>= + dbg "arbb_get_nested_type" [("ctx", show $ fromContext ctx), + ("itype", show $ fromType t)] + ("otype", fromType) + >>= + throwIfErrorIO1 + +{#fun unsafe arbb_get_nested_type as getNestedType' + { fromContext `Context' , + alloca- `Type' peekType*, + fromType `Type' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + +-- ---------------------------------------------------------------------- +-- createGlobal + +createGlobal :: Context -> Type -> String -> Binding -> IO GlobalVariable +createGlobal ctx t name b = + createGlobal' ctx t name b nullPtr >>= + dbg "arbb_create_global" [("ctx",show $ fromContext ctx), + ("t" ,show $ fromType t), + ("name",name), + ("bind",show $ fromBinding b)] ("GlobalVar",fromGlobalVariable) >>= + throwIfErrorIO1 + +{# fun unsafe arbb_create_global as createGlobal' + { fromContext `Context' , + alloca- `GlobalVariable' peekGlobalVariable* , + fromType `Type' , + withCString* `String' , + fromBinding `Binding' , + id `Ptr ()' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + + --id `Ptr (Ptr ())' + +-- ---------------------------------------------------------------------- +-- Bindings + +{# fun pure arbb_is_binding_null as isBindingNull + { fromBinding `Binding' } -> `Bool' cToBool #} + +-- TODO: see if this needs to be done differently +{# fun unsafe arbb_set_binding_null as getBindingNull + { alloca- `Binding' peekBinding* } -> `()'#} + + +--createDenseBinding :: Context -> Ptr () -> Word -> [CULLong] -> [CULLong] -> IO Binding +--createDenseBinding :: Context -> Ptr () -> Word -> [Integer] -> [Integer] -> IO Binding +createDenseBinding :: Context -> Ptr () -> Word -> [Word64] -> [Word64] -> IO Binding +createDenseBinding ctx d dim sizes pitches = + createDenseBinding' ctx d dim sizes pitches >>= + dbg "arbb_create_densebinding" [("ctx",show $ fromContext ctx), + ("dataPtr" ,show $ d), + ("dim", show dim), + ("sizes", show sizes), + ("pitches",show pitches)] + ("bind",fromBinding) >>= + throwIfErrorIO1 + +{# fun unsafe arbb_create_dense_binding as createDenseBinding' + { fromContext `Context' , + alloca- `Binding' peekBinding* , + id `Ptr ()' , +-- cIntConv `Int' , + cIntConv `Word' , +-- withCULArray* `[Integer]', +-- withCULArray* `[Integer]', + withIntArray* `[Word64]', + withIntArray* `[Word64]', + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + +freeBinding ctx bind = + freeBinding' ctx bind >>= throwIfErrorIO0 + +{# fun unsafe arbb_free_binding as freeBinding' + { fromContext `Context' , + fromBinding `Binding' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + + +-- ---------------------------------------------------------------------- +-- FUNCTIONS + +getFunctionType :: Context -> [Type] -> [Type] -> IO Type +getFunctionType ctx outp inp = + do + let outlen = length outp + inlen = length inp + getFunctionType' ctx outlen outp inlen inp >>= + dbg "arbb_get_function_type" [("ctx",show $ fromContext ctx), + ("outputs" ,show (map fromType outp)), + ("inputs", show (map fromType inp))] + ("type",fromType) >>= + throwIfErrorIO1 + +{# fun unsafe arbb_get_function_type as getFunctionType' + { fromContext `Context' , + alloca- `Type' peekType* , + cIntConv `Int' , + withTypeArray* `[Type]' , + cIntConv `Int' , + withTypeArray* `[Type]' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + --id `Ptr (Ptr ())' + +beginFunction :: Context -> Type -> String -> Int -> IO Function +beginFunction ctx t name remote = + beginFunction' ctx t name remote >>= + dbg "arbb_begin_function" [("ctx",show $ fromContext ctx), + ("fn_t" ,show $ fromType t), + ("name", name), + ("remote", show remote)] + ("fun",fromFunction) >>= + + throwIfErrorIO1 + +{# fun unsafe arbb_begin_function as beginFunction' + { fromContext `Context' , + alloca- `Function' peekFunction* , + fromType `Type' , + withCString* `String' , + cIntConv `Int' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + -- alloca- `ErrorDetails' peekErrorDet* + +endFunction :: Function -> IO () +endFunction f = + endFunction' f >>= + dbg0 "arbb_end_function" [("fun",show $ fromFunction f)] >>= + throwIfErrorIO0 + +{#fun unsafe arbb_end_function as endFunction' + { fromFunction `Function' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + ---id `Ptr (Ptr ())' + +-- ---------------------------------------------------------------------- +-- Operations of various kinds + +-- Operations on scalaras +opImm :: Opcode -> [Variable] -> [Variable] -> IO () +opImm opcode outp inp = + op' (Function nullPtr) opcode outp inp nullPtr nullPtr >>= + dbg0 "arbb_op" [("fun", show $ nullPtr), + ("Opcode", show opcode), + ("outputs", show (map fromVariable outp)), + ("inputs" , show (map fromVariable inp))] >>= + throwIfErrorIO0 + +op :: Function -> Opcode -> [Variable] -> [Variable] -> IO () +op f opcode outp inp = + op' f opcode outp inp nullPtr nullPtr >>= + dbg0 "arbb_op" [("fun",show $ fromFunction f), + ("Opcode", show opcode), + ("outputs", show (map fromVariable outp)), + ("inputs" , show (map fromVariable inp))] >>= + throwIfErrorIO0 + +{# fun unsafe arbb_op as op' + { fromFunction `Function' , + cFromEnum `Opcode' , + withVariableArray* `[Variable]' , + withVariableArray* `[Variable]' , + id `Ptr (Ptr ())' , + id `Ptr (Ptr ())' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + -- alloca- `ErrorDetails' peekErrorDet* + +-- Operation that works on arrays of various length +-- TODO: Add Debug printing here +opDynamic fnt opc outp inp = + opDynamic' fnt + opc + nout + outp + nin + inp + nullPtr + nullPtr >>= throwIfErrorIO0 + where + nin = length inp + nout = length outp + +opDynamicImm opc outp inp = + opDynamic' (Function nullPtr) + opc + nout + outp + nin + inp + nullPtr + nullPtr >>= throwIfErrorIO0 + where + nin = length inp + nout = length outp + + +{# fun unsafe arbb_op_dynamic as opDynamic' + { fromFunction `Function' , + cFromEnum `Opcode' , + cIntConv `Int' , + withVariableArray* `[Variable]' , + cIntConv `Int' , + withVariableArray* `[Variable]' , + id `Ptr (Ptr ())' , + id `Ptr (Ptr ())' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + +-- callOp can be used to map a function over an array +callOp caller opc callee outp inp = + callOp' caller opc callee outp inp >>= + dbg0 "arbb_call_op" [("caller",show $ fromFunction caller), + ("Opcode", show opc), + ("callee", show $ fromFunction callee), + ("outputs", show (map fromVariable outp)), + ("inputs" , show (map fromVariable inp))] >>= + + throwIfErrorIO0 + + +{# fun unsafe arbb_call_op as callOp' + { fromFunction `Function' , + cFromEnum `CallOpcode' , + fromFunction `Function' , + withVariableArray* `[Variable]' , + withVariableArray* `[Variable]' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + +-- ---------------------------------------------------------------------- +-- COMPILE AND RUN + +-- execute f outp inp = execute' f outp inp nullPtr >>= \x -> throwIfErrorIO (x,()) +execute f outp inp = + execute' f outp inp >>= + dbg0 "arbb_execute" [("fun",show $ fromFunction f), + ("outputs", show (map fromVariable outp)), + ("inputs" , show (map fromVariable inp))] >>= + + throwIfErrorIO0 + +{# fun unsafe arbb_execute as execute' + { fromFunction `Function' , + withVariableArray* `[Variable]' , + withVariableArray* `[Variable]' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} +-- alloca- `ErrorDetails' peekErrorDet* + + +-- There is no more "compile" function in this way +-- in the latest version of arbb_vmapi.h +{- +compile f = + compile' f >>= + dbg0 "arbb_compile" [("fun",show $ fromFunction f)] >>= + throwIfErrorIO0 + +{# fun unsafe arbb_compile as compile' + { fromFunction `Function' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} +-} +finish = finish' >>= throwIfErrorIO0 +{# fun unsafe arbb_finish as finish' + {alloca- `ErrorDetails' peekErrorDet*} -> `Error' cToEnum #} + +-- ---------------------------------------------------------------------- +-- Variables, Constants .. + + +createConstant :: Context -> Type -> Ptr () -> IO GlobalVariable +createConstant ctx t d = + createConstant' ctx t d nullPtr >>= + dbg "arbb_create_constant" [("context",show $ fromContext ctx), + ("type",show $ fromType t), + ("dataPtr", show d)] ("globalVar", fromGlobalVariable) >>= + throwIfErrorIO1 + +{# fun unsafe arbb_create_constant as createConstant' + { fromContext `Context' , + alloca- `GlobalVariable' peekGlobalVariable* , + fromType `Type' , + id `Ptr ()' , + id `Ptr ()' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + +createLocal :: Function -> Type -> String -> IO Variable +createLocal fnt t name = + createLocal' fnt t name >>= + dbg "arbb_create_local" [("fun",show $ fromFunction fnt), + ("type",show $ fromType t), + ("name", name)] ("variable", fromVariable) >>= + throwIfErrorIO1 +{# fun unsafe arbb_create_local as createLocal' + { fromFunction `Function' , + alloca- `Variable' peekVariable* , + fromType `Type' , + withCString* `String' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + +variableFromGlobal :: Context -> GlobalVariable -> IO Variable +variableFromGlobal ctx g = + variableFromGlobal' ctx g >>= + dbg "arbb_get_variable_from_global" [("ctx",show $ fromContext ctx), + ("globVar",show $ fromGlobalVariable g)] + ("variable", fromVariable) >>= + throwIfErrorIO1 + +{# fun unsafe arbb_get_variable_from_global as variableFromGlobal' + { fromContext `Context' , + alloca- `Variable' peekVariable* , + fromGlobalVariable `GlobalVariable' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + +getParameter :: Function -> Int -> Int -> IO Variable +getParameter f n m = + getParameter' f n m >>= + dbg "arbb_get_parameter" [("fun",show $ fromFunction f), + ("in/out",show n), + ("index", show m)] ("variable", fromVariable) >>= + throwIfErrorIO1 + +{# fun unsafe arbb_get_parameter as getParameter' + { fromFunction `Function' , + alloca- `Variable' peekVariable* , + cIntConv `Int' , + cIntConv `Int' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + +readScalar :: Context -> Variable -> Ptr () -> IO () +readScalar ctx v ptr = + readScalar' ctx v ptr >>= + dbg0 "arbb_read_scalar" [("ctx",show $ fromContext ctx), + ("variable",show $ fromVariable v), + ("dataOutPtr", show ptr)] >>= + throwIfErrorIO0 + +{# fun unsafe arbb_read_scalar as readScalar' + { fromContext `Context' , + fromVariable `Variable' , + id `Ptr ()' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + +writeScalar :: Context -> Variable -> Ptr () -> IO () +writeScalar ctx v ptr = + writeScalar' ctx v ptr >>= + dbg0 "arbb_write_scalar" [("ctx",show $ fromContext ctx), + ("variable",show $ fromVariable v), + ("dataPtr", show ptr)] >>= + throwIfErrorIO0 + +{# fun unsafe arbb_write_scalar as writeScalar' + { fromContext `Context' , + fromVariable `Variable' , + id `Ptr ()' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + +serializeFunction :: Function -> IO VMString +serializeFunction fun = + serializeFunction' fun >>= throwIfErrorIO1 + +-- TODO: use finalizer to remove VMString ? (ForeignPtr) +{# fun unsafe arbb_serialize_function as serializeFunction' + { fromFunction `Function' , + alloca- `VMString' peekVMString*, + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + +--void arbb_free_string(arbb_string_t string); +{# fun unsafe arbb_free_string as freeVMString + { fromVMString `VMString' } -> `()' #} + +--const char* arbb_get_c_string(arbb_string_t string); +{# fun pure arbb_get_c_string as getCString + { fromVMString `VMString' } -> `String' peekCString* #} + +-- ---------------------------------------------------------------------- +-- Flowcontrol + + + +-- LOOPS +beginLoop fnt kind = + beginLoop' fnt kind >>= + dbg0 "arbb_begin_loop" [("fun",show $ fromFunction fnt), + ("kind",show kind) ] >>= + throwIfErrorIO0 + +{# fun unsafe arbb_begin_loop as beginLoop' + { fromFunction `Function' , + cFromEnum `LoopType' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + +beginLoopBlock fnt block = + beginLoopBlock' fnt block >>= + dbg0 "arbb_begin_loop_block" [("fun",show $ fromFunction fnt), + ("block",show block) ] >>= + throwIfErrorIO0 + +{# fun unsafe arbb_begin_loop_block as beginLoopBlock' + { fromFunction `Function' , + cFromEnum `LoopBlock' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + +loopCondition fnt var = + loopCondition' fnt var >>= + dbg0 "arbb_loop_condition" [("fun",show $ fromFunction fnt), + ("condVar",show $ fromVariable var) ] >>= + throwIfErrorIO0 + +{#fun unsafe arbb_loop_condition as loopCondition' + { fromFunction `Function' , + fromVariable `Variable' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + + + +endLoop fnt = + endLoop' fnt >>= + dbg0 "arbb_end_loop" [("fun",show $ fromFunction fnt)] >>= + throwIfErrorIO0 + +{#fun unsafe arbb_end_loop as endLoop' + { fromFunction `Function' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + +break fnt = + break' fnt >>= + dbg0 "arbb_break" [("fun",show $ fromFunction fnt)] >>= + throwIfErrorIO0 + +{#fun unsafe arbb_break as break' + { fromFunction `Function' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + +continue fnt = + continue' fnt >>= + dbg0 "arbb_continue" [("fun",show $ fromFunction fnt)] >>= + throwIfErrorIO0 + +{#fun unsafe arbb_continue as continue' + { fromFunction `Function' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + + +-- if then else + +ifBranch f v = ifBranch' f v >>= throwIfErrorIO0 + +{# fun unsafe arbb_if as ifBranch' + { fromFunction `Function' , + fromVariable `Variable' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + + +elseBranch f = elseBranch' f >>= throwIfErrorIO0 + +{#fun unsafe arbb_else as elseBranch' + { fromFunction `Function' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + +endIf f = endIf' f >>= throwIfErrorIO0 + +{#fun unsafe arbb_end_if as endIf' + { fromFunction `Function' , + alloca- `ErrorDetails' peekErrorDet*} -> `Error' cToEnum #} + + + +-- ---------------------------------------------------------------------- +-- Alternative means of data movement + +mapToHost ctx var pitch mode = + mapToHost' ctx var pitch mode >>= +-- dbg "map_to_host" [("ctx",show $ fromContext ctx), +-- ("variable" ,show (fromVariable var)), +-- ("pitch", show pitch)] +-- (-- something about the result -- ) >>= + throwIfErrorIO1 + +{# fun unsafe arbb_map_to_host as mapToHost' + { fromContext `Context' , + fromVariable `Variable' , + alloca- `Ptr ()' peek* , + withIntArray* `[Word64]' , + cFromEnum `RangeAccessMode' , + alloca- `ErrorDetails' peekErrorDet* } -> `Error' cToEnum #} + + + + + +-- ---------------------------------------------------------------------- +-- null and isThisNull ? + + +-- int arbb_is_refcountable_null(arbb_refcountable_t object); + + +-- void arbb_set_refcountable_null(arbb_refcountable_t* object); + + +-- int arbb_is_error_details_null(arbb_error_details_t object); + + +-- void arbb_set_error_details_null(arbb_error_details_t* object); + + +-- int arbb_is_string_null(arbb_string_t object); + + +-- void arbb_set_string_null(arbb_string_t* object); + + +-- int arbb_is_context_null(arbb_context_t object); + + +-- void arbb_set_context_null(arbb_context_t* object); + +-- int arbb_is_function_null(arbb_function_t object); + + +-- void arbb_set_function_null(arbb_function_t* object); + + +-- int arbb_is_variable_null(arbb_variable_t object); + + +-- void arbb_set_variable_null(arbb_variable_t* object); + + +-- int arbb_is_global_variable_null(arbb_global_variable_t object); + + +-- void arbb_set_global_variable_null(arbb_global_variable_t* object); + + +-- int arbb_is_binding_null(arbb_binding_t object); + + +-- void arbb_set_binding_null(arbb_binding_t* object); + + +-- int arbb_is_type_null(arbb_type_t object); + + +-- void arbb_set_type_null(arbb_type_t* object); + +-- void arbb_cxx_set_stack_trace_null(arbb_cxx_stack_trace_t* object); + + +-- int arbb_cxx_is_stack_trace_null(arbb_cxx_stack_trace_t object); + + +-- void arbb_set_attribute_map_null(arbb_attribute_map_t* object); + + +-- int arbb_is_attribute_map_null(arbb_attribute_map_t object); + +-- ---------------------------------------------------------------------- +-- Auxiliary functionality diff --git a/Intel/ArbbVM/Convenience.hs b/Intel/ArbbVM/Convenience.hs new file mode 100644 --- /dev/null +++ b/Intel/ArbbVM/Convenience.hs @@ -0,0 +1,707 @@ +{-# LANGUAGE CPP #-} + +{- | + + A module capturing common patterns in ArBB VM code emission and + thereby making it easier to emit code. + + -} + +module Intel.ArbbVM.Convenience + ( + ifThenElse, while, readScalarOfSize, newConstant, + + arbbSession, EmitArbb, ConvFunction, + if_, while_, readScalar_, + funDef_, funDefS_, -- funDefCallable_, + op_, opImm_, + opDynamic_, opDynamicImm_, + map_, call_, + + mapToHost_, + + const_, int32_, int64_,float32_, float64_, bool_, + const_storable_, + usize_, isize_, + incr_int32_, + copy_, copyImm_, + + local_bool_, local_int32_, local_float64_, + global_nobind_, global_nobind_int32_, + + -- Compile does not exist in this way anymore + --compile_, + execute_, serializeFunction_, finish_, + + getBindingNull_, getScalarType_, variableFromGlobal_, + getFunctionType_, createGlobal_, createLocal_, + + createDenseBinding_, getDenseType_, + getNestedType_, + + withArray_, print_, + + doarith_, SimpleArith(V), +-- module Intel.ArbbVM.SimpleArith, + + liftIO, liftMs, + + -- These should probably be internal only: + getCtx, getFun + ) +where + +--import qualified Intel.ArbbVM as VM +import Intel.ArbbVM as VM +-- import Intel.ArbbVM.SimpleArith + +import Control.Monad +import Data.IORef +import Data.Word +import Data.Int +import Data.Serialize +import Data.ByteString.Internal +import Foreign.Marshal.Array +import Foreign.Marshal.Alloc +import Foreign.ForeignPtr +import Foreign.Storable as Storable +import Foreign.Ptr +import C2HS + +import qualified Control.Monad.State.Strict as S + +import Debug.Trace + +-------------------------------------------------------------------------------- +-- The monad for emitting Arbb code. +type EmitArbb = S.StateT ArbbEmissionState IO + +-- We put the context and a stack of function types into the +-- background. Note, we need the stack of functions because we allow +-- nested function definitions at this convenience layer. (They will +-- all have global scope to ArBB however.) +type ArbbEmissionState = (Context, [ConvFunction]) -- BJS: ConvFunction in place of Function +-- Note: if we also include a counter in here we can do gensyms... + + +-- BJS: Convenient functions are pairs of inconvenient functions +data ConvFunction = ConvFunction { executable :: Function, -- just a wrapper + callable :: Function } -- "The" function + + +#define L S.lift$ + +liftIO :: IO a -> EmitArbb a +liftIO = S.lift -- Allow the user to perform IO inside this monad. + +arbbSession :: EmitArbb a -> IO a +arbbSession m = + do ctx <- getDefaultContext + (a,s) <- S.runStateT m (ctx,[]) + return a + +-- BJS: ConvFunction (as a name) is a bit inconvenient +getConvFun msg = + do (_,ls) <- S.get + case ls of + [] -> error$ msg ++" when not inside a function" + (h:t) -> return h + +getFun msg = + do (_,ls) <- S.get + case ls of + [] -> error$ msg ++" when not inside a function" + (h:t) -> return (callable h) + + +getCtx = + do (ctx,_) <- S.get + return ctx + +------------------------------------------------------------------------------ +-- Map an ArBB array into host addrspace +mapToHost_ :: Variable -> [Word64] -> RangeAccessMode -> EmitArbb (Ptr ()) +mapToHost_ var pitch mode = do + ctx <- getCtx + L mapToHost ctx var pitch mode +-------------------------------------------------------------------------------- +-- Convenience functions for common patterns: + +opImm_ :: Opcode -> [Variable] -> [Variable] -> EmitArbb() +opImm_ code out inp = L opImm code out inp + +op_ :: Opcode -> [Variable] -> [Variable] -> EmitArbb () +op_ code out inp = + do fun <- getFun "Convenience.op_ cannot execute an Opcode" + L op fun code out inp + +opDynamicImm_ :: Opcode -> [Variable] -> [Variable] -> EmitArbb() +opDynamicImm_ code out inp = L opDynamicImm code out inp + +opDynamic_ :: Opcode -> [Variable] -> [Variable] -> EmitArbb () +opDynamic_ code out inp = + do fun <- getFun "Convenience.opDynamic_ cannot execute an Opcode" + L opDynamic fun code out inp + +if_ :: Variable -> EmitArbb a -> EmitArbb a1 -> EmitArbb () +if_ c t e = + do fun <- getFun "Convenience.if_ cannot execute a conditional" + L ifBranch fun c + t -- op myfun ArbbOpSub [c] [a,a] + L elseBranch fun + e -- op myfun ArbbOpDiv [c] [a,a] + L endIf fun + +-- | An ArBB while loop. Must be called inside a function definition. +while_ :: (EmitArbb Variable) -> EmitArbb a -> EmitArbb a +while_ cond body = + do fun <- getFun "Convenience.while_ cannot execute a while loop" + L beginLoop fun ArbbLoopWhile + L beginLoopBlock fun ArbbLoopBlockCond + lc <- cond + L loopCondition fun lc + L beginLoopBlock fun ArbbLoopBlockBody + result <- body + L endLoop fun + return result + + +const_storable_ :: Storable a => ScalarType -> a -> EmitArbb Variable +const_storable_ st n = + do ctx <- getCtx + L newConstantAlt ctx st n + +-- This version picks the right in-memory representation. +const_ :: Integral a => ScalarType -> a -> EmitArbb Variable +const_ sty i = + case sty of + ArbbI8 -> const_storable_ sty (fromIntegral i :: Int8) + ArbbI16 -> const_storable_ sty (fromIntegral i :: Int16) + ArbbI32 -> const_storable_ sty (fromIntegral i :: Int32) + ArbbI64 -> const_storable_ sty (fromIntegral i :: Int64) + + ArbbU8 -> const_storable_ sty (fromIntegral i :: Word8) + ArbbU16 -> const_storable_ sty (fromIntegral i :: Word16) + ArbbU32 -> const_storable_ sty (fromIntegral i :: Word32) + ArbbU64 -> const_storable_ sty (fromIntegral i :: Word64) + + -- This only lets you get at the integral floating point numbers: + ArbbF32 -> const_storable_ sty (fromIntegral i :: Float) + ArbbF64 -> const_storable_ sty (fromIntegral i :: Double) + + ArbbUsize -> const_storable_ sty (fromIntegral i :: Word) + ArbbIsize -> const_storable_ sty (fromIntegral i :: Int) + + + +readScalar_ :: (Num a, Storable a) => Variable -> EmitArbb a +readScalar_ v = + do ctx <- getCtx + let z = 0 + size = Storable.sizeOf z + x <- L readScalarOfSize size ctx v + return (x+z) + +type FunBody = [Variable] -> [Variable] -> EmitArbb () + +debug_fundef = True + +{- + BJS: This funDef_ situation might need some improvement. + - one option is create the functions both callable and not + a Function would need to be a pair of the "callable" function + and the "executable" function + - This is a part of ArBB that is very likely to change + + +-} +{- +funDef_ name outty inty userbody = + funDefInternal name outty inty userbody 1 + +funDefCallable_ name outty inty userbody = + funDefInternal name outty inty userbody 0 + +funDefInternal :: String -> [Type] -> [Type] -> FunBody -> Int -> EmitArbb Function +funDefInternal name outty inty userbody remote = + do + ctx <- getCtx + fnt <- L getFunctionType ctx outty inty + fun <- L beginFunction ctx fnt name remote + + when debug_fundef$ print_$ "["++name++"] Function begun." + invars <- L forM [0 .. length inty - 1] (getParameter fun 0) + outvars <- L forM [0 .. length outty - 1] (getParameter fun 1) + + -- Push on the stack: + S.modify (\ (c,ls) -> (c, fun:ls)) + + -- Now generate body: + when debug_fundef$ print_$ "["++name++"] Begin body codgen..." + userbody outvars invars + when debug_fundef$ print_$ "["++name++"] Done body codgen." + + -- Pop off the stack: + S.modify (\ (c, h:t) -> (c, t)) + L endFunction fun + + -- EXPERIMENTAL! Compile immediately!! + when debug_fundef$ print_$ "["++name++"] Function ended. Compiling..." + L compile fun + when debug_fundef$ print_$ "["++name++"] Done compiling." + return fun +-} + +is_callable = 0 +is_executable = 1 +nullfun = Function nullPtr + +-- BJS: New funDef (create a pair of funs, actual fun + wrapper) +funDef_ :: String -> [Type] -> [Type] -> FunBody -> EmitArbb ConvFunction +funDef_ name outty inty userbody = + do + ctx <- getCtx + + fnt <- L getFunctionType ctx outty inty + fun <- L beginFunction ctx fnt name is_callable + + when debug_fundef$ print_$ "["++name++"] Function begun." + invars <- L forM [0 .. length inty - 1] (getParameter fun 0) + outvars <- L forM [0 .. length outty - 1] (getParameter fun 1) + + -- Push on the stack: + S.modify (\ (c,ls) -> (c, (ConvFunction nullfun fun):ls)) + + -- Now generate body: + when debug_fundef$ print_$ "["++name++"] Begin body codgen..." + userbody outvars invars + when debug_fundef$ print_$ "["++name++"] Done body codgen." + + -- Pop off the stack: + S.modify (\ (c, h:t) -> (c, t)) + L endFunction fun + + -- EXPERIMENTAL! Compile immediately!! + --when debug_fundef$ print_$ "["++name++"] Function ended. Compiling..." + --L compile fun + --when debug_fundef$ print_$ "["++name++"] Done compiling." + + -- Also create an executable wrapper + wrapper <- L beginFunction ctx fnt name is_executable + inputs <- L forM [0 .. length inty - 1] (getParameter wrapper 0) + outputs <- L forM [0 .. length outty - 1] (getParameter wrapper 1) + L callOp wrapper ArbbOpCall fun outputs inputs + L endFunction wrapper + + + return$ ConvFunction wrapper fun + + +-- Umm... what's a good naming convention here? +funDefS_ :: String -> [ScalarType] -> [ScalarType] -> FunBody -> EmitArbb ConvFunction +funDefS_ name outs ins body = + do + outs' <- mapM getScalarType_ outs + ins' <- mapM getScalarType_ ins + funDef_ name outs' ins' body + +{- +call_ :: Function -> [Variable] -> [Variable] -> EmitArbb () +call_ fun out inp = + do -- At the point of the call the *caller* is on the top of the stack: + caller <- getFun "Convenience.call_ cannot call function" + when debug_fundef$ print_ "Call_: got caller function, emitting call opcode..." + L callOp caller ArbbOpCall fun out inp + when debug_fundef$ print_ "Call_: Done emitting call opcode." +-} +call_ :: ConvFunction -> [Variable] -> [Variable] -> EmitArbb () +call_ fun out inp = + do -- At the point of the call the *caller* is on the top of the stack: + caller <- getFun "Convenience.call_ cannot call function" + when debug_fundef$ print_ "Call_: got caller function, emitting call opcode..." + L callOp caller ArbbOpCall (callable fun) out inp + when debug_fundef$ print_ "Call_: Done emitting call opcode." + + + +map_ :: ConvFunction -> [Variable] -> [Variable] -> EmitArbb () +map_ fun out inp = + do -- At the point of the call the *caller* is on the top of the stack: + caller <- getFun "Convenience.map_ cannot call function" + when debug_fundef$ print_ "Map_: got caller function, emitting map opcode..." + L callOp caller ArbbOpMap (callable fun) out inp + when debug_fundef$ print_ "Map_: Done emitting map opcode." + + +-------------------------------------------------------------------------------- +-- Iteration Patterns. + +-- for_range_ :: Variable -> Variable -> (i -> EmitArbb ()) -> EmitArbb () + +-- This uses C-style [inclusive,exclusive) ranges. +-- for_constRange_ :: Int -> Int -> (i -> EmitArbb ()) -> EmitArbb () +-- for_range_ start end body = do +-- counter <- local_int32_ "counter" +-- op_ ArbbOpCopy [counter] [zer] +-- while_ (do +-- lc <- local_bool_ "loopcond" +-- op_ ArbbOpLess [lc] [counter,max] +-- return lc) +-- (op_ ArbbOpAdd [counter] [counter,one]) + +-- Lifting higher order ops like this is trickier. +withArray_ :: Storable a => [a] -> (Ptr a -> EmitArbb b) -> EmitArbb b +withArray_ ls body = + do state <- S.get + ref <- L newIORef state + let body2 ptr = do (a,s2) <- S.runStateT (body ptr) state + writeIORef ref s2 + return a + res <- L withArray ls body2 + state2 <- L readIORef ref + S.put state2 + return res + +print_ :: String -> EmitArbb () +print_ = S.lift . putStrLn + +-------------------------------------------------------------------------------- + +-- liftM for lists +liftMs :: Monad m => ([a] -> m b) -> [m a] -> m b +-- liftMs fn ls = liftM fn (sequence ls) +liftMs fn ls = + sequence ls >>= fn + -- do ls' <- sequence ls + -- fn ls' + +-- These let us lift the slew of ArbbVM functions that expect a Context as a first argument. +lift1 :: (Context -> a -> IO b) -> a -> EmitArbb b +lift2 :: (Context -> a -> b -> IO c) -> a -> b -> EmitArbb c +lift3 :: (Context -> a -> b -> c -> IO d) -> a -> b -> c -> EmitArbb d +lift4 :: (Context -> a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> EmitArbb e + +lift1 fn a = do ctx <- getCtx; L fn ctx a +lift2 fn a b = do ctx <- getCtx; L fn ctx a b +lift3 fn a b c = do ctx <- getCtx; L fn ctx a b c +lift4 fn a b c d = do ctx <- getCtx; L fn ctx a b c d + +getScalarType_ = lift1 getScalarType +getDenseType_ = lift2 getDenseType +getNestedType_ = lift1 getNestedType +variableFromGlobal_ = lift1 variableFromGlobal +getFunctionType_ = lift2 getFunctionType +createGlobal_ = lift3 createGlobal + +createLocal_ :: Type -> String -> EmitArbb Variable +createLocal_ ty name = do f <- getFun "Convenience.createLocal_ cannot create local" + L createLocal f ty name + +createDenseBinding_ = lift4 createDenseBinding + +---------------------------------------- +-- These are easy ones, no Context or Function argument: + +-- compile_ fn = liftIO$ compile fn +-- execute_ a b c = liftIO$ execute a b c +finish_ = liftIO finish +--serializeFunction_ = liftIO . serializeFunction +getBindingNull_ = liftIO getBindingNull + +--BJS: execute_ nolonger quite as easy +execute_ f o i = liftIO$ execute (executable f) o i + +--BJS: should be a way to serialize the wrapper also! +serializeFunction_ f = liftIO$ serializeFunction (callable f) + +-- ... TODO ... Keep going. + +-------------------------------------------------------------------------------- + +-- Lazy, lazy, lazy: here are even more shorthands. + +int32_ :: Integral t => t -> EmitArbb Variable +int64_ :: Integral t => t -> EmitArbb Variable +usize_ :: Integral t => t -> EmitArbb Variable +isize_ :: Integral t => t -> EmitArbb Variable +float32_ :: Float -> EmitArbb Variable +float64_ :: Double -> EmitArbb Variable + +int32_ = const_ ArbbI32 +int64_ = const_ ArbbI64 +usize_ = const_ ArbbUsize +isize_ = const_ ArbbIsize +float32_ = const_storable_ ArbbF32 +float64_ = const_storable_ ArbbF64 + + + +bool_ :: Bool -> EmitArbb Variable +bool_ True = const_storable_ ArbbBoolean (1::Int32) +bool_ False = const_storable_ ArbbBoolean (0::Int32) + +-- TODO... Keep going... + +incr_int32_ :: Variable -> EmitArbb () +incr_int32_ var = do one <- int32_ 1 + op_ ArbbOpAdd [var] [var,one] + +copy_ v1 v2 = op_ ArbbOpCopy [v1] [v2] +copyImm_ v1 v2 = opImm_ ArbbOpCopy [v1] [v2] + +------------------------------------------------------------ + +local_bool_ name = do bty <- getScalarType_ ArbbBoolean + createLocal_ bty name + +local_int32_ name = do ity <- getScalarType_ ArbbI32 + createLocal_ ity name + +local_float64_ name = do ty <- getScalarType_ ArbbF64 + createLocal_ ty name + +global_nobind_ ty name = + do binding <- getBindingNull_ + g <- createGlobal_ ty name binding + variableFromGlobal_ g + +global_nobind_int32_ name = + do sty <- getScalarType_ ArbbI32 + global_nobind_ sty name + +-------------------------------------------------------------------------------- +-- Num instance. + + + + +-------------------------------------------------------------------------------- +-- OBSOLETE: These were some helpers that didn't use the EmitArbb monad. + +ifThenElse :: Function -> Variable -> IO a -> IO a1 -> IO () +ifThenElse f c t e = + do + ifBranch f c + t -- op myfun ArbbOpSub [c] [a,a] + elseBranch f + e -- op myfun ArbbOpDiv [c] [a,a] + endIf f + + +-- while loops +while :: Function -> (IO Variable) -> IO a1 -> IO () +while f cond body = + do + beginLoop f ArbbLoopWhile + beginLoopBlock f ArbbLoopBlockCond + lc <- cond + loopCondition f lc + + beginLoopBlock f ArbbLoopBlockBody + body + endLoop f + +-- Works not just for arrays but anything serializable: +withSerialized :: Serialize a => a -> (Ptr () -> IO b) -> IO b +withSerialized x fn = + withForeignPtr fptr (fn . castPtr) + where + (fptr,_,_) = toForeignPtr (encode x) + +newConstant :: Storable a => Context -> Type -> a -> IO Variable +newConstant ctx t n = + do + -- Could use withSerialized possibly... + tmp <- withArray [n] $ \x -> createConstant ctx t (castPtr x) + variableFromGlobal ctx tmp + +newConstantAlt :: Storable a => Context -> ScalarType -> a -> IO Variable +newConstantAlt ctx st n = + do + t <- getScalarType ctx st + tmp <- withArray [n] $ \x -> createConstant ctx t (castPtr x) + variableFromGlobal ctx tmp + +-- global/constant shortcuts + +-- readScalarOfSize :: Storable b => Int -> Context -> Variable -> EmitArbb b +readScalarOfSize :: Storable b => Int -> Context -> Variable -> IO b +readScalarOfSize n ctx v = + allocaBytes n $ \ptr -> + do + readScalar ctx v ptr + peek (castPtr ptr) + +-- TODO: readScalar of storable should be able to determine size. + + +---------------------------------------------------------------------------------------------------- +-- Numeric instances. +---------------------------------------------------------------------------------------------------- + +{- + It is not clear that this is worth it, yet. + This is mainly here because I want to use Data.Complex. + -} + + +-- We could use a richer type for Variable in the convenience interface. +-- data VarPlus = VarPlus Variable Type +-- +-- The trick would be to have functions like op_ take [SimpleArith] rather than [Variable] +-- But to dealwith anything other than the "V" variant, the desired type would need to be known. +-- + +instance Show Variable where + show v = "" + +instance Eq Variable where + a == b = error "equality on Variables doesn't make sense yet" + +data SimpleArith = + V Variable + | Const Integer + | ConstD Double + + | Plus SimpleArith SimpleArith + | Times SimpleArith SimpleArith + | Div SimpleArith SimpleArith + | Signum SimpleArith + | Abs SimpleArith + + | Expon SimpleArith + | Sqrt SimpleArith + | Log SimpleArith + | Sin SimpleArith + | Cos SimpleArith + | ASin SimpleArith + | ACos SimpleArith + | ATan SimpleArith + | SinH SimpleArith + | CosH SimpleArith + | ASinH SimpleArith + | ACosH SimpleArith + | ATanH SimpleArith + +-- | ProperFrac SimpleArith + -- UNFINISHED + deriving (Show,Eq) + + +instance Num SimpleArith where + (+) = Plus + (*) = Times + signum = Signum + abs = Abs + fromInteger = Const + +instance Fractional SimpleArith where + (/) = Div + fromRational rat = error "fromRational not implemented yet for SimpleArith" + +instance Ord SimpleArith where + a < b = error "< not implemented yet for SimpleArith" + +instance Real SimpleArith where + toRational v = error "toRational not implemented for SimpleArith" + +instance Floating SimpleArith where + pi = ConstD pi + exp = Expon + sqrt = Sqrt + log = Log + -- (**) :: a -> a -> a + -- logBase :: a -> a -> a + sin = Sin + -- tan :: a -> a + cos = Cos + asin = ASin + atan = ATan + acos = ACos + sinh = SinH + cosh = CosH + asinh = ASinH + acosh = ACosH + atanh = ATanH + +-- instance Enum SimpleArith where +-- instance Integral SimpleArith where + +--class (Real a, Fractional a) => RealFrac a where +instance RealFrac SimpleArith where +-- properFraction :: Integral b => a -> (b, a) + properFraction x = error "properFraction not implemented for SimpleArith" + +#if 0 + +class (Real a, Enum a) => Integral a where + quot :: a -> a -> a + rem :: a -> a -> a + div :: a -> a -> a + mod :: a -> a -> a + quotRem :: a -> a -> (a, a) + divMod :: a -> a -> (a, a) + toInteger :: a -> Integer + +class Enum a where + succ :: a -> a + pred :: a -> a + toEnum :: Int -> a + fromEnum :: a -> Int + enumFrom :: a -> [a] + enumFromThen :: a -> a -> [a] + enumFromTo :: a -> a -> [a] + enumFromThenTo :: a -> a -> a -> [a] + +class (RealFrac a, Floating a) => RealFloat a where + floatRadix :: a -> Integer + floatDigits :: a -> Int + floatRange :: a -> (Int, Int) + decodeFloat :: a -> (Integer, Int) + encodeFloat :: Integer -> Int -> a + exponent :: a -> Int + significand :: a -> a + scaleFloat :: Int -> a -> a + isNaN :: a -> Bool + isInfinite :: a -> Bool + isDenormalized :: a -> Bool + isNegativeZero :: a -> Bool + isIEEE :: a -> Bool + atan2 :: a -> a -> a + +#endif + + +-- | This lets one execute simple arithmetic expressions and store the result. +-- Returns the name of a new local binding that caries the result. +doarith_ :: ScalarType -> SimpleArith -> EmitArbb Variable +doarith_ ty_ exp = + do ty <- getScalarType_ ty_ + let binop op a b = + do tmp <- createLocal_ ty "tmp" + a' <- loop a + b' <- loop b + op_ op [tmp] [a',b'] + return tmp + loop exp = + case exp of + V v -> return v + Const i -> const_ ty_ i + + Plus a b -> binop ArbbOpAdd a b + Times a b -> binop ArbbOpMul a b + _ -> error$ "doarith_: not handled yet: "++ show exp + loop exp + + +-- data ScalarType = ArbbI8 +-- | ArbbI16 +-- | ArbbI32 +-- | ArbbI64 + +-- | ArbbU8 +-- | ArbbU16 +-- | ArbbU32 +-- | ArbbU64 + +-- deriving (Enum,Show,Eq) diff --git a/Intel/ArbbVM/Debug.hs b/Intel/ArbbVM/Debug.hs new file mode 100644 --- /dev/null +++ b/Intel/ArbbVM/Debug.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE ForeignFunctionInterface, BangPatterns, ScopedTypeVariables #-} +{-# OPTIONS -XDeriveDataTypeable -fwarn-unused-imports #-} + +{- + + TODO LIST: +============================================================ + + * Constants need to be back-translated, e.g. "ArbbOpAdd". See the + example output below which is generated by the attached + test_debug.hs. + + * Appropriate headers need to be included. + + * Arguments to "dbg" need to be tweaked/pruned so that they + reflect ONLY the arguments to the actual C api calls. + + o Actually.... get_function_type is a particularly + challenging example because it passes arrays of types. To + be honest I'm not sure what the best solution there is. + + o The strings-only hack may not be sustainable. + + o Perhaps the next step would be to include more structure + and metadata in the DbgEvent. That's fine with me though -- + the main thing was that I wanted DbgEvent to have Show/Read + invariance, not depend on in-memory haskell data + structures... + + * The array capture mechanism needs to be implemented. A + DbgArraySnapshot needs to be created when an array is sent to + ArBB (bind?), then makeCReproducer needs to generate a big + constant C array. OR another approach is to store each array in + its binary representation in a file. + + * When the whole thing works I was going to factor out your + existing debugging printed messages and implement a separate + function that consumes DbgTraces and prints those same messages. + +-} + +module Intel.ArbbVM.Debug + ( + DbgEvent(..), + dbg, dbg0, dbgfile, + runTrace, runReproducer, makeCReproducer, + + -- TEMP: + newDBGFile, printInfo + ) +where + +import Debug.Trace() +import Control.Concurrent +import Data.IORef +import Data.List +import qualified Data.Map as M + +import System.IO() +import System.Directory +import Text.PrettyPrint.HughesPJ + +import C2HS hiding (sizeOf) + +-- -------------------------------------------------------------------------------- +-- Globals and Datatype Definitions +-- -------------------------------------------------------------------------------- + +-- | Flag to disable debugging. For now this is set statically in the +-- code. It should be dynamically configurable. +debug_arbbvm = True + +-- | Name of the debug output file, to be placed in the current directory. +dbgfile = "debugtrace_HaskellArBB.txt" + +-- | A running ArBBVM session creates a trace of debug messages that +-- can be consumed immediately or accumulated in memory. +data DbgTrace = DbgCons Int TaggedDbgEvent (MVar DbgTrace) + +-- Tagged with additional message and ThreadID: +type TaggedDbgEvent = (ThreadId,DbgEvent) + +data DbgEvent = + DbgStart -- A dummy event. + | DbgCall { operator :: String, + operands :: [NamedValue], + result :: NamedValue } + -- NOTE: This is an inefficent representation, we could at least use + -- binary representations for common scalar types: + -- Also we could use bytestrings here and Text.Show.ByteString: + | DbgArraySnapshot [String] + deriving (Show, Read) + +-- A printed value together with a descriptive name: +type NamedValue = (String,String) + + +-- -------------------------------------------------------------------------------- + +-- Run an computation that interacts with the ArBB-VM and capture its +-- trace. +runTrace :: IO a ->IO (a,[DbgEvent]) +runTrace m = + do + -- ASSUMPTION: m is a single threaded computation! + tid <- myThreadId + -- Capture the starting point for this segment of trace: + head <- readIORef global_dbg_trace_tail + -- Run the computation: + x <- m + -- Capture the ending point: + DbgCons cntr2 _ _ <- readIORef global_dbg_trace_tail + -- Read everything inbetween: + ls <- extractTrace tid cntr2 head + return (x,ls) + +reproducer_file = "reproducer.c" + +-- Run an ArBBVM computation, log interactions, and generate a reproducer C program. +runReproducer :: IO a ->IO a +runReproducer m = do + putStrLn$ "Begin logging ArBB-VM interactions and generating reproducer: " ++ reproducer_file + (x,ls) <- runTrace m + writeFile reproducer_file (makeCReproducer ls) + putStrLn$ "Done writing reproducer to: "++reproducer_file + return x + +extractTrace :: ThreadId -> Int -> DbgTrace -> IO [DbgEvent] +extractTrace tid end trace = loop trace [] + where + loop (DbgCons ctr (id,evt) tl) !acc = + if ctr == end then + return (reverse (evt:acc)) + else do nxt <- readMVar tl + loop nxt (if id==id then evt:acc else acc) + + +-- TODO: ASYNC VERSION: +-- Here the trace is returned as a lazy list so that it may be +-- consumed concurrently with the IO computation. +-- runWithTraceAsync :: IO a -> ([DbgEvent], IO a) + +-- TOFIX: Presently debug traces are accumulated via a global +-- variable. In the future it's probably better that this go in a +-- state monad! +global_dbg_trace_tail :: IORef DbgTrace +global_dbg_trace_tail = unsafePerformIO initial + where initial = do tl <- newEmptyMVar + id <- myThreadId + newIORef (DbgCons 0 (id,DbgStart) tl) + +-- | IO function to log an event in the debug trace. +dbg :: (Show c) => + String -> + [(String,String)] -> + (String, b -> c) -> +-- (Error, b, ErrorDetails) -> IO (Error, b, ErrorDetails) + (d, b, e) -> IO (d, b, e) + +dbg msg inputs (nom,accf) (ec, rv, ed) = + do + id <- myThreadId + new_tl <- newEmptyMVar + let evt = DbgCall msg inputs (nom, show (accf rv)) + loop = do + -- Now to add a new entry to the debug trace. Things get tricky + -- because we want to do TWO things, extend the linked list and + -- modify the global variable to point to the new tail. We could + -- use TVars to do that atomically but the following protocol + -- works as well. Which runs better under contention? + DbgCons cntr hd tl <- readIORef global_dbg_trace_tail + let newcell = DbgCons (cntr+1) (id,evt) new_tl + success <- tryPutMVar tl newcell + if success then + -- If we succeed then we have the right to repoint the global: + writeIORef global_dbg_trace_tail newcell + -- If we fail to fill the tail then someone else beat us to it and we retry: + else loop + loop + putStrLn$ ", "++ show evt + + -- TEMP: Keeping the old-style print messages for now as well: + appendFile dbgfile $ + msg ++ concatMap printInfo inputs ++ + "-> {" ++ nom ++ " = " ++ show (accf rv) ++ " }" ++ "\n" + + return (ec, rv, ed) + +-- | Log a call to a function without a return value. +dbg0 msg inputs (ec,ed) = + do + (a,b,c) <- dbg msg inputs ("unit", id) (ec,(),ed) + return (a,c) + + +-- -------------------------------------------------------------------------------- + +-- | Generate a C file that reproduces a logged interaction with the +-- ArBB VM. This function uses some dangerous heuristics and while +-- it is useful for debugging it should not be relied upon for +-- production purposes. + +makeCReproducer :: [DbgEvent] -> String +makeCReproducer log = render doc +-- do let hndl = stdout +-- hPutStrLn hndl "int main() {" + where + doc = + text "#include " $$ + text "int main() {" $$ + nest 4 (loop M.empty log) $$ + text "}\n" + + loop mp [] = empty + loop mp (DbgStart:tl) = loop mp tl + loop mp (DbgCall oper rands result : tl) = + let + -- rands' = map (text . show . snd) rands + rands' = map (text . dorand) rands + dorand (_,r) = if isPtr r + then case M.lookup r mp of + Nothing -> r + Just name -> name + else r + + (mp2,prefix) = + if isPtr (snd result) + then let counter = M.size mp + name = "v"++ show counter + in + (M.insert (snd result) name mp, + "void* "++name++" = ") + else (mp,"") + in + text prefix <> + text oper <> + parens (hcat$ intersperse comma rands') <> + text ";" $$ + loop mp2 tl + +-- Hackish: +isPtr = isPrefixOf "0x" + +newDBGFile x = + do + b <- doesFileExist dbgfile + if b then removeFile dbgfile else return () + return x + + +printInfo ::(String, String) -> String +printInfo (nom,val) = + "{" ++ nom ++ " = " ++ val ++ " }" + + diff --git a/Intel/ArbbVM/Type.hs b/Intel/ArbbVM/Type.hs new file mode 100644 --- /dev/null +++ b/Intel/ArbbVM/Type.hs @@ -0,0 +1,23 @@ +{- Things that have to do with ArBB types -} + + +module Intel.ArbbVM.Type (size) where + +import Intel.ArbbVM + + +-- size of one element of ArBB scalartype in bytes +size :: ScalarType -> Int +size ArbbI8 = 1 +size ArbbI16 = 2 +size ArbbI32 = 4 +size ArbbI64 = 8 +size ArbbU8 = 1 +size ArbbU16 = 2 +size ArbbU32 = 4 +size ArbbU64 = 8 +size ArbbF32 = 4 +size ArbbF64 = 8 +size ArbbBoolean = 4 -- I think they are stored as 32 bit integers +size ArbbUsize = 4 -- very insecure about the three last here +size ArbbIsize = 4 -- What size are these really ? diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ + +BSD3 Full Text: +-------------------------------------------------------------------------------- + +Copyright (c) 2011, Intel Corporation +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL 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/arbb-vm.cabal b/arbb-vm.cabal new file mode 100644 --- /dev/null +++ b/arbb-vm.cabal @@ -0,0 +1,64 @@ +Name: arbb-vm +Version: 0.1.1.2 + +License: BSD3 +License-file: LICENSE +Stability: Beta +Maintainer: Joel Svensson +Author: Joel Svensson + +Copyright: Copyright (c) 2011 Intel Corporation +Synopsis: FFI binding to the Intel Array Building Blocks (ArBB) virtual machine. +HomePage: git://github.com/svenssonjoel/arbb-vm/wiki +Description: + DESCRIPTION GOES HERE. + +Category: Foreign +Cabal-Version: >=1.8 +Tested-With: GHC == 7.0.1 + +build-type: Simple + +extra-source-files: + examples/tests/Test_DotProd.hs + + +source-repository head + type: git + location: git://github.com/svenssonjoel/arbb-vm.git + +---------------------------------------------------------------------------------------------------- +Library + build-depends: base >= 4 && < 5, haskell98 + , mtl >= 2.0 + , bytestring + , cereal + , directory + , containers + , pretty +-- Having a problem with this [2011.02.27] : +-- , c2hs + + exposed-modules: Intel.ArbbVM + , Intel.ArbbVM.Convenience + , Intel.ArbbVM.Type + other-modules: + C2HS + , Intel.ArbbVM.Debug + + GHC-Options: -O2 +--extra-libraries: tbb, arbb, pthread + include-dirs: /opt/intel/arbb/latest/include + + -- FIXME: How do we read an environment variable? + if arch( x86_64 ) + extra-lib-dirs: /opt/intel/arbb/latest/lib/intel64 + else + extra-lib-dirs: /opt/intel/arbb/latest/lib/ia32 + +-- C-sources: +-- [2011.02.15] Don't need this at the moment because of the arbb_alt hack: +-- cbits/arbb_vmwrap.c +-- , cbits/arbb_vmwrap.h + +-- Include-Dirs: cbits diff --git a/examples/tests/Test_DotProd.hs b/examples/tests/Test_DotProd.hs new file mode 100644 --- /dev/null +++ b/examples/tests/Test_DotProd.hs @@ -0,0 +1,63 @@ + +-- ----------------------------------------------------------------------------- +-- Test_DotProd + +import Intel.ArbbVM + +import Foreign.Marshal.Array +import Foreign.Ptr + +import C2HS + +len = 2^22-1 + +main = do + ctx <- getDefaultContext + st <- getScalarType ctx ArbbF32 + t <- getDenseType ctx st 1 + fnt <- getFunctionType ctx [t] [t,t] + myfun <- beginFunction ctx fnt "sum" 0 + a <- getParameter myfun 0 0 + b <- getParameter myfun 0 1 + c <- getParameter myfun 1 0 + + tmp <- createLocal myfun t "tmp" + + op myfun ArbbOpMul [tmp] [a,b] + + opDynamic myfun ArbbOpAddReduce [c] [tmp] + endFunction myfun + --compile myfun + binding <- getBindingNull + -- This part gets messy! + -- TODO: Clean up! + withArray [1.0 :: Float | _ <- [0..len]] $ \ i1 -> + withArray [1.0 :: Float | _ <- [0..len]] $ \ i2 -> + withArray [0 :: Float] $ \ o -> + do + + b1 <- createDenseBinding ctx (castPtr i1) 1 [len] [4] + b2 <- createDenseBinding ctx (castPtr i2) 1 [len] [4] + b3 <- createDenseBinding ctx (castPtr o) 1 [1] [4] + + + g1 <- createGlobal ctx t "in1" b1 + g2 <- createGlobal ctx t "in2" b2 + g3 <- createGlobal ctx t "out" b3 + + v1 <- variableFromGlobal ctx g1 + v2 <- variableFromGlobal ctx g2 + v3 <- variableFromGlobal ctx g3 + + --r <- createGlobal ctx t "result" binding + --v2 <- variableFromGlobal ctx r + + execute myfun [v3] [v1,v2] + str <- serializeFunction myfun + putStrLn (getCString str) + + -- access result + result <- peekArray 1 (castPtr o :: Ptr Float) + putStrLn $ show $ result + +