arbb-vm (empty) → 0.1.1.2
raw patch · 9 files changed
+2240/−0 lines, 9 filesdep +basedep +bytestringdep +cerealsetup-changed
Dependencies added: base, bytestring, cereal, containers, directory, haskell98, mtl, pretty
Files
- C2HS.hs +220/−0
- Intel/ArbbVM.chs +878/−0
- Intel/ArbbVM/Convenience.hs +707/−0
- Intel/ArbbVM/Debug.hs +255/−0
- Intel/ArbbVM/Type.hs +23/−0
- LICENSE +28/−0
- Setup.hs +2/−0
- arbb-vm.cabal +64/−0
- examples/tests/Test_DotProd.hs +63/−0
+ C2HS.hs view
@@ -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
+ Intel/ArbbVM.chs view
@@ -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 <arbb_vmapi.h>+-- ----------------------------------------------------------------------++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
+ Intel/ArbbVM/Convenience.hs view
@@ -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 = "<ArBB_Var>"++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)
+ Intel/ArbbVM/Debug.hs view
@@ -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 <stdio.h>" $$ + 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 ++ " }"++
+ Intel/ArbbVM/Type.hs view
@@ -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 ?
+ LICENSE view
@@ -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 <organization> 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 <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ arbb-vm.cabal view
@@ -0,0 +1,64 @@+Name: arbb-vm+Version: 0.1.1.2++License: BSD3+License-file: LICENSE+Stability: Beta+Maintainer: Joel Svensson<svensson.bj@gmail.com>+Author: Joel Svensson<svensson.bj@gmail.com>++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
+ examples/tests/Test_DotProd.hs view
@@ -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+ +