accelerate-llvm (empty) → 1.0.0.0
raw patch · 55 files changed
+8549/−0 lines, 55 filesdep +abstract-dequedep +acceleratedep +basesetup-changed
Dependencies added: abstract-deque, accelerate, base, chaselev-deque, containers, data-default-class, dlist, exceptions, fclabels, llvm-hs, llvm-hs-pure, mtl, mwc-random, unordered-containers, vector
Files
- Control/Parallel/Meta.hs +222/−0
- Control/Parallel/Meta/Resource/Backoff.hs +89/−0
- Control/Parallel/Meta/Resource/SMP.hs +119/−0
- Control/Parallel/Meta/Resource/Single.hs +33/−0
- Control/Parallel/Meta/Trans/LBS.hs +130/−0
- Control/Parallel/Meta/Worker.hs +229/−0
- Data/Array/Accelerate/LLVM/Analysis/Match.hs +41/−0
- Data/Array/Accelerate/LLVM/Array/Data.hs +382/−0
- Data/Array/Accelerate/LLVM/CodeGen.hs +139/−0
- Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs +683/−0
- Data/Array/Accelerate/LLVM/CodeGen/Array.hs +82/−0
- Data/Array/Accelerate/LLVM/CodeGen/Base.hs +204/−0
- Data/Array/Accelerate/LLVM/CodeGen/Constant.hs +81/−0
- Data/Array/Accelerate/LLVM/CodeGen/Downcast.hs +455/−0
- Data/Array/Accelerate/LLVM/CodeGen/Environment.hs +91/−0
- Data/Array/Accelerate/LLVM/CodeGen/Exp.hs +438/−0
- Data/Array/Accelerate/LLVM/CodeGen/IR.hs +324/−0
- Data/Array/Accelerate/LLVM/CodeGen/Intrinsic.hs +71/−0
- Data/Array/Accelerate/LLVM/CodeGen/Loop.hs +140/−0
- Data/Array/Accelerate/LLVM/CodeGen/Module.hs +43/−0
- Data/Array/Accelerate/LLVM/CodeGen/Monad.hs +424/−0
- Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot +18/−0
- Data/Array/Accelerate/LLVM/CodeGen/Permute.hs +336/−0
- Data/Array/Accelerate/LLVM/CodeGen/Ptr.hs +65/−0
- Data/Array/Accelerate/LLVM/CodeGen/Skeleton.hs +263/−0
- Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs +310/−0
- Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs +84/−0
- Data/Array/Accelerate/LLVM/CodeGen/Type.hs +188/−0
- Data/Array/Accelerate/LLVM/Compile.hs +375/−0
- Data/Array/Accelerate/LLVM/Execute.hs +489/−0
- Data/Array/Accelerate/LLVM/Execute/Async.hs +85/−0
- Data/Array/Accelerate/LLVM/Execute/Environment.hs +47/−0
- Data/Array/Accelerate/LLVM/Execute/Marshal.hs +102/−0
- Data/Array/Accelerate/LLVM/Foreign.hs +40/−0
- Data/Array/Accelerate/LLVM/State.hs +61/−0
- Data/Array/Accelerate/LLVM/Target.hs +29/−0
- Data/Array/Accelerate/LLVM/Util.hs +51/−0
- Data/Range/Range.hs +184/−0
- LICENSE +23/−0
- LLVM/AST/Type/AddrSpace.hs +29/−0
- LLVM/AST/Type/Constant.hs +41/−0
- LLVM/AST/Type/Flags.hs +38/−0
- LLVM/AST/Type/Global.hs +55/−0
- LLVM/AST/Type/Instruction.hs +319/−0
- LLVM/AST/Type/Instruction/Atomic.hs +44/−0
- LLVM/AST/Type/Instruction/Compare.hs +18/−0
- LLVM/AST/Type/Instruction/RMW.hs +29/−0
- LLVM/AST/Type/Instruction/Volatile.hs +26/−0
- LLVM/AST/Type/Metadata.hs +32/−0
- LLVM/AST/Type/Name.hs +72/−0
- LLVM/AST/Type/Operand.hs +29/−0
- LLVM/AST/Type/Representation.hs +429/−0
- LLVM/AST/Type/Terminator.hs +56/−0
- Setup.hs +2/−0
- accelerate-llvm.cabal +160/−0
+ Control/Parallel/Meta.hs view
@@ -0,0 +1,222 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Control.Parallel.Meta+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Control.Parallel.Meta (++ WorkSearch(..),+ Resource(..),+ Executable(..),+ Action,+ runSeqIO, runParIO,++) where++import Control.Monad+import Control.Parallel.Meta.Worker+import Data.Concurrent.Deque.Class+import Data.Monoid+import Data.Sequence ( Seq )+import Data.Range.Range as R+import qualified Data.Vector as V++import GHC.Base ( quotInt, remInt )+++-- | The 'Startup' component of a 'Resource' is a callback that implements+-- initialisation behaviour. For example, it might contact remote hosts, spawn+-- threads, or initialise hardware such as GPUs.+--+data Startup = Startup {+ _runStartup :: Gang -> IO () }++instance Monoid Startup where+ mempty = Startup $ \_ -> return ()+ Startup st1 `mappend` Startup st2 = Startup $ \g -> st1 g >> st2 g+++-- | The 'WorkSearch' component of a 'Resource' is a callback that responds to+-- requests for work from meta-workers. The arguments to 'WorkSearch' are the+-- scheduler state for the current thread and a reference to all workers in the+-- program.+--+data WorkSearch = WorkSearch {+ runWorkSearch :: Int -> Workers -> IO (Maybe Range) }++instance Monoid WorkSearch where+ mempty = WorkSearch $ \_ _ -> return Nothing+ WorkSearch ws1 `mappend` WorkSearch ws2 =+ WorkSearch $ \tid st -> do+ mwork <- ws1 tid st+ case mwork of+ Nothing -> ws2 tid st+ _ -> return mwork+++-- | A 'Resource' provides an abstraction of heterogeneous execution resources+-- that may be combined. Composition of resources is left-biased. That is, if if+-- @resource1@ always returns work from its 'WorkSearch', then the composed+-- resource @resource1 <> resource2@ will never request work from @resource2@.+--+data Resource = Resource {+ -- startup :: Startup+ workSearch :: WorkSearch+ }++instance Monoid Resource where+ mempty = Resource mempty+ mappend (Resource ws1) (Resource ws2) = Resource (ws1 <> ws2)+++-- | An action to execute. The first parameters are the start and end indices of+-- the range this action should process, and the final is the ID of the thread+-- doing the work.+--+type Action = Int -> Int -> Int -> IO ()+-- data Action = Action {+-- runAction :: Int -> Int -> Int -> IO }+-- }++-- instance Monoid Action where+-- mempty = Action $ \_ _ _ -> return ()+-- Action f1 `mappend` Action f2 = Action $ \m n i -> f1 m n i >> f1 m n i+++-- | An 'Executable' provides a callback that can be used to run a provided+-- function using an encapsulated work-stealing gang of threads.+--+data Executable = Executable {+ runExecutable+ :: String -- Function name+ -> Int -- Profitable parallelism threshold (PPT)+ -> Range -- The range to execute over+ -> Action -- The main function to execute+ -> IO ()+ }+++-- | The 'Finalise' component of an executable is an action the thread applies+-- after processing the work function, given its thread id the ranges that this+-- thread actually handled.+--+data Finalise = Finalise {+ _runFinalise :: Seq Range -> IO ()+ }++instance Monoid Finalise where+ mempty = Finalise $ \_ -> return ()+ Finalise f1 `mappend` Finalise f2 = Finalise $ \r -> f1 r >> f2 r++++-- | Run a sequential operation+--+-- We just have the first thread of the gang execute the operation, but we could+-- also make the threads compete, which might be useful on a loaded system.+--+runSeqIO+ :: Gang+ -> Range+ -> Action+ -> IO ()+runSeqIO _ Empty _ = return ()+runSeqIO gang (IE u v) action =+ gangIO gang $ \workers ->+ workerIO workers $ \thread ->+ when (thread == 0) $ action u v thread+ -- let+ -- target = V.unsafeIndex workers 0+ -- loop 0 = return ()+ -- loop n = do+ -- mwork <- tryPopR (workpool target)+ -- case mwork of+ -- Nothing -> loop (n-1)+ -- Just Empty -> return ()+ -- Just (IE u v) -> action u v thread+ -- --+ -- when (thread == 0) $ pushL (workpool target) range+ -- loop 3+++-- | Run a parallel work-stealing operation.+--+-- Each thread initialises its work queue with an equally sized chunk of the+-- work. Threads keep working until their work search returns Nothing, at which+-- point the thread exits. In our LBS implementation, a worker thread takes a+-- small chunk of its work range to process, and places the remainder back onto+-- its deque. Thus the work queues are only empty:+--+-- (a) Briefly during the scheduling process; or+--+-- (b) After the deque has been robbed. If the stolen chunk is large enough,+-- the stealee will split the remainder onto its deque to be stolen; or+--+-- (c) There is no more work.+--+-- As long as the thread makes a small number of retries, this should correctly+-- balance the work without too much scheduler overhead.+--+-- An alternative to every thread initialising with an even chunk size is to put+-- the entire range onto the first worker and then have the scheduler handle the+-- decomposition. However, this method should be better for locality,+-- particularly when the workloads are balanced and little stealing occurs.+--+-- TLM: Should threads check whether the work queues of all threads are empty+-- before deciding to exit? If the PPT is too large then threads might not+-- react quickly enough to splitting once their deque is emptied. Maybe the+-- first thread to return Nothing can probe the queues to see if they are+-- all empty. If True, write into a shared MVar to signal to the others+-- that it is time to exit. But, that still assumes that the PPT is not so+-- large that the queues are always empty.+--+-- TLM: The initial work distribution should probably be aligned to cache+-- boundaries, rather than attempting to split exactly evenly.+--+runParIO+ :: Resource+ -> Gang+ -> Range+ -> Action+ -> IO ()+runParIO _ _ Empty _ = return ()+runParIO resource gang (IE inf sup) action =+ gangIO gang $ \workers ->+ workerIO workers $ \tid -> do+ let+ len = sup - inf+ threads = V.length workers+ chunk = len `quotInt` threads+ leftover = len `remInt` threads++ start = splitIx tid+ end = splitIx (tid + 1)+ me = V.unsafeIndex workers tid++ splitIx n | n < leftover = inf + n * (chunk + 1)+ splitIx n = inf + n * chunk + leftover++ loop = do+ work <- runWorkSearch (workSearch resource) tid workers+ case work of+ -- Got a work unit. Execute it then search for more.+ Just (IE u v) -> action u v tid >> loop++ -- If the work search failed (which is random), to be extra safe+ -- make sure all the work queues are exhausted before exiting.+ _ -> do+ done <- exhausted workers+ if done+ then return ()+ else loop++ when (end > start) $ pushL (workpool me) (IE start end)+ loop+
+ Control/Parallel/Meta/Resource/Backoff.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Control.Parallel.Meta.Resource.Backoff+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module implements exponential backoff so as to prevent spamming of+-- stealing actions. Most scheduler compositions should include this at the+-- bottom of the stack.+--+-- Inspired by the meta-par package. This package has a BSD license.+-- <http://hackage.haskell.org/package/meta-par>+--++module Control.Parallel.Meta.Resource.Backoff (++ mkResource,+ defaultWorkSearch, mkWorkSearch,++) where++import Control.Concurrent+import Data.IORef+import Text.Printf++import Control.Parallel.Meta+import Control.Parallel.Meta.Worker+import Data.Range.Range as R+import qualified Data.Vector as V+import qualified Data.Array.Accelerate.Debug as Debug+++mkResource :: Resource+mkResource = Resource defaultWorkSearch++defaultWorkSearch :: WorkSearch+defaultWorkSearch = mkWorkSearch 100 10000+++-- | To construct the work search, we need to know the minimum and maximum+-- amount of time, in nanoseconds, to sleep. The exponential backoff policy is+-- always the same: it starts at 1µs and doubles at every failure.+--+-- The thing that changes over time is whether sleeping actually occurs. For+-- example, the 'defaultWorkSearch':+--+-- > mkWorkSearch 100 10000+--+-- will not sleep for the first 7 invocations (until 128), and then will sleep+-- an amount that doubles each time until it surpasses the maximum, at which+-- point it will always sleep for the maximum time (10ms)+--+mkWorkSearch :: Int -> Int -> WorkSearch+mkWorkSearch _ 0 = WorkSearch $ \_ _ -> return Nothing+mkWorkSearch shortest longest = WorkSearch backoff+ where+ backoff :: Int -> Workers -> IO (Maybe Range)+ backoff tid workers = do+ let Worker{..} = V.unsafeIndex workers tid+ failed <- readIORef consecutiveFailures+ let sleep = min longest (2 ^ failed)+ if sleep >= shortest+ then do+ message workerId (printf "sleeping for %d µs" sleep)+ threadDelay sleep++ else do+ message workerId "not sleeping"+ return ()++ return Nothing+++-- Debugging+-- ---------++{-# INLINE message #-}+message :: Int -> String -> IO ()+message tid msg+ = Debug.when Debug.verbose+ $ Debug.traceIO Debug.dump_sched (printf "sched/backoff: [%d] %s" tid msg)+
+ Control/Parallel/Meta/Resource/SMP.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Control.Parallel.Meta.Resource.SMP+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module implements a resource for SMP parallelism. It is suitable as a+-- base for combining a bunch of resources that can steal cheaply from each+-- other.+--+-- Inspired by the meta-par package. This package has a BSD license.+-- <http://hackage.haskell.org/package/meta-par>+--++module Control.Parallel.Meta.Resource.SMP (++ mkResource,+ mkWorkSearch,++) where++-- accelerate+import Data.Range.Range+import Control.Parallel.Meta+import Control.Parallel.Meta.Worker++import qualified Data.Array.Accelerate.Debug as Debug++-- standard library+import Data.Concurrent.Deque.Class+import Data.IORef+import System.Random.MWC+import Text.Printf+import qualified Data.Vector as V+++-- | Create an SMP (symmetric multiprocessor) resource where all underlying+-- workers have uniform access to shared resources such as memory. Thus workers+-- at this level can steal cheaply from each other.+--+mkResource+ :: Int -- ^ number of steal attempts per 'WorkSearch'+ -> Resource+mkResource retries =+ Resource (mkWorkSearch retries)+++-- | Given a set of workers and a number of steal attempts per worker, return a+-- work search function. Steals from workers in this gang are considered cheap+-- and uniform.+--+-- Note: [Number of retries in SMP resource]+--+-- A large number of retries in the work search will prevent the search function+-- from traversing the resource stack. This can result in spamming of stealing+-- actions. In particular, the exponential backoff resource usually placed at+-- the bottom of the stack may never be reached. Thus a balance is required+-- between number of times to traverse each level and number of times to+-- traverse the entire resource stack.+--+mkWorkSearch :: Int -> WorkSearch+mkWorkSearch retries = WorkSearch search+ where+ search :: Int -> Workers -> IO (Maybe Range)+ search !tid !workers =+ let+ me = V.unsafeIndex workers tid+ myId = workerId me+ random = uniformR (0, V.length workers - 1) (rngState me)++ loop 0 = do+ message myId "work search failed"+ modifyIORef' (consecutiveFailures me) (+1)+ return Nothing++ loop n = do+ target <- V.unsafeIndex workers `fmap` random+ if workerId target == myId+ then loop (n-1)+ else do+ mwork <- tryPopR (workpool target)+ case mwork of+ Nothing -> loop (n-1)+ _ -> do event myId (printf "steal from %d" (workerId target))+ writeIORef (consecutiveFailures me) 0+ return mwork+ in+ loop retries+-- self <- tryPopL (workpool me)+-- case self of+-- Nothing -> loop retries+-- _ -> do message myId "steal from self"+-- writeIORef (consecutiveFailures me) 0+-- return self+++-- Debugging+-- ---------++{-# INLINE message #-}+message :: Int -> String -> IO ()+message tid msg+ = Debug.when Debug.verbose+ $ Debug.traceIO Debug.dump_sched (printf "sched/smp: [%d] %s" tid msg)++{-# INLINE event #-}+event :: Int -> String -> IO ()+event tid msg = do+ let msg' = printf "sched/smp: [%d] %s" tid msg+ Debug.traceIO Debug.dump_sched msg'+ Debug.traceEventIO Debug.dump_sched msg'+
+ Control/Parallel/Meta/Resource/Single.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Control.Parallel.Meta.Resource.Single+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Control.Parallel.Meta.Resource.Single+ where++-- accelerate+import Control.Parallel.Meta+import Control.Parallel.Meta.Worker++-- library+import Data.Concurrent.Deque.Class+import qualified Data.Vector as V+++-- | Create a resource where each thread works in isolation. The resource is not+-- aware of any other sources of work (at this level) and only ever tries to pop+-- from its own local queue.+--+mkResource :: Resource+mkResource+ = Resource+ $ WorkSearch $ \tid workers -> tryPopL (workpool (V.unsafeIndex workers tid))+
+ Control/Parallel/Meta/Trans/LBS.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Control.Parallel.Meta.Resource.LBS+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module implements a lazy binary splitting resource transformer. It is+-- suitable to add an adaptive runtime work-stealing component to resource.+--++module Control.Parallel.Meta.Trans.LBS (++ mkResource,+ mkWorkSearch,++) where++import Control.Parallel.Meta+import Control.Parallel.Meta.Worker+import Data.Concurrent.Deque.Class+import Data.Range.Range ( Range )+import qualified Data.Range.Range as R+import qualified Data.Array.Accelerate.Debug as Debug++import Control.Monad+import Text.Printf+import qualified Data.Vector as V+++-- | Transform the 'WorkSearch' function of the given 'Resource' to include a+-- lazy binary splitting work stealing scheduler.+--+mkResource+ :: Int -- ^ profitable parallelism threshold+ -> Resource -- ^ the resource to modify+ -> Resource+mkResource ppt (Resource ws)+ = Resource (mkWorkSearch ppt ws)+++-- | This transforms the 'WorkSearch' function to add a lazy binary splitting+-- operation on top of an existing (work-stealing) scheduler. On receiving a+-- unit of work, the scheduler proceeds as follows:+--+-- 1. If the number of iterations is less than the profitable parallelism+-- threshold (ppt), execute the remaining iterations and exit, else (2).+--+-- 2. Check this worker's remaining work queue. If it is not empty, then+-- execute ppt iterations, then go to (1) with the remainder.+--+-- 3. If the remaining work queue is empty, split this work chunk in half.+-- Place the second half onto the remaining work queue and go to (1).+--+mkWorkSearch+ :: Int -- ^ profitable parallelism threshold+ -> WorkSearch -- ^ the basic work search method to modify+ -> WorkSearch+mkWorkSearch ppt steal = WorkSearch search+ where+ search :: Int -> Workers -> IO (Maybe Range)+ search tid workers = do+ let Worker{..} = V.unsafeIndex workers tid++ -- Look for some work to do. If there is work on the local queue, take+ -- that first before trying to steal from the neighbours.+ --+ self <- tryPopL workpool+ work <- case self of+ Nothing -> runWorkSearch steal tid workers+ Just _ -> return self++ -- Once we have some work, take the first ppt elements (which we will+ -- return so that they are processed next) and decide what do do with+ -- the remainder:+ --+ -- 1. If the deque is not empty OR the remainder is less than the PPT,+ -- push it back without splitting.+ --+ -- 2. If our deque is empty, split it in half and push both pieces+ -- back onto the deque.+ --+ -- This strategy avoids excessive splitting, especially in the case+ -- where this worker steals back the remainder from itself.+ --+ case work of+ Just r | not (R.null r) -> do+ let (this, rest) = R.splitAt ppt r+ handleRemainder+ | R.null rest = return ()++ | R.size rest < ppt = do+ message workerId (printf "not splitting remainder (size %d < ppt %d)" (R.size rest) ppt)+ pushL workpool rest++ | otherwise = do+ empty <- nullQ workpool+ if not empty+ then do+ message workerId (printf "not splitting remainder %s (deque not empty)" (show rest))+ pushL workpool rest++ else do+ let (l,u) = R.bisect rest+ message workerId (printf "splitting remainder %s -> %s, %s" (show rest) (show l) (show u))+ unless (R.null u) $ pushL workpool u+ pushL workpool l+ --+ message workerId (printf "got work range %s" (show this))+ handleRemainder+ return (Just this)++ _ -> message workerId "work search failed" >> return Nothing+++-- Debugging+-- ---------++{-# INLINE message #-}+message :: Int -> String -> IO ()+message tid msg+ = Debug.when Debug.verbose+ $ Debug.traceIO Debug.dump_sched (printf "sched/lbs: [%d] %s" tid msg)+
+ Control/Parallel/Meta/Worker.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Control.Parallel.Meta.Worker+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Control.Parallel.Meta.Worker (++ Gang, Workers, Worker(..), Req(..),+ gangIO, forkGang, forkGangOn, workerIO, exhausted,++) where++-- accelerate+import qualified Data.Array.Accelerate.Debug as Debug++-- standard library+import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.IORef+import Data.Range.Range+import Data.Vector ( Vector )+import System.IO.Unsafe+import System.Random.MWC ( GenIO, createSystemRandom )+import Text.Printf+import Prelude+import qualified Data.Vector as V++import Data.Concurrent.Deque.Class+#ifdef CHASELEV_DEQUE+import Data.Concurrent.Deque.ChaseLev.DequeInstance ()+#else+import Data.Concurrent.Deque.Reference.DequeInstance ()+#endif+++-- | The 'Gang' structure tracks the state of all workers in the program. It+-- starts empty, and workers append to it as they are brought online. Although+-- the vector append operation is expensive, it is expected it is only called+-- occasionally; e.g. at program initialisation. So, we prioritise for constant+-- lookup of the worker structure, which will be done frequently during the work+-- search.+--+type Gang = MVar Workers+type Workers = Vector Worker+++-- | The 'Worker' is the per-worker-thread state.+--+-- If the worker has work that can be stolen by other processors, it is stored+-- in the 'workpool'. Thieves treat the workpool as a stack which can be popped+-- on the right, where as the owner can both push and pop on the left.+--+-- In the lazy binary splitting work stealing setup, a worker processes its+-- range in chunks, checking the state of its workpool periodically. Whenever+-- the queue is empty, it splits it's current workload in two so that the second+-- half can be stolen by another processor.+--+data Worker = Worker {+ workerId :: {-# UNPACK #-} !Int++ -- Coordinating with the host thread+ , requestVar :: {-# UNPACK #-} !(MVar Req)+ , resultVar :: {-# UNPACK #-} !(MVar ())++ -- Work scheduling+ , workpool :: {-# UNPACK #-} !(WSDeque Range)+ , consecutiveFailures :: {-# UNPACK #-} !(IORef Int)+ , rngState :: {-# UNPACK #-} !GenIO -- don't unpack: too large?++ -- TODO: debug/work statistics+ }++instance Eq Worker where+ w1 == w2 = workerId w1 == workerId w2+++-- | The 'Req' type encapsulates work requests for individual workers+--+data Req+ -- | Instruct the worker to run the given action+ = ReqDo (Int -> IO ())++ -- | Tell the worker to exit. The worker should signal that it received the+ -- request by writing its result var before exiting.+ | ReqShutdown+++-- A global name supply. This is not strictly necessary, but useful for ensuring+-- that each worker thread has a unique identifier. We can't just use the+-- threadId the worker is spawned on, because we might have multiple work groups+-- (i.e. for CPUs and GPUs)+--+{-# NOINLINE uniqueSupply #-}+uniqueSupply :: IORef Int+uniqueSupply = unsafePerformIO $ newIORef 0++-- Generate a fresh identifier. Note that the bang pattern is important.+freshId :: IO Int+freshId = atomicModifyIORef uniqueSupply (\n -> let !n' = n+1 in (n', n))+++-- | Create a set of workers. This is a somewhat expensive function, so it is+-- expected that it is called only occasionally (e.g. once per program+-- execution).+--+forkGang :: Int -> IO Gang+forkGang n = forkGangOn [0..n-1]+++-- | Create a set of workers on specific capabilities. Note that the thread ID+-- passed to the 'gangWorker' is the index of this worker in the gang structure,+-- not necessarily the capability is is spawned on.+--+forkGangOn :: [Int] -> IO Gang+forkGangOn caps = do+ ws <- V.forM (V.indexed (V.fromList caps)) $ \(i, cap) -> do+ worker <- Worker <$> freshId -- identifier+ <*> newEmptyMVar -- work request+ <*> newEmptyMVar -- work complete+ <*> newQ -- work stealing deque+ <*> newIORef 0 -- consecutive steal failure count+ <*> createSystemRandom -- random generator for stealing+ --+ message (printf "fork %d on capability %d" (workerId worker) cap)+ void $ mkWeakMVar (requestVar worker) (finaliseWorker worker)+ void $ forkOn cap $ gangWorker i worker+ return worker+ newMVar ws+++-- | The main worker loop for a thread in the gang.+--+-- Threads block on the MVar waiting for work requests, until told to exit.+--+gangWorker :: Int -> Worker -> IO ()+gangWorker threadId st@Worker{..} = do++ -- Wait for a request+ req <- takeMVar requestVar++ case req of+ ReqShutdown ->+ putMVar resultVar () -- signal that we got the shutdown order++ ReqDo action -> do+ action threadId -- Run the action we were given+ putMVar resultVar () -- Signal that the action is complete+ gangWorker threadId st -- Wait for more requests+++-- | Gain control of the gang and use it to do some work+--+gangIO :: Gang -> (Workers -> IO ()) -> IO ()+gangIO = withMVar++-- | Issue work requests to the threads and wait until they complete+--+workerIO :: Workers -> (Int -> IO ()) -> IO ()+workerIO workers action = mask $ \restore -> do+ main <- myThreadId++ -- Send requests to the threads+ V.forM_ workers $ \Worker{..} -> do+ writeIORef consecutiveFailures 0+ putMVar requestVar $ ReqDo (reflectExceptionsTo main . restore . action)++ -- Wait for all requests to complete+ V.forM_ workers $ \Worker{..} -> takeMVar resultVar++reflectExceptionsTo :: ThreadId -> IO () -> IO ()+reflectExceptionsTo tid action =+ catchNonThreadKilled action (throwTo tid)++catchNonThreadKilled :: IO a -> (SomeException -> IO a) -> IO a+catchNonThreadKilled action handler =+ action `catch` \e ->+ case fromException e of+ Just ThreadKilled -> throwIO e+ _ -> handler e+++-- | The finaliser for worker threads.+--+-- Without this programs can complain about "Blocked indefinitely on an MVar"+-- because worker threads are still blocked on the request MVars when the+-- program ends. Whether the finalizer is called or not is very racey.+--+-- We're relying on the comment in System.Mem.Weak that says:+--+-- "If there are no other threads to run, the runtime system will check for+-- runnable finalizers before declaring the system to be deadlocked."+--+-- If we were creating and destroying the gang cleanly we wouldn't need this,+-- but 'theGang' is created with a top-level unsafePerformIO. Hacks beget hacks+-- beget hacks...+--+finaliseWorker :: Worker -> IO ()+finaliseWorker Worker{..} = do+ message (printf "worker %d shutting down" workerId)+ putMVar requestVar ReqShutdown+ takeMVar resultVar+++-- | Check whether the work queues of all workers in a gang are empty+--+exhausted :: Workers -> IO Bool+exhausted workers =+ V.and <$> V.mapM (\Worker{..} -> nullQ workpool) workers+++-- Debugging+-- ---------++{-# INLINE message #-}+message :: String -> IO ()+message msg = Debug.traceIO Debug.dump_sched ("gang: " ++ msg)+
+ Data/Array/Accelerate/LLVM/Analysis/Match.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Analysis.Match+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Analysis.Match (++ module Data.Array.Accelerate.Analysis.Match,+ module Data.Array.Accelerate.LLVM.Analysis.Match,++) where++import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Sugar++import Data.Typeable+++-- Match reified shape types+--+matchShapeType+ :: forall sh sh'. (Shape sh, Shape sh')+ => sh+ -> sh'+ -> Maybe (sh :~: sh')+matchShapeType _ _+ | Just Refl <- matchTupleType (eltType (undefined::sh)) (eltType (undefined::sh'))+ = gcast Refl++matchShapeType _ _+ = Nothing+
+ Data/Array/Accelerate/LLVM/Array/Data.hs view
@@ -0,0 +1,382 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Array.Data+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Array.Data (++ Remote(..),+ newRemote,+ useRemote, useRemoteAsync,+ copyToRemote, copyToRemoteAsync,+ copyToHost, copyToHostAsync,+ copyToPeer, copyToPeerAsync,++ runIndexArray,+ runArrays,+ runArray,++ module Data.Array.Accelerate.Array.Data,++) where++-- accelerate+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Sugar++import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.Execute.Async++-- standard library+import Control.Monad ( liftM, liftM2 )+import Control.Monad.Trans+import Data.Typeable+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable+import Prelude+++class Async arch => Remote arch where++ -- | Allocate a new uninitialised array on the remote device.+ --+ {-# INLINEABLE allocateRemote #-}+ allocateRemote :: (Shape sh, Elt e) => sh -> LLVM arch (Array sh e)+ allocateRemote sh = liftIO $ allocateArray sh++ -- | Use the given immutable array on the remote device. Since the source+ -- array is immutable, the allocator can evict and re-upload the data as+ -- necessary without copy-back.+ --+ {-# INLINEABLE useRemoteR #-}+ useRemoteR+ :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e)+ => Int -- ^ number of elements in the payload+ -> Maybe (StreamR arch) -- ^ execute synchronously w.r.t. this execution stream+ -> ArrayData e -- ^ array payload+ -> LLVM arch ()+ useRemoteR _ _ _ = return ()++ -- | Upload a section of an array from the host to the remote device. Only the+ -- elements between the given indices (inclusive left, exclusive right) are+ -- transferred.+ --+ {-# INLINEABLE copyToRemoteR #-}+ copyToRemoteR+ :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e)+ => Int -- ^ index of first element to copy+ -> Int+ -> Maybe (StreamR arch) -- ^ execute synchronously w.r.t. this execution stream+ -> ArrayData e -- ^ array payload+ -> LLVM arch ()+ copyToRemoteR _ _ _ _ = return ()++ -- | Copy a section of an array from the remote device back to the host. The+ -- elements between the given indices (inclusive left, exclusive right) are+ -- transferred.,v+ --+ {-# INLINEABLE copyToHostR #-}+ copyToHostR+ :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e)+ => Int -- ^ index of the first element to copy+ -> Int+ -> Maybe (StreamR arch) -- ^ execute synchronously w.r.t. this execution stream+ -> ArrayData e -- ^ array payload+ -> LLVM arch ()+ copyToHostR _ _ _ _ = return ()++ -- | Copy a section of an array between two remote instances of the same type.+ -- This may be more efficient than copying to the host and then to the second+ -- remote instance (e.g. DMA between two CUDA devices). The elements between+ -- the given indices (inclusive left, exclusive right) are transferred.+ --+ {-# INLINEABLE copyToPeerR #-}+ copyToPeerR+ :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e)+ => Int -- ^ index of the first element to copy+ -> Int+ -> arch -- ^ remote device to copy to+ -> Maybe (StreamR arch) -- ^ execute synchronously w.r.t. this execution stream+ -> ArrayData e -- ^ array payload+ -> LLVM arch ()+ copyToPeerR _ _ _ _ _ = return ()++ -- | Read a single element from the array at a given row-major index+ --+ {-# INLINEABLE indexRemote #-}+ indexRemote :: Array sh e -> Int -> LLVM arch e+ indexRemote (Array _ adata) i = return . toElt $! unsafeIndexArrayData adata i+++-- | Create a new array from its representation on the host, and upload it to+-- a new remote array.+--+{-# INLINEABLE newRemote #-}+newRemote+ :: (Remote arch, Shape sh, Elt e)+ => sh+ -> (sh -> e)+ -> LLVM arch (Array sh e)+newRemote sh f =+ useRemote $! fromFunction sh f+++-- | Upload an immutable array from the host to the remote device. This is+-- a synchronous operation in that it will not return until the transfer+-- completes, but the individual array payloads will be uploaded concurrently if+-- possible.+--+{-# INLINEABLE useRemote #-}+useRemote :: (Remote arch, Arrays arrs) => arrs -> LLVM arch arrs+useRemote arrs = do+ AsyncR _ a <- async (useRemoteAsync arrs)+ get a+++-- | Upload an immutable array from the host to the remote device,+-- asynchronously. This will upload each array payload in a separate execution+-- stream, thereby making us of multiple memcpy engines (where available).+--+{-# INLINEABLE useRemoteAsync #-}+useRemoteAsync+ :: (Remote arch, Arrays arrs)+ => arrs+ -> StreamR arch+ -> LLVM arch (AsyncR arch arrs)+useRemoteAsync arrs stream = do+ arrs' <- runArrays arrs $ \arr@Array{} ->+ let n = size (shape arr)+ in runArray arr $ \ad -> do+ s <- fork+ useRemoteR n (Just s) ad+ after stream =<< checkpoint s+ join s+ return ad+ --+ event <- checkpoint stream -- TLM: Assuming that adding events to a stream counts as things to wait for+ return $! AsyncR event arrs'+++-- | Uploading existing arrays from the host to the remote device. This is+-- synchronous with respect to the calling thread, but the individual array+-- payloads may themselves be transferred concurrently.+--+{-# INLINEABLE copyToRemote #-}+copyToRemote :: (Remote arch, Arrays a) => a -> LLVM arch a+copyToRemote arrs = do+ AsyncR _ a <- async (copyToRemoteAsync arrs)+ get a+++-- | Upload an existing array to the remote device, asynchronously.+--+{-# INLINEABLE copyToRemoteAsync #-}+copyToRemoteAsync+ :: (Remote arch, Arrays a)+ => a+ -> StreamR arch+ -> LLVM arch (AsyncR arch a)+copyToRemoteAsync arrs stream = do+ arrs' <- runArrays arrs $ \arr@Array{} ->+ let n = size (shape arr)+ in runArray arr $ \ad -> do+ s <- fork+ copyToRemoteR 0 n (Just s) ad+ after stream =<< checkpoint s+ join s+ return ad+ --+ event <- checkpoint stream+ return $! AsyncR event arrs'+++-- | Copy an array from the remote device to the host. This is synchronous with+-- respect to the calling thread, but the individual array payloads may+-- themselves be transferred concurrently.+--+{-# INLINEABLE copyToHost #-}+copyToHost :: (Remote arch, Arrays a) => a -> LLVM arch a+copyToHost arrs = do+ AsyncR _ a <- async (copyToHostAsync arrs)+ get a+++-- | Copy an array from the remote device to the host, asynchronously+--+{-# INLINEABLE copyToHostAsync #-}+copyToHostAsync+ :: (Remote arch, Arrays a)+ => a+ -> StreamR arch+ -> LLVM arch (AsyncR arch a)+copyToHostAsync arrs stream = do+ arrs' <- runArrays arrs $ \arr@Array{} ->+ let n = size (shape arr)+ in runArray arr $ \ad -> do+ s <- fork+ copyToHostR 0 n (Just s) ad+ after stream =<< checkpoint s+ join s+ return ad+ --+ event <- checkpoint stream+ return $! AsyncR event arrs'+++-- | Copy arrays between two remote instances of the same type. This may be more+-- efficient than copying to the host and then to the second remote instance+-- (e.g. DMA between CUDA devices).+--+{-# INLINEABLE copyToPeer #-}+copyToPeer :: (Remote arch, Arrays a) => arch -> a -> LLVM arch a+copyToPeer peer arrs = do+ AsyncR _ a <- async (copyToPeerAsync peer arrs)+ get a+++-- | As 'copyToPeer', asynchronously.+--+{-# INLINEABLE copyToPeerAsync #-}+copyToPeerAsync+ :: (Remote arch, Arrays a)+ => arch+ -> a+ -> StreamR arch+ -> LLVM arch (AsyncR arch a)+copyToPeerAsync peer arrs stream = do+ arrs' <- runArrays arrs $ \arr@Array{} ->+ let n = size (shape arr)+ in runArray arr $ \ad -> do+ s <- fork+ copyToPeerR 0 n peer (Just s) ad+ after stream =<< checkpoint s+ join s+ return ad+ --+ event <- checkpoint stream+ return $! AsyncR event arrs'+++-- Helpers for traversing the Arrays data structure+-- ------------------------------------------------++-- |Read a single element from an array at the given row-major index.+--+{-# INLINEABLE runIndexArray #-}+runIndexArray+ :: forall m sh e. Monad m+ => (forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e) => ArrayData e -> Int -> m a)+ -> Array sh e+ -> Int+ -> m e+runIndexArray worker (Array _ adata) i = toElt `liftM` indexR arrayElt adata+ where+ indexR :: ArrayEltR a -> ArrayData a -> m a+ indexR ArrayEltRunit _ = return ()+ indexR (ArrayEltRpair aeR1 aeR2) ad = liftM2 (,) (indexR aeR1 (fstArrayData ad))+ (indexR aeR2 (sndArrayData ad))+ --+ indexR ArrayEltRint ad = worker ad i+ indexR ArrayEltRint8 ad = worker ad i+ indexR ArrayEltRint16 ad = worker ad i+ indexR ArrayEltRint32 ad = worker ad i+ indexR ArrayEltRint64 ad = worker ad i+ indexR ArrayEltRword ad = worker ad i+ indexR ArrayEltRword8 ad = worker ad i+ indexR ArrayEltRword16 ad = worker ad i+ indexR ArrayEltRword32 ad = worker ad i+ indexR ArrayEltRword64 ad = worker ad i+ indexR ArrayEltRfloat ad = worker ad i+ indexR ArrayEltRdouble ad = worker ad i+ indexR ArrayEltRchar ad = worker ad i+ indexR ArrayEltRcshort ad = CShort `liftM` worker ad i+ indexR ArrayEltRcushort ad = CUShort `liftM` worker ad i+ indexR ArrayEltRcint ad = CInt `liftM` worker ad i+ indexR ArrayEltRcuint ad = CUInt `liftM` worker ad i+ indexR ArrayEltRclong ad = CLong `liftM` worker ad i+ indexR ArrayEltRculong ad = CULong `liftM` worker ad i+ indexR ArrayEltRcllong ad = CLLong `liftM` worker ad i+ indexR ArrayEltRcullong ad = CULLong `liftM` worker ad i+ indexR ArrayEltRcchar ad = CChar `liftM` worker ad i+ indexR ArrayEltRcschar ad = CSChar `liftM` worker ad i+ indexR ArrayEltRcuchar ad = CUChar `liftM` worker ad i+ indexR ArrayEltRcfloat ad = CFloat `liftM` worker ad i+ indexR ArrayEltRcdouble ad = CDouble `liftM` worker ad i+ indexR ArrayEltRbool ad = toBool `liftM` worker ad i+ where+ toBool 0 = False+ toBool _ = True+++-- | Generalised function to traverse the Arrays structure+--+{-# INLINE runArrays #-}+runArrays+ :: forall m arrs. (Monad m, Arrays arrs)+ => arrs+ -> (forall sh e. Array sh e -> m (Array sh e))+ -> m arrs+runArrays arrs worker = toArr `liftM` runR (arrays arrs) (fromArr arrs)+ where+ runR :: ArraysR a -> a -> m a+ runR ArraysRunit () = return ()+ runR ArraysRarray arr = worker arr+ runR (ArraysRpair aeR2 aeR1) (arrs2, arrs1) = liftM2 (,) (runR aeR2 arrs2) (runR aeR1 arrs1)+++-- | Generalised function to traverse the ArrayData structure with one+-- additional argument+--+{-# INLINE runArray #-}+runArray+ :: forall m sh e. Monad m+ => Array sh e+ -> (forall e' p. (ArrayElt e', ArrayPtrs e' ~ Ptr p, Storable p, Typeable p, Typeable e') => ArrayData e' -> m (ArrayData e'))+ -> m (Array sh e)+runArray (Array sh adata) worker = Array sh `liftM` runR arrayElt adata+ where+ runR :: ArrayEltR e' -> ArrayData e' -> m (ArrayData e')+ runR ArrayEltRunit AD_Unit = return AD_Unit+ runR (ArrayEltRpair aeR2 aeR1) (AD_Pair ad2 ad1) = liftM2 AD_Pair (runR aeR2 ad2) (runR aeR1 ad1)+ --+ runR ArrayEltRint ad = worker ad+ runR ArrayEltRint8 ad = worker ad+ runR ArrayEltRint16 ad = worker ad+ runR ArrayEltRint32 ad = worker ad+ runR ArrayEltRint64 ad = worker ad+ runR ArrayEltRword ad = worker ad+ runR ArrayEltRword8 ad = worker ad+ runR ArrayEltRword16 ad = worker ad+ runR ArrayEltRword32 ad = worker ad+ runR ArrayEltRword64 ad = worker ad+ runR ArrayEltRfloat ad = worker ad+ runR ArrayEltRdouble ad = worker ad+ runR ArrayEltRbool ad = worker ad+ runR ArrayEltRchar ad = worker ad+ runR ArrayEltRcshort ad = worker ad+ runR ArrayEltRcushort ad = worker ad+ runR ArrayEltRcint ad = worker ad+ runR ArrayEltRcuint ad = worker ad+ runR ArrayEltRclong ad = worker ad+ runR ArrayEltRculong ad = worker ad+ runR ArrayEltRcllong ad = worker ad+ runR ArrayEltRcullong ad = worker ad+ runR ArrayEltRcfloat ad = worker ad+ runR ArrayEltRcdouble ad = worker ad+ runR ArrayEltRcchar ad = worker ad+ runR ArrayEltRcschar ad = worker ad+ runR ArrayEltRcuchar ad = worker ad+
+ Data/Array/Accelerate/LLVM/CodeGen.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen (++ Skeleton(..), Intrinsic(..), KernelMetadata,+ llvmOfOpenAcc,++) where++-- accelerate+import Data.Array.Accelerate.AST hiding ( Val(..), prj, stencil )+import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.Target++import Data.Array.Accelerate.LLVM.CodeGen.Constant+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Intrinsic+import Data.Array.Accelerate.LLVM.CodeGen.Module+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Permute+import Data.Array.Accelerate.LLVM.CodeGen.Skeleton+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Foreign++-- standard library+import Prelude hiding ( map, scanl, scanl1, scanr, scanr1 )+++-- | Generate code for a given target architecture.+--+{-# INLINEABLE llvmOfOpenAcc #-}+llvmOfOpenAcc+ :: forall arch aenv arrs. (Target arch, Skeleton arch, Intrinsic arch, Foreign arch)+ => arch+ -> DelayedOpenAcc aenv arrs+ -> Gamma aenv+ -> Module arch aenv arrs+llvmOfOpenAcc _ Delayed{} _ = $internalError "llvmOfOpenAcc" "expected manifest array"+llvmOfOpenAcc arch (Manifest pacc) aenv = runLLVM $+ case pacc of+ -- Producers+ Map f a -> map arch aenv (travF1 f) (travD a)+ Generate _ f -> generate arch aenv (travF1 f)+ Transform _ p f a -> transform arch aenv (travF1 p) (travF1 f) (travD a)+ Backpermute _ p a -> backpermute arch aenv (travF1 p) (travD a)++ -- Consumers+ Fold f z a -> fold arch aenv (travF2 f) (travE z) (travD a)+ Fold1 f a -> fold1 arch aenv (travF2 f) (travD a)+ FoldSeg f z a s -> foldSeg arch aenv (travF2 f) (travE z) (travD a) (travD s)+ Fold1Seg f a s -> fold1Seg arch aenv (travF2 f) (travD a) (travD s)+ Scanl f z a -> scanl arch aenv (travF2 f) (travE z) (travD a)+ Scanl' f z a -> scanl' arch aenv (travF2 f) (travE z) (travD a)+ Scanl1 f a -> scanl1 arch aenv (travF2 f) (travD a)+ Scanr f z a -> scanr arch aenv (travF2 f) (travE z) (travD a)+ Scanr' f z a -> scanr' arch aenv (travF2 f) (travE z) (travD a)+ Scanr1 f a -> scanr1 arch aenv (travF2 f) (travD a)+ Permute f _ p a -> permute arch aenv (travPF f) (travF1 p) (travD a)+ Stencil f b a -> stencil arch aenv (travF1 f) (travB a b) (travM a)+ Stencil2 f b1 a1 b2 a2 -> stencil2 arch aenv (travF2 f) (travB a1 b1) (travM a1) (travB a2 b2) (travM a2)++ -- Non-computation forms: sadness+ Alet{} -> unexpectedError+ Avar{} -> unexpectedError+ Apply{} -> unexpectedError+ Acond{} -> unexpectedError+ Awhile{} -> unexpectedError+ Atuple{} -> unexpectedError+ Aprj{} -> unexpectedError+ Use{} -> unexpectedError+ Unit{} -> unexpectedError+ Aforeign{} -> unexpectedError+ Reshape{} -> unexpectedError++ Replicate{} -> fusionError+ Slice{} -> fusionError+ ZipWith{} -> fusionError++ where+ -- code generation for delayed arrays+ travD :: DelayedOpenAcc aenv (Array sh e) -> IRDelayed arch aenv (Array sh e)+ travD Manifest{} = $internalError "llvmOfOpenAcc" "expected delayed array"+ travD Delayed{..} = IRDelayed (travE extentD) (travF1 indexD) (travF1 linearIndexD)++ travM :: DelayedOpenAcc aenv (Array sh e) -> IRManifest arch aenv (Array sh e)+ travM (Manifest (Avar ix)) = IRManifest ix+ travM _ = $internalError "llvmOfOpenAcc" "expected manifest array variable"++ -- scalar code generation+ travF1 :: DelayedFun aenv (a -> b) -> IRFun1 arch aenv (a -> b)+ travF1 f = llvmOfFun1 arch f aenv++ travF2 :: DelayedFun aenv (a -> b -> c) -> IRFun2 arch aenv (a -> b -> c)+ travF2 f = llvmOfFun2 arch f aenv++ travPF :: DelayedFun aenv (e -> e -> e) -> IRPermuteFun arch aenv (e -> e -> e)+ travPF f = llvmOfPermuteFun arch f aenv++ travE :: DelayedExp aenv t -> IRExp arch aenv t+ travE e = llvmOfOpenExp arch e Empty aenv++ travB :: forall sh e. Elt e+ => DelayedOpenAcc aenv (Array sh e)+ -> Boundary (EltRepr e)+ -> Boundary (IR e)+ travB _ Clamp = Clamp+ travB _ Mirror = Mirror+ travB _ Wrap = Wrap+ travB _ (Constant c)+ = Constant+ $ IR (constant (eltType (undefined::e)) c)++ -- sadness+ fusionError, unexpectedError :: error+ fusionError = $internalError "llvmOfOpenAcc" $ "unexpected fusible material: " ++ showPreAccOp pacc+ unexpectedError = $internalError "llvmOfOpenAcc" $ "unexpected array primitive: " ++ showPreAccOp pacc+
+ Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs view
@@ -0,0 +1,683 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+ where++-- standard/external libraries+import Prelude ( Eq, Num, Either(..), ($), (++), (==), undefined, otherwise, flip, fromInteger )+import Control.Applicative+import Control.Monad+import Data.Bits ( finiteBitSize )+import Data.String+import Text.Printf+import Foreign.Storable ( sizeOf )+import qualified Prelude as P+import qualified Data.Ord as Ord++-- accelerate+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Array.Sugar++-- accelerate-llvm+import LLVM.AST.Type.Constant+import LLVM.AST.Type.Global+import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Instruction.Compare+import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation++import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Constant+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Type+++-- Operations from Num+-- -------------------++add :: NumType a -> IR a -> IR a -> CodeGen (IR a)+add = binop Add++sub :: NumType a -> IR a -> IR a -> CodeGen (IR a)+sub = binop Sub++mul :: NumType a -> IR a -> IR a -> CodeGen (IR a)+mul = binop Mul++negate :: NumType a -> IR a -> CodeGen (IR a)+negate t x =+ case t of+ IntegralNumType i | IntegralDict <- integralDict i -> mul t x (ir t (num t (P.negate 1)))+ FloatingNumType f | FloatingDict <- floatingDict f -> mul t x (ir t (num t (P.negate 1)))++abs :: forall a. NumType a -> IR a -> CodeGen (IR a)+abs n x =+ case n of+ FloatingNumType f -> mathf "fabs" f x+ IntegralNumType i+ | unsigned i -> return x+ | IntegralDict <- integralDict i ->+ let p = ScalarPrimType (NumScalarType n)+ t = PrimType p+ in+ case finiteBitSize (undefined :: a) of+ 64 -> call (Lam p (op n x) (Body t "llabs")) [NoUnwind, ReadNone]+ _ -> call (Lam p (op n x) (Body t "abs")) [NoUnwind, ReadNone]++signum :: forall a. NumType a -> IR a -> CodeGen (IR a)+signum t x =+ case t of+ IntegralNumType i+ | IntegralDict <- integralDict i+ , unsigned i+ -> do z <- neq (NumScalarType t) x (ir t (num t 0))+ s <- instr (Ext boundedType (IntegralBoundedType i) (op scalarType z))+ return s+ --+ -- http://graphics.stanford.edu/~seander/bithacks.html#CopyIntegerSign+ | IntegralDict <- integralDict i+ -> do let wsib = finiteBitSize (undefined::a)+ z <- neq (NumScalarType t) x (ir t (num t 0))+ l <- instr (Ext boundedType (IntegralBoundedType i) (op scalarType z))+ r <- shiftRA i x (ir integralType (integral integralType (wsib P.- 1)))+ s <- bor i l r+ return s+ --+ -- http://graphics.stanford.edu/~seander/bithacks.html#CopyIntegerSign+ FloatingNumType f+ | FloatingDict <- floatingDict f+ -> do+ l <- gt (NumScalarType t) x (ir f (floating f 0))+ r <- lt (NumScalarType t) x (ir f (floating f 0))+ u <- instr (IntToFP (Right nonNumType) f (op scalarType l))+ v <- instr (IntToFP (Right nonNumType) f (op scalarType r))+ s <- sub t u v+ return s++-- Operations from Integral and Bits+-- ---------------------------------++quot :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+quot = binop Quot++rem :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+rem = binop Rem++quotRem :: IntegralType a -> IR a -> IR a -> CodeGen (IR (a,a))+quotRem t x y = do+ q <- quot t x y+ r <- rem t x y+ -- TLM: On x86 we can compute quotRem with a single [i]divq instruction. This+ -- is not evident from the generated LLVM IR, which will still list both+ -- div/rem operations. Note that this may not be true for other instruction+ -- sets, for example the NVPTX assembly contains both operations. It might be+ -- worthwhile to allow backends to specialise Exp code generation in the same+ -- way the other phases of compilation are handled.+ --+ -- The following can be used to compute the remainder, and _may_ be better for+ -- architectures without a combined quotRem instruction.+ --+ -- z <- mul (IntegralNumType t) y q+ -- r <- sub (IntegralNumType t) x z+ return $ pair q r++idiv :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+idiv i x y+ | unsigned i+ = quot i x y+ --+ | IntegralDict <- integralDict i+ , EltDict <- integralElt i+ , zero <- ir i (integral i 0)+ , one <- ir i (integral i 1)+ , n <- IntegralNumType i+ , s <- NumScalarType n+ = if gt s x zero `land` lt s y zero+ then do+ a <- sub n x one+ b <- quot i a y+ c <- sub n b one+ return c+ else+ if lt s x zero `land` gt s y zero+ then do+ a <- add n x one+ b <- quot i a y+ c <- sub n b one+ return c+ else+ quot i x y++mod :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+mod i x y+ | unsigned i+ = rem i x y+ --+ | IntegralDict <- integralDict i+ , EltDict <- integralElt i+ , zero <- ir i (integral i 0)+ , n <- IntegralNumType i+ , s <- NumScalarType n+ = do r <- rem i x y+ if (gt s x zero `land` lt s y zero) `lor` (lt s x zero `land` gt s y zero)+ then if neq s r zero+ then add n r y+ else return zero+ else return r++divMod :: IntegralType a -> IR a -> IR a -> CodeGen (IR (a,a))+divMod i x y+ | unsigned i+ = quotRem i x y+ --+ | IntegralDict <- integralDict i+ , EltDict <- integralElt i+ , zero <- ir i (integral i 0)+ , one <- ir i (integral i 1)+ , n <- IntegralNumType i+ , s <- NumScalarType n+ = if gt s x zero `land` lt s y zero+ then do+ a <- sub n x one+ b <- quotRem i a y+ c <- sub n (fst b) one+ d <- add n (snd b) y+ e <- add n d one+ return $ pair c e+ else+ if lt s x zero `land` gt s y zero+ then do+ a <- add n x one+ b <- quotRem i a y+ c <- sub n (fst b) one+ d <- add n (snd b) y+ e <- sub n d one+ return $ pair c e+ else+ quotRem i x y+++band :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+band = binop BAnd++bor :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+bor = binop BOr++xor :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+xor = binop BXor++complement :: IntegralType a -> IR a -> CodeGen (IR a)+complement t x | IntegralDict <- integralDict t = xor t x (ir t (integral t (P.negate 1)))++shiftL :: IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+shiftL t x i = do+ i' <- fromIntegral integralType (IntegralNumType t) i+ binop ShiftL t x i'++shiftR :: IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+shiftR t+ | signed t = shiftRA t+ | otherwise = shiftRL t++shiftRL :: IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+shiftRL t x i = do+ i' <- fromIntegral integralType (IntegralNumType t) i+ r <- binop ShiftRL t x i'+ return r++shiftRA :: IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+shiftRA t x i = do+ i' <- fromIntegral integralType (IntegralNumType t) i+ r <- binop ShiftRA t x i'+ return r++rotateL :: forall a. IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+rotateL t x i+ | IntegralDict <- integralDict t+ = do let wsib = finiteBitSize (undefined::a)+ i1 <- band integralType i (ir integralType (integral integralType (wsib P.- 1)))+ i2 <- sub numType (ir numType (integral integralType wsib)) i1+ --+ a <- shiftL t x i1+ b <- shiftRL t x i2+ c <- bor t a b+ return c++rotateR :: forall a. IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+rotateR t x i = do+ i' <- negate numType i+ r <- rotateL t x i'+ return r++popCount :: forall a. IntegralType a -> IR a -> CodeGen (IR Int)+popCount i x+ | IntegralDict <- integralDict i+ = do let ctpop = Label $ printf "llvm.ctpop.i%d" (finiteBitSize (undefined::a))+ p = ScalarPrimType (NumScalarType (IntegralNumType i))+ t = PrimType p+ --+ c <- call (Lam p (op i x) (Body t ctpop)) [NoUnwind, ReadNone]+ r <- fromIntegral i numType c+ return r++countLeadingZeros :: forall a. IntegralType a -> IR a -> CodeGen (IR Int)+countLeadingZeros i x+ | IntegralDict <- integralDict i+ = do let clz = Label $ printf "llvm.ctlz.i%d" (finiteBitSize (undefined::a))+ p = ScalarPrimType (NumScalarType (IntegralNumType i))+ t = PrimType p+ --+ c <- call (Lam p (op i x) (Lam primType (nonnum nonNumType False) (Body t clz))) [NoUnwind, ReadNone]+ r <- fromIntegral i numType c+ return r++countTrailingZeros :: forall a. IntegralType a -> IR a -> CodeGen (IR Int)+countTrailingZeros i x+ | IntegralDict <- integralDict i+ = do let clz = Label $ printf "llvm.cttz.i%d" (finiteBitSize (undefined::a))+ p = ScalarPrimType (NumScalarType (IntegralNumType i))+ t = PrimType p+ --+ c <- call (Lam p (op i x) (Lam primType (nonnum nonNumType False) (Body t clz))) [NoUnwind, ReadNone]+ r <- fromIntegral i numType c+ return r+++-- Operators from Fractional and Floating+-- --------------------------------------++fdiv :: FloatingType a -> IR a -> IR a -> CodeGen (IR a)+fdiv = binop Div++recip :: FloatingType a -> IR a -> CodeGen (IR a)+recip t x | FloatingDict <- floatingDict t = fdiv t (ir t (floating t 1)) x++sin :: FloatingType a -> IR a -> CodeGen (IR a)+sin = mathf "sin"++cos :: FloatingType a -> IR a -> CodeGen (IR a)+cos = mathf "cos"++tan :: FloatingType a -> IR a -> CodeGen (IR a)+tan = mathf "tan"++sinh :: FloatingType a -> IR a -> CodeGen (IR a)+sinh = mathf "sinh"++cosh :: FloatingType a -> IR a -> CodeGen (IR a)+cosh = mathf "cosh"++tanh :: FloatingType a -> IR a -> CodeGen (IR a)+tanh = mathf "tanh"++asin :: FloatingType a -> IR a -> CodeGen (IR a)+asin = mathf "asin"++acos :: FloatingType a -> IR a -> CodeGen (IR a)+acos = mathf "acos"++atan :: FloatingType a -> IR a -> CodeGen (IR a)+atan = mathf "atan"++asinh :: FloatingType a -> IR a -> CodeGen (IR a)+asinh = mathf "asinh"++acosh :: FloatingType a -> IR a -> CodeGen (IR a)+acosh = mathf "acosh"++atanh :: FloatingType a -> IR a -> CodeGen (IR a)+atanh = mathf "atanh"++atan2 :: FloatingType a -> IR a -> IR a -> CodeGen (IR a)+atan2 = mathf2 "atan2"++exp :: FloatingType a -> IR a -> CodeGen (IR a)+exp = mathf "exp"++fpow :: FloatingType a -> IR a -> IR a -> CodeGen (IR a)+fpow = mathf2 "pow"++sqrt :: FloatingType a -> IR a -> CodeGen (IR a)+sqrt = mathf "sqrt"++log :: FloatingType a -> IR a -> CodeGen (IR a)+log = mathf "log"++logBase :: forall a. FloatingType a -> IR a -> IR a -> CodeGen (IR a)+logBase t x@(op t -> base) y | FloatingDict <- floatingDict t = logBase'+ where+ match :: Eq t => Operand t -> Operand t -> Bool+ match (ConstantOperand (ScalarConstant _ u))+ (ConstantOperand (ScalarConstant _ v)) = u == v+ match _ _ = False++ logBase' :: (Num a, Eq a) => CodeGen (IR a)+ logBase' | match base (floating t 2) = mathf "log2" t y+ | match base (floating t 10) = mathf "log10" t y+ | otherwise+ = do x' <- log t x+ y' <- log t y+ fdiv t y' x'+++-- Operators from RealFloat+-- ------------------------++isNaN :: FloatingType a -> IR a -> CodeGen (IR Bool)+isNaN f (op f -> x) = do+ let p = ScalarPrimType (NumScalarType (FloatingNumType f))+ t = type'+ name <- intrinsic "isnan"+ r <- call (Lam p x (Body t name)) [NoUnwind, ReadOnly]+ return r+++-- Operators from RealFrac+-- -----------------------++truncate :: FloatingType a -> IntegralType b -> IR a -> CodeGen (IR b)+truncate tf ti (op tf -> x) = instr (FPToInt tf ti x)++round :: FloatingType a -> IntegralType b -> IR a -> CodeGen (IR b)+round tf ti x = do+ i <- mathf "round" tf x+ truncate tf ti i++floor :: FloatingType a -> IntegralType b -> IR a -> CodeGen (IR b)+floor tf ti x = do+ i <- mathf "floor" tf x+ truncate tf ti i++ceiling :: FloatingType a -> IntegralType b -> IR a -> CodeGen (IR b)+ceiling tf ti x = do+ i <- mathf "ceil" tf x+ truncate tf ti i+++-- Relational and Equality operators+-- ---------------------------------++cmp :: Ordering -> ScalarType a -> IR a -> IR a -> CodeGen (IR Bool)+cmp p dict (op dict -> x) (op dict -> y) = instr (Cmp dict p x y)++lt :: ScalarType a -> IR a -> IR a -> CodeGen (IR Bool)+lt = cmp LT++gt :: ScalarType a -> IR a -> IR a -> CodeGen (IR Bool)+gt = cmp GT++lte :: ScalarType a -> IR a -> IR a -> CodeGen (IR Bool)+lte = cmp LE++gte :: ScalarType a -> IR a -> IR a -> CodeGen (IR Bool)+gte = cmp GE++eq :: ScalarType a -> IR a -> IR a -> CodeGen (IR Bool)+eq = cmp EQ++neq :: ScalarType a -> IR a -> IR a -> CodeGen (IR Bool)+neq = cmp NE++max :: ScalarType a -> IR a -> IR a -> CodeGen (IR a)+max ty x y+ | NumScalarType (FloatingNumType f) <- ty = mathf2 "fmax" f x y+ | otherwise = do c <- op scalarType <$> gte ty x y+ binop (flip Select c) ty x y++min :: ScalarType a -> IR a -> IR a -> CodeGen (IR a)+min ty x y+ | NumScalarType (FloatingNumType f) <- ty = mathf2 "fmin" f x y+ | otherwise = do c <- op scalarType <$> lte ty x y+ binop (flip Select c) ty x y+++-- Logical operators+-- -----------------++land :: CodeGen (IR Bool) -> CodeGen (IR Bool) -> CodeGen (IR Bool)+land x y =+ if x+ then y+ else return $ ir scalarType (scalar scalarType False)++lor :: CodeGen (IR Bool) -> CodeGen (IR Bool) -> CodeGen (IR Bool)+lor x y =+ if x+ then return $ ir scalarType (scalar scalarType True)+ else y++-- These implementations are strict in both arguments.+land' :: IR Bool -> IR Bool -> CodeGen (IR Bool)+land' (op scalarType -> x) (op scalarType -> y)+ = instr (LAnd x y)++lor' :: IR Bool -> IR Bool -> CodeGen (IR Bool)+lor' (op scalarType -> x) (op scalarType -> y)+ = instr (LOr x y)++lnot :: IR Bool -> CodeGen (IR Bool)+lnot (op scalarType -> x) = instr (LNot x)+++-- Type conversions+-- ----------------++ord :: IR Char -> CodeGen (IR Int)+ord (op scalarType -> x) =+ case finiteBitSize (undefined :: Int) of+ 32 -> instr (BitCast scalarType x)+ 64 -> instr (Trunc boundedType boundedType x)+ _ -> $internalError "ord" "I don't know what architecture I am"++chr :: IR Int -> CodeGen (IR Char)+chr (op integralType -> x) =+ case finiteBitSize (undefined :: Int) of+ 32 -> instr (BitCast scalarType x)+ 64 -> instr (Ext boundedType boundedType x)+ _ -> $internalError "chr" "I don't know what architecture I am"++boolToInt :: IR Bool -> CodeGen (IR Int)+boolToInt x = instr (Ext boundedType boundedType (op scalarType x))++fromIntegral :: forall a b. IntegralType a -> NumType b -> IR a -> CodeGen (IR b)+fromIntegral i1 n (op i1 -> x) =+ case n of+ FloatingNumType f+ -> instr (IntToFP (Left i1) f x)++ IntegralNumType (i2 :: IntegralType b)+ | IntegralDict <- integralDict i1+ , IntegralDict <- integralDict i2+ -> let+ bits_a = finiteBitSize (undefined::a)+ bits_b = finiteBitSize (undefined::b)+ in+ case Ord.compare bits_a bits_b of+ Ord.EQ -> instr (BitCast (NumScalarType n) x)+ Ord.GT -> instr (Trunc (IntegralBoundedType i1) (IntegralBoundedType i2) x)+ Ord.LT -> instr (Ext (IntegralBoundedType i1) (IntegralBoundedType i2) x)++toFloating :: forall a b. NumType a -> FloatingType b -> IR a -> CodeGen (IR b)+toFloating n1 f2 (op n1 -> x) =+ case n1 of+ IntegralNumType i1+ -> instr (IntToFP (Left i1) f2 x)++ FloatingNumType (f1 :: FloatingType a)+ | FloatingDict <- floatingDict f1+ , FloatingDict <- floatingDict f2+ -> let+ bytes_a = sizeOf (undefined::a)+ bytes_b = sizeOf (undefined::b)+ in+ case Ord.compare bytes_a bytes_b of+ Ord.EQ -> instr (BitCast (NumScalarType (FloatingNumType f2)) x)+ Ord.GT -> instr (FTrunc f1 f2 x)+ Ord.LT -> instr (FExt f1 f2 x)++coerce :: forall a b. ScalarType a -> ScalarType b -> IR a -> CodeGen (IR b)+coerce ta tb (op ta -> x) = instr (BitCast tb x)+++-- Utility functions+-- -----------------++fst :: IR (a, b) -> IR a+fst (IR (OP_Pair (OP_Pair OP_Unit x) _)) = IR x++snd :: IR (a, b) -> IR b+snd (IR (OP_Pair _ y)) = IR y++pair :: IR a -> IR b -> IR (a, b)+pair (IR x) (IR y) = IR $ OP_Pair (OP_Pair OP_Unit x) y++unpair :: IR (a, b) -> (IR a, IR b)+unpair x = (fst x, snd x)++uncurry :: (IR a -> IR b -> c) -> IR (a, b) -> c+uncurry f (unpair -> (x,y)) = f x y+++binop :: IROP dict => (dict a -> Operand a -> Operand a -> Instruction a) -> dict a -> IR a -> IR a -> CodeGen (IR a)+binop f dict (op dict -> x) (op dict -> y) = instr (f dict x y)+++fst3 :: IR (a, b, c) -> IR a+fst3 (IR (OP_Pair (OP_Pair (OP_Pair OP_Unit x) _) _)) = IR x++snd3 :: IR (a, b, c) -> IR b+snd3 (IR (OP_Pair (OP_Pair _ y) _)) = IR y++thd3 :: IR (a, b, c) -> IR c+thd3 (IR (OP_Pair _ z)) = IR z++trip :: IR a -> IR b -> IR c -> IR (a, b, c)+trip (IR x) (IR y) (IR z) = IR $ OP_Pair (OP_Pair (OP_Pair OP_Unit x) y) z++untrip :: IR (a, b, c) -> (IR a, IR b, IR c)+untrip t = (fst3 t, snd3 t, thd3 t)+++-- | Lift a constant value into an constant in the intermediate representation.+--+{-# INLINABLE lift #-}+lift :: IsScalar a => a -> IR a+lift x = ir scalarType (scalar scalarType x)+++-- | Standard if-then-else expression+--+ifThenElse+ :: Elt a+ => CodeGen (IR Bool)+ -> CodeGen (IR a)+ -> CodeGen (IR a)+ -> CodeGen (IR a)+ifThenElse test yes no = do+ ifThen <- newBlock "if.then"+ ifElse <- newBlock "if.else"+ ifExit <- newBlock "if.exit"++ _ <- beginBlock "if.entry"+ p <- test+ _ <- cbr p ifThen ifElse++ setBlock ifThen+ tv <- yes+ tb <- br ifExit++ setBlock ifElse+ fv <- no+ fb <- br ifExit++ setBlock ifExit+ phi [(tv, tb), (fv, fb)]+++-- Execute the body only if the first argument evaluates to True+--+when :: CodeGen (IR Bool) -> CodeGen () -> CodeGen ()+when test doit = do+ body <- newBlock "when.body"+ exit <- newBlock "when.exit"++ p <- test+ _ <- cbr p body exit++ setBlock body+ doit+ _ <- br exit++ setBlock exit+++-- Execute the body only if the first argument evaluates to False+--+unless :: CodeGen (IR Bool) -> CodeGen () -> CodeGen ()+unless test doit = do+ body <- newBlock "unless.body"+ exit <- newBlock "unless.exit"++ p <- test+ _ <- cbr p exit body++ setBlock body+ doit+ _ <- br exit++ setBlock exit+++-- Call a function from the standard C math library. This is a wrapper around+-- the 'call' function from CodeGen.Base since:+--+-- (1) The parameter and return types are all the same; and+-- (2) We check if there is an intrinsic implementation of this function+--+-- TLM: We should really be able to construct functions of any arity.+--+mathf :: String -> FloatingType t -> IR t -> CodeGen (IR t)+mathf n f (op f -> x) = do+ let s = ScalarPrimType (NumScalarType (FloatingNumType f))+ t = PrimType s+ --+ name <- lm f n+ r <- call (Lam s x (Body t name)) [NoUnwind, ReadOnly]+ return r+++mathf2 :: String -> FloatingType t -> IR t -> IR t -> CodeGen (IR t)+mathf2 n f (op f -> x) (op f -> y) = do+ let s = ScalarPrimType (NumScalarType (FloatingNumType f))+ t = PrimType s+ --+ name <- lm f n+ r <- call (Lam s x (Lam s y (Body t name))) [NoUnwind, ReadOnly]+ return r++lm :: FloatingType t -> String -> CodeGen Label+lm t n+ = intrinsic+ $ case t of+ TypeFloat{} -> n++"f"+ TypeCFloat{} -> n++"f"+ TypeDouble{} -> n+ TypeCDouble{} -> n+
+ Data/Array/Accelerate/LLVM/CodeGen/Array.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Array+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Array (++ readArray,+ writeArray,++) where++import Control.Applicative+import Prelude hiding ( read )++import LLVM.AST.Type.AddrSpace+import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Instruction.Volatile+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation++import Data.Array.Accelerate.Array.Sugar++import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Ptr+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+++-- | Read a value from an array at the given index+--+{-# INLINEABLE readArray #-}+readArray :: forall int sh e. IsIntegral int => IRArray (Array sh e) -> IR int -> CodeGen (IR e)+readArray (IRArray _ (IR adata) addrspace volatility) (op integralType -> ix) =+ IR <$> readArrayData addrspace volatility ix (eltType (undefined::e)) adata++readArrayData :: AddrSpace -> Volatility -> Operand int -> TupleType t -> Operands t -> CodeGen (Operands t)+readArrayData as v ix = read+ where+ read :: TupleType t -> Operands t -> CodeGen (Operands t)+ read UnitTuple OP_Unit = return OP_Unit+ read (PairTuple t2 t1) (OP_Pair a2 a1) = OP_Pair <$> read t2 a2 <*> read t1 a1+ read (SingleTuple t) (asPtr as . op' t -> arr) = ir' t <$> readArrayPrim t v arr ix++readArrayPrim :: ScalarType e -> Volatility -> Operand (Ptr e) -> Operand int -> CodeGen (Operand e)+readArrayPrim t v arr ix = do+ p <- instr' $ GetElementPtr arr [ix]+ x <- instr' $ Load t v p+ return x+++-- | Write a value into an array at the given index+--+{-# INLINEABLE writeArray #-}+writeArray :: forall int sh e. IsIntegral int => IRArray (Array sh e) -> IR int -> IR e -> CodeGen ()+writeArray (IRArray _ (IR adata) addrspace volatility) (op integralType -> ix) (IR val) =+ writeArrayData addrspace volatility ix (eltType (undefined::e)) adata val++writeArrayData :: AddrSpace -> Volatility -> Operand int -> TupleType t -> Operands t -> Operands t -> CodeGen ()+writeArrayData as v ix = write+ where+ write :: TupleType e -> Operands e -> Operands e -> CodeGen ()+ write UnitTuple OP_Unit OP_Unit = return ()+ write (PairTuple t2 t1) (OP_Pair a2 a1) (OP_Pair v2 v1) = write t1 a1 v1 >> write t2 a2 v2+ write (SingleTuple t) (asPtr as . op' t -> arr) (op' t -> val) = writeArrayPrim v arr ix val++writeArrayPrim :: Volatility -> Operand (Ptr e) -> Operand int -> Operand e -> CodeGen ()+writeArrayPrim v arr i x = do+ p <- instr' $ GetElementPtr arr [i]+ _ <- instr' $ Store v p x+ return ()+
+ Data/Array/Accelerate/LLVM/CodeGen/Base.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Base+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Base (++ -- References+ Name(..),+ local, global,++ -- Arrays+ irArray,+ mutableArray,++ -- Functions & parameters+ call,+ scalarParameter, ptrParameter,+ envParam,+ arrayParam,++) where++import LLVM.AST.Type.AddrSpace+import LLVM.AST.Type.Constant+import LLVM.AST.Type.Global+import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Instruction.Volatile+import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation++import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Array.Sugar++import Data.Array.Accelerate.LLVM.CodeGen.Downcast+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar++import qualified LLVM.AST.Global as LLVM++import qualified Data.IntMap as IM+++-- References+-- ----------++local :: ScalarType a -> Name a -> IR a+local t x = ir t (LocalReference (PrimType (ScalarPrimType t)) x)++global :: ScalarType a -> Name a -> IR a+global t x = ir t (ConstantOperand (GlobalReference (PrimType (ScalarPrimType t)) x))+++-- Generating names for things+-- ---------------------------++-- | Names of array data components+--+arrayName :: Name (Array sh e) -> Int -> Name e' -- for the i-th component of the ArrayData+arrayName (Name n) i = Name (n ++ ".ad" ++ show i)+arrayName (UnName n) i = arrayName (Name (show n)) i++-- | Names of shape components+--+shapeName :: Name (Array sh e) -> Int -> Name sh' -- for the i-th component of the shape structure+shapeName (Name n) i = Name (n ++ ".sh" ++ show i)+shapeName (UnName n) i = shapeName (Name (show n)) i++-- | Names of array data elements+--+{-# INLINEABLE irArray #-}+irArray+ :: forall sh e. (Shape sh, Elt e)+ => Name (Array sh e)+ -> IRArray (Array sh e)+irArray n+ = IRArray (travTypeToIR (undefined::sh) (\t i -> LocalReference (PrimType (ScalarPrimType t)) (shapeName n i)))+ (travTypeToIR (undefined::e) (\t i -> LocalReference (PrimType (ScalarPrimType t)) (arrayName n i)))+ defaultAddrSpace+ NonVolatile+++-- | Generate typed local names for array data components as well as function+-- parameters to bind those names+--+{-# INLINEABLE mutableArray #-}+mutableArray+ :: forall sh e. (Shape sh, Elt e)+ => Name (Array sh e)+ -> (IRArray (Array sh e), [LLVM.Parameter])+mutableArray name =+ ( irArray name+ , arrayParam name )+++{-# INLINEABLE travTypeToList #-}+travTypeToList+ :: forall t a. Elt t+ => t {- dummy -}+ -> (forall s. ScalarType s -> Int -> a)+ -> [a]+travTypeToList t f = snd $ go (eltType t) 0+ where+ -- DANGER: [1] must traverse in the same order as [2]+ go :: TupleType s -> Int -> (Int, [a])+ go UnitTuple i = (i, [])+ go (SingleTuple t') i = (i+1, [f t' i])+ go (PairTuple t2 t1) i = let (i1, r1) = go t1 i+ (i2, r2) = go t2 i1+ in+ (i2, r2 ++ r1)++travTypeToIR+ :: Elt t+ => t {- dummy -}+ -> (forall s. ScalarType s -> Int -> Operand s)+ -> IR t+travTypeToIR t f = IR . snd $ go (eltType t) 0+ where+ -- DANGER: [2] must traverse in the same order as [1]+ go :: TupleType s -> Int -> (Int, Operands s)+ go UnitTuple i = (i, OP_Unit)+ go (SingleTuple t') i = (i+1, ir' t' $ f t' i)+ go (PairTuple t2 t1) i = let (i1, r1) = go t1 i+ (i2, r2) = go t2 i1+ in+ (i2, OP_Pair r2 r1)++-- travTypeToIRPtr+-- :: forall t. Elt t+-- => AddrSpace+-- -> t {- dummy -}+-- -> (forall s. ScalarType s -> Int -> Operand (Ptr s))+-- -> IR (Ptr t)+-- travTypeToIRPtr as t f = IR . snd $ go (eltType t) 0+-- where+-- -- DANGER: [2] must traverse in the same order as [1]+-- -- go :: TupleType s -> Int -> (Int, Operands (Ptr s))+-- go :: TupleType (EltRepr s) -> Int -> (Int, Operands (EltRepr (Ptr s))) -- TLM: ugh ):+-- go UnitTuple i = (i, OP_Unit)+-- go (SingleTuple t') i = (i+1, ir' (PtrPrimType t' as) $ f t' i)+-- go (PairTuple t2 t1) i = let (i1, r1) = go t1 i+-- (i2, r2) = go t2 i1+-- in+-- (i2, OP_Pair r2 r1)+++-- Function parameters+-- -------------------++-- | Call a global function. The function declaration is inserted into the+-- symbol table.+--+call :: GlobalFunction args t -> [FunctionAttribute] -> CodeGen (IR t)+call f attrs = do+ let decl = (downcast f) { LLVM.functionAttributes = downcast attrs' }+ attrs' = map Right attrs+ --+ declare decl+ instr (Call f attrs')+++scalarParameter :: ScalarType t -> Name t -> LLVM.Parameter+scalarParameter t x = downcast (Parameter (ScalarPrimType t) x)++ptrParameter :: ScalarType t -> Name (Ptr t) -> LLVM.Parameter+ptrParameter t x = downcast (Parameter (PtrPrimType (ScalarPrimType t) defaultAddrSpace) x)+++-- | Unpack the array environment into a set of input parameters to a function.+-- The environment here refers only to the actual free array variables that are+-- accessed by the function.+--+envParam :: forall aenv. Gamma aenv -> [LLVM.Parameter]+envParam aenv = concatMap (\(Label n, Idx' v) -> toParam v (Name n)) (IM.elems aenv)+ where+ toParam :: forall sh e. (Shape sh, Elt e) => Idx aenv (Array sh e) -> Name (Array sh e) -> [LLVM.Parameter]+ toParam _ name = arrayParam name+++-- | Generate function parameters for an Array with given base name.+--+{-# INLINEABLE arrayParam #-}+arrayParam+ :: forall sh e. (Shape sh, Elt e)+ => Name (Array sh e)+ -> [LLVM.Parameter]+arrayParam name = ad ++ sh+ where+ ad = travTypeToList (undefined :: e) (\t i -> ptrParameter t (arrayName name i))+ sh = travTypeToList (undefined :: sh) (\t i -> scalarParameter t (shapeName name i))+
+ Data/Array/Accelerate/LLVM/CodeGen/Constant.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Constant+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Constant (++ primConst,+ constant, scalar, num, integral, floating, nonnum,+ undef,++) where+++import Data.Array.Accelerate.AST ( PrimConst(..) )+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.LLVM.CodeGen.IR++import LLVM.AST.Type.Constant+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation+++-- | Primitive constant values+--+primConst :: PrimConst t -> t+primConst (PrimMinBound t) = primMinBound t+primConst (PrimMaxBound t) = primMaxBound t+primConst (PrimPi t) = primPi t++primMinBound :: BoundedType a -> a+primMinBound (IntegralBoundedType t) | IntegralDict <- integralDict t = minBound+primMinBound (NonNumBoundedType t) | NonNumDict <- nonNumDict t = minBound++primMaxBound :: BoundedType a -> a+primMaxBound (IntegralBoundedType t) | IntegralDict <- integralDict t = maxBound+primMaxBound (NonNumBoundedType t) | NonNumDict <- nonNumDict t = maxBound++primPi :: FloatingType a -> a+primPi t | FloatingDict <- floatingDict t = pi+++-- | A constant value+--+constant :: TupleType a -> a -> Operands a+constant UnitTuple () = OP_Unit+constant (PairTuple ta tb) (a,b) = OP_Pair (constant ta a) (constant tb b)+constant (SingleTuple t) a = ir' t (scalar t a)++scalar :: ScalarType a -> a -> Operand a+scalar t = ConstantOperand . ScalarConstant t++num :: NumType a -> a -> Operand a+num t = scalar (NumScalarType t)++integral :: IntegralType a -> a -> Operand a+integral t = num (IntegralNumType t)++floating :: FloatingType a -> a -> Operand a+floating t = num (FloatingNumType t)++nonnum :: NonNumType a -> a -> Operand a+nonnum t = scalar (NonNumScalarType t)+++-- | The string 'undef' can be used anywhere a constant is expected, and+-- indicates that the program is well defined no matter what value is used.+--+-- <http://llvm.org/docs/LangRef.html#undefined-values>+--+undef :: ScalarType a -> Operand a+undef t = ConstantOperand (UndefConstant (PrimType (ScalarPrimType t)))+
+ Data/Array/Accelerate/LLVM/CodeGen/Downcast.hs view
@@ -0,0 +1,455 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Downcast+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Downcast (++ Downcast(..)++) where++import Prelude hiding ( Ordering(..), const )+import Data.Bits+import Foreign.C.Types++import Data.Array.Accelerate.AST ( tupleIdxToInt )+import Data.Array.Accelerate.Error++import Data.Array.Accelerate.LLVM.CodeGen.Type+import Data.Array.Accelerate.LLVM.CodeGen.Constant++import LLVM.AST.Type.Constant+import LLVM.AST.Type.Flags+import LLVM.AST.Type.Global+import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Instruction.Atomic+import LLVM.AST.Type.Instruction.Compare+import LLVM.AST.Type.Instruction.Volatile+import LLVM.AST.Type.Metadata+import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation+import LLVM.AST.Type.Terminator+import qualified LLVM.AST.Type.Instruction.RMW as RMW++import qualified LLVM.AST.Attribute as L+import qualified LLVM.AST.CallingConvention as L+import qualified LLVM.AST.Constant as LC+import qualified LLVM.AST.Float as L+import qualified LLVM.AST.FloatingPointPredicate as FP+import qualified LLVM.AST.Global as L+import qualified LLVM.AST.Instruction as L+import qualified LLVM.AST.IntegerPredicate as IP+import qualified LLVM.AST.Name as L+import qualified LLVM.AST.Operand as L+import qualified LLVM.AST.RMWOperation as LA+import qualified LLVM.AST.Type as L+++-- | Convert a value from our representation of the LLVM AST which uses+-- Haskell-level types, into the llvm-general representation where types are+-- represented only at the value level. We use the type-level information to+-- generate the appropriate value-level types.+--+class Downcast typed untyped where+ downcast :: typed -> untyped++instance Downcast a a' => Downcast [a] [a'] where+ downcast = map downcast++instance Downcast a a' => Downcast (Maybe a) (Maybe a') where+ downcast Nothing = Nothing+ downcast (Just x) = Just (downcast x)++instance (Downcast a a', Downcast b b') => Downcast (a,b) (a',b') where+ downcast (a,b) = (downcast a, downcast b)++instance (Downcast a a', Downcast b b') => Downcast (Either a b) (Either a' b') where+ downcast (Left a) = Left (downcast a)+ downcast (Right b) = Right (downcast b)+++-- LLVM.General.AST.Type.Flags+-- ---------------------------++nsw :: Bool+nsw = False++nuw :: Bool+nuw = False++fmf :: FastMathFlags+fmf = UnsafeAlgebra++md :: L.InstructionMetadata+md = []+++instance Downcast NUW Bool where+ downcast NoUnsignedWrap = True+ downcast UnsignedWrap = False++instance Downcast NSW Bool where+ downcast NoSignedWrap = True+ downcast SignedWrap = False++instance Downcast FastMathFlags L.FastMathFlags where+ downcast = id+++-- LLVM.General.AST.Type.Name+-- --------------------------++instance Downcast (Name a) L.Name where+ downcast (Name s) = L.Name s+ downcast (UnName n) = L.UnName n+++-- LLVM.General.AST.Type.Instruction+-- ---------------------------------++tailcall :: Maybe L.TailCallKind+tailcall = Nothing++-- Instructions++instance Downcast (Instruction a) L.Instruction where+ downcast (Add t x y) =+ case t of+ IntegralNumType{} -> L.Add nsw nuw (downcast x) (downcast y) md+ FloatingNumType{} -> L.FAdd fmf (downcast x) (downcast y) md+ downcast (Sub t x y) =+ case t of+ IntegralNumType{} -> L.Sub nsw nuw (downcast x) (downcast y) md+ FloatingNumType{} -> L.FSub fmf (downcast x) (downcast y) md+ downcast (Mul t x y) =+ case t of+ IntegralNumType{} -> L.Mul nsw nuw (downcast x) (downcast y) md+ FloatingNumType{} -> L.FMul fmf (downcast x) (downcast y) md+ downcast (Quot t x y)+ | signed t = L.SDiv False (downcast x) (downcast y) md+ | otherwise = L.UDiv False (downcast x) (downcast y) md+ downcast (Rem t x y)+ | signed t = L.SRem (downcast x) (downcast y) md+ | otherwise = L.URem (downcast x) (downcast y) md+ downcast (Div _ x y) = L.FDiv fmf (downcast x) (downcast y) md+ downcast (ShiftL _ x i) = L.Shl nsw nuw (downcast x) (downcast i) md+ downcast (ShiftRL _ x i) = L.LShr False (downcast x) (downcast i) md+ downcast (ShiftRA _ x i) = L.AShr False (downcast x) (downcast i) md+ downcast (BAnd _ x y) = L.And (downcast x) (downcast y) md+ downcast (LAnd x y) = L.And (downcast x) (downcast y) md+ downcast (BOr _ x y) = L.Or (downcast x) (downcast y) md+ downcast (LOr x y) = L.Or (downcast x) (downcast y) md+ downcast (BXor _ x y) = L.Xor (downcast x) (downcast y) md+ downcast (LNot x) = L.Xor (downcast x) (downcast (scalar scalarType True)) md+ downcast (ExtractValue _ tix tup) = L.ExtractValue (downcast tup) [fromIntegral $ sizeOfTuple - tupleIdxToInt tix - 1] md+ where+ sizeOfTuple+ | PrimType p <- typeOf tup+ , TupleType t <- p = go t+ | otherwise = $internalError "downcast" "unexpected operand type to ExtractValue"+ --+ go :: TupleType t -> Int+ go (PairTuple t _) = 1 + go t+ go _ = 0+ downcast (Load _ v p) = L.Load (downcast v) (downcast p) Nothing 0 md+ downcast (Store v p x) = L.Store (downcast v) (downcast p) (downcast x) Nothing 0 md+ downcast (GetElementPtr n i) = L.GetElementPtr False (downcast n) (downcast i) md -- TLM: in bounds??+ downcast (Fence a) = L.Fence (downcast a) md+ downcast (CmpXchg _ v p x y a m) = L.CmpXchg (downcast v) (downcast p) (downcast x) (downcast y) (downcast a) (downcast m) md+ downcast (AtomicRMW t v op p x a) = L.AtomicRMW (downcast v) (downcast (t,op)) (downcast p) (downcast x) (downcast a) md+ downcast (Trunc _ t x) = L.Trunc (downcast x) (downcast t) md+ downcast (FTrunc _ t x) = L.FPTrunc (downcast x) (downcast t) md+ downcast (Ext t t' x)+ | signed t = L.SExt (downcast x) (downcast t') md+ | otherwise = L.ZExt (downcast x) (downcast t') md+ downcast (FExt _ t x) = L.FPExt (downcast x) (downcast t) md+ downcast (FPToInt _ t x)+ | signed t = L.FPToSI (downcast x) (downcast t) md+ | otherwise = L.FPToUI (downcast x) (downcast t) md+ downcast (IntToFP t t' x)+ | either signed signed t = L.SIToFP (downcast x) (downcast t') md+ | otherwise = L.UIToFP (downcast x) (downcast t') md+ downcast (BitCast t x) = L.BitCast (downcast x) (downcast t) md+ downcast (PtrCast t x) = L.BitCast (downcast x) (downcast t) md+ downcast (Phi t incoming) = L.Phi (downcast t) (downcast incoming) md+ downcast (Select _ p x y) = L.Select (downcast p) (downcast x) (downcast y) md+ downcast (Call f attrs) = L.Call tailcall L.C [] (downcast f) (downcast f) (downcast attrs) md+ downcast (Cmp t p x y) =+ let+ fp EQ = FP.OEQ+ fp NE = FP.ONE+ fp LT = FP.OLT+ fp LE = FP.OLE+ fp GT = FP.OGT+ fp GE = FP.OGE+ --+ si EQ = IP.EQ+ si NE = IP.NE+ si LT = IP.SLT+ si LE = IP.SLE+ si GT = IP.SGT+ si GE = IP.SGE+ --+ ui EQ = IP.EQ+ ui NE = IP.NE+ ui LT = IP.ULT+ ui LE = IP.ULE+ ui GT = IP.UGT+ ui GE = IP.UGE+ in+ case t of+ NumScalarType FloatingNumType{} -> L.FCmp (fp p) (downcast x) (downcast y) md+ _ | signed t -> L.ICmp (si p) (downcast x) (downcast y) md+ | otherwise -> L.ICmp (ui p) (downcast x) (downcast y) md++instance Downcast Volatility Bool where+ downcast Volatile = True+ downcast NonVolatile = False++instance Downcast Synchronisation L.SynchronizationScope where+ downcast SingleThread = L.SingleThread+ downcast CrossThread = L.CrossThread++instance Downcast MemoryOrdering L.MemoryOrdering where+ downcast Unordered = L.Unordered+ downcast Monotonic = L.Monotonic+ downcast Acquire = L.Acquire+ downcast Release = L.Release+ downcast AcquireRelease = L.AcquireRelease+ downcast SequentiallyConsistent = L.SequentiallyConsistent++instance Downcast (IntegralType t, RMW.RMWOperation) LA.RMWOperation where+ downcast (_, RMW.Exchange) = LA.Xchg+ downcast (_, RMW.Add) = LA.Add+ downcast (_, RMW.Sub) = LA.Sub+ downcast (_, RMW.And) = LA.And+ downcast (_, RMW.Or) = LA.Or+ downcast (_, RMW.Xor) = LA.Xor+ downcast (_, RMW.Nand) = LA.Nand+ downcast (t, RMW.Min)+ | signed t = LA.Min+ | otherwise = LA.UMin+ downcast (t, RMW.Max)+ | signed t = LA.Max+ | otherwise = LA.UMax++instance (Downcast (i a) i') => Downcast (Named i a) (L.Named i') where+ downcast (x := op) = downcast x L.:= downcast op+ downcast (Do op) = L.Do (downcast op)++instance Downcast a b => Downcast (L.Named a) (L.Named b) where+ downcast (l L.:= r) = l L.:= downcast r+ downcast (L.Do x) = L.Do (downcast x)+++-- LLVM.General.AST.Type.Constant+-- ------------------------------++instance Downcast (Constant a) LC.Constant where+ downcast (ScalarConstant (NumScalarType (IntegralNumType t)) x)+ | IntegralDict <- integralDict t+ = LC.Int (L.typeBits (downcast t)) (fromIntegral x)++ downcast (ScalarConstant (NumScalarType (FloatingNumType t)) x)+ = LC.Float+ $ case t of+ TypeFloat{} -> L.Single x+ TypeDouble{} -> L.Double x+ TypeCFloat{} -> L.Single $ case x of CFloat x' -> x'+ TypeCDouble{} -> L.Double $ case x of CDouble x' -> x'++ downcast (ScalarConstant (NonNumScalarType t) x)+ = LC.Int (L.typeBits (downcast t))+ $ case t of+ TypeBool{} -> fromIntegral (fromEnum x)+ TypeChar{} -> fromIntegral (fromEnum x)+ TypeCChar{} -> fromIntegral (fromEnum x)+ TypeCUChar{} -> fromIntegral (fromEnum x)+ TypeCSChar{} -> fromIntegral (fromEnum x)++ downcast (UndefConstant t)+ = LC.Undef (downcast t)++ downcast (GlobalReference t n)+ = LC.GlobalReference (downcast t) (downcast n)+++-- LLVM.General.AST.Type.Operand+-- -----------------------------++instance Downcast (Operand a) L.Operand where+ downcast (LocalReference t n) = L.LocalReference (downcast t) (downcast n)+ downcast (ConstantOperand c) = L.ConstantOperand (downcast c)+++-- LLVM.General.AST.Type.Metadata+-- ------------------------------++instance Downcast Metadata L.Operand where+ downcast = L.MetadataOperand . downcast++instance Downcast Metadata L.Metadata where+ downcast (MetadataStringOperand s) = L.MDString s+ downcast (MetadataNodeOperand n) = L.MDNode (downcast n)+ downcast (MetadataOperand o) = L.MDValue (downcast o)++instance Downcast MetadataNode L.MetadataNode where+ downcast (MetadataNode n) = L.MetadataNode (downcast n)+ downcast (MetadataNodeReference r) = L.MetadataNodeReference r+++-- LLVM.General.AST.Type.Terminator+-- --------------------------------++instance Downcast (Terminator a) L.Terminator where+ downcast Ret = L.Ret Nothing md+ downcast (RetVal x) = L.Ret (Just (downcast x)) md+ downcast (Br l) = L.Br (downcast l) md+ downcast (CondBr p t f) = L.CondBr (downcast p) (downcast t) (downcast f) md+ downcast (Switch p d a) = L.Switch (downcast p) (downcast d) (downcast a) md+++-- LLVM.General.AST.Type.Name+-- --------------------------++instance Downcast Label L.Name where+ downcast (Label l) = L.Name l+++-- LLVM.General.AST.Type.Global+-- ----------------------------++instance Downcast (Parameter a) L.Parameter where+ downcast (Parameter t x) = L.Parameter (downcast t) (downcast x) attrs+ where+ attrs | PtrPrimType{} <- t = [L.NoAlias, L.NoCapture] -- TLM: alignment?+ | otherwise = []++-- Function -> callable operands (for Call instruction)+--+instance Downcast (GlobalFunction args t) L.CallableOperand where+ downcast f+ = let trav :: GlobalFunction args t -> ([L.Type], L.Type, L.Name)+ trav (Body t n) = ([], downcast t, downcast n)+ trav (Lam t _ l) = let (t',r, n) = trav l+ in (downcast t : t', r, n)++ (args, result, name) = trav f+ ty = L.FunctionType result args False+ in+ Right (L.ConstantOperand (LC.GlobalReference ty name))++instance Downcast (GlobalFunction args t) [(L.Operand, [L.ParameterAttribute])] where+ downcast Body{} = []+ downcast (Lam _ x l) = (downcast x, []) : downcast l++-- Function -> global declaration+--+instance Downcast (GlobalFunction args t) L.Global where+ downcast f+ = let trav :: GlobalFunction args t -> ([L.Type], L.Type, L.Name)+ trav (Body t n) = ([], downcast t, downcast n)+ trav (Lam t _ l) = let (t',r, n) = trav l+ in (downcast t : t', r, n)++ (args, result, name) = trav f+ params = [ L.Parameter t (L.UnName i) [] | t <- args | i <- [0..] ]+ in+ L.functionDefaults { L.name = name+ , L.returnType = result+ , L.parameters = (params,False)+ }++instance Downcast FunctionAttribute L.FunctionAttribute where+ downcast NoReturn = L.NoReturn+ downcast NoUnwind = L.NoUnwind+ downcast ReadOnly = L.ReadOnly+ downcast ReadNone = L.ReadNone+ downcast AlwaysInline = L.AlwaysInline+ downcast NoDuplicate = L.NoDuplicate+ downcast Convergent = L.Convergent++instance Downcast GroupID L.GroupID where+ downcast (GroupID n) = L.GroupID n+++-- LLVM.General.AST.Type.Representation+-- ------------------------------------++instance Downcast (Type a) L.Type where+ downcast VoidType = L.VoidType+ downcast (PrimType t) = downcast t++instance Downcast (PrimType a) L.Type where+ downcast (ScalarPrimType t) = downcast t+ downcast (PtrPrimType t a) = L.PointerType (downcast t) a+ downcast (ArrayType n t) = L.ArrayType n (downcast t)+ downcast (TupleType t) = L.StructureType False (go t)+ where+ go :: TupleType t -> [L.Type]+ go UnitTuple = []+ go (SingleTuple s) = [downcast s]+ go (PairTuple ta tb) = go ta ++ go tb++-- Data.Array.Accelerate.Type+-- --------------------------++instance Downcast (ScalarType a) L.Type where+ downcast (NumScalarType t) = downcast t+ downcast (NonNumScalarType t) = downcast t++instance Downcast (BoundedType t) L.Type where+ downcast (IntegralBoundedType t) = downcast t+ downcast (NonNumBoundedType t) = downcast t++instance Downcast (NumType a) L.Type where+ downcast (IntegralNumType t) = downcast t+ downcast (FloatingNumType t) = downcast t++instance Downcast (IntegralType a) L.Type where+ downcast (TypeInt _) = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Int)) |] )+ downcast (TypeInt8 _) = L.IntegerType 8+ downcast (TypeInt16 _) = L.IntegerType 16+ downcast (TypeInt32 _) = L.IntegerType 32+ downcast (TypeInt64 _) = L.IntegerType 64+ downcast (TypeWord _) = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Word)) |] )+ downcast (TypeWord8 _) = L.IntegerType 8+ downcast (TypeWord16 _) = L.IntegerType 16+ downcast (TypeWord32 _) = L.IntegerType 32+ downcast (TypeWord64 _) = L.IntegerType 64+ downcast (TypeCShort _) = L.IntegerType 16+ downcast (TypeCUShort _) = L.IntegerType 16+ downcast (TypeCInt _) = L.IntegerType 32+ downcast (TypeCUInt _) = L.IntegerType 32+ downcast (TypeCLong _) = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: CLong)) |] )+ downcast (TypeCULong _) = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: CULong)) |] )+ downcast (TypeCLLong _) = L.IntegerType 64+ downcast (TypeCULLong _) = L.IntegerType 64++instance Downcast (FloatingType a) L.Type where+ downcast (TypeFloat _) = L.FloatingPointType 32 L.IEEE+ downcast (TypeDouble _) = L.FloatingPointType 64 L.IEEE+ downcast (TypeCFloat _) = L.FloatingPointType 32 L.IEEE+ downcast (TypeCDouble _) = L.FloatingPointType 64 L.IEEE++instance Downcast (NonNumType a) L.Type where+ downcast (TypeBool _) = L.IntegerType 1+ downcast (TypeChar _) = L.IntegerType 32+ downcast (TypeCChar _) = L.IntegerType 8+ downcast (TypeCSChar _) = L.IntegerType 8+ downcast (TypeCUChar _) = L.IntegerType 8+
+ Data/Array/Accelerate/LLVM/CodeGen/Environment.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Environment+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Environment+ where++import Data.IntMap ( IntMap )+import qualified Data.IntMap as IM++import Data.Array.Accelerate.AST ( Idx(..), idxToInt )+import Data.Array.Accelerate.Error ( internalError )+import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt )++import Data.Array.Accelerate.LLVM.CodeGen.IR++import LLVM.AST.Type.Name+++-- Scalar environment+-- ==================++-- | An environment for local scalar expression bindings, encoded at the value+-- level as a heterogenous snoc list, and on the type level as nested tuples.+--+data Val env where+ Empty :: Val ()+ Push :: Val env -> IR t -> Val (env, t)++-- | Projection of a value from the valuation environment using a de Bruijn+-- index.+--+prj :: Idx env t -> Val env -> IR t+prj ZeroIdx (Push _ v) = v+prj (SuccIdx ix) (Push val _) = prj ix val+#if __GLASGOW_HASKELL__ < 800+prj _ _ = $internalError "prj" "inconsistent valuation"+#endif+++-- Array environment+-- =================++-- | A mapping between the environment index of a free array variable and the+-- Name of that array to be used in the generated code.+--+-- This simply compresses the array indices into a continuous range, rather than+-- directly using the integer equivalent of the de Bruijn index. Thus, the+-- result is still sensitive to the order of let bindings, but not of any+-- intermediate (unused) free array variables.+--+type Gamma aenv = IntMap (Label, Idx' aenv)++data Idx' aenv where+ Idx' :: (Shape sh, Elt e) => Idx aenv (Array sh e) -> Idx' aenv++-- Projection of a value from the array environment using a de Bruijn index.+-- This returns a pair of operands to access the shape and array data+-- respectively.+--+aprj :: Idx aenv t -> Gamma aenv -> Name t+aprj ix aenv =+ case IM.lookup (idxToInt ix) aenv of+ Nothing -> $internalError "aprj" "free variable not registered"+ Just (Label n,_) -> Name n+++-- | Construct the array environment index, will be used by code generation to+-- map free array variable indices to names in the generated code.+--+makeGamma :: IntMap (Idx' aenv) -> Gamma aenv+makeGamma = snd . IM.mapAccum (\n ix -> (n+1, toAval n ix)) 0+ where+ toAval :: Int -> Idx' aenv -> (Label, Idx' aenv)+ toAval n ix = (Label ("fv" ++ show n), ix)++-- | A free variable+--+freevar :: (Shape sh, Elt e) => Idx aenv (Array sh e) -> IntMap (Idx' aenv)+freevar ix = IM.singleton (idxToInt ix) (Idx' ix)+
+ Data/Array/Accelerate/LLVM/CodeGen/Exp.hs view
@@ -0,0 +1,438 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Exp+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Exp+ where++import Control.Applicative hiding ( Const )+import Control.Monad+import Prelude hiding ( exp, any )+import qualified Data.IntMap as IM++import Data.Array.Accelerate.AST hiding ( Val(..), prj )+import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Sugar hiding ( Foreign, toTuple, shape, intersect, union )+import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) )+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.Type+import qualified Data.Array.Accelerate.Array.Sugar as A++import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Constant+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad ( CodeGen )+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Foreign+import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop as L+import qualified Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A+++-- Scalar expressions+-- ==================++{-# INLINEABLE llvmOfFun1 #-}+llvmOfFun1+ :: Foreign arch+ => arch+ -> DelayedFun aenv (a -> b)+ -> Gamma aenv+ -> IRFun1 arch aenv (a -> b)+llvmOfFun1 arch (Lam (Body body)) aenv = IRFun1 $ \x -> llvmOfOpenExp arch body (Empty `Push` x) aenv+llvmOfFun1 _ _ _ = $internalError "llvmOfFun1" "impossible evaluation"++{-# INLINEABLE llvmOfFun2 #-}+llvmOfFun2+ :: Foreign arch+ => arch+ -> DelayedFun aenv (a -> b -> c)+ -> Gamma aenv+ -> IRFun2 arch aenv (a -> b -> c)+llvmOfFun2 arch (Lam (Lam (Body body))) aenv = IRFun2 $ \x y -> llvmOfOpenExp arch body (Empty `Push` x `Push` y) aenv+llvmOfFun2 _ _ _ = $internalError "llvmOfFun2" "impossible evaluation"+++-- | Convert an open scalar expression into a sequence of LLVM IR instructions.+-- Code is generated in depth first order, and uses a monad to collect the+-- sequence of instructions used to construct basic blocks.+--+{-# INLINEABLE llvmOfOpenExp #-}+llvmOfOpenExp+ :: forall arch env aenv _t. Foreign arch+ => arch+ -> DelayedOpenExp env aenv _t+ -> Val env+ -> Gamma aenv+ -> IROpenExp arch env aenv _t+llvmOfOpenExp arch top env aenv = cvtE top+ where+ cvtM :: DelayedOpenAcc aenv (Array sh e) -> IRManifest arch aenv (Array sh e)+ cvtM (Manifest (Avar ix)) = IRManifest ix+ cvtM _ = $internalError "llvmOfOpenExp" "expected manifest array variable"++ cvtF1 :: DelayedOpenFun env aenv (a -> b) -> IROpenFun1 arch env aenv (a -> b)+ cvtF1 (Lam (Body body)) = IRFun1 $ \x -> llvmOfOpenExp arch body (env `Push` x) aenv+ cvtF1 _ = $internalError "cvtF1" "impossible evaluation"++ cvtE :: forall t. DelayedOpenExp env aenv t -> IROpenExp arch env aenv t+ cvtE exp =+ case exp of+ Let bnd body -> do x <- cvtE bnd+ llvmOfOpenExp arch body (env `Push` x) aenv+ Var ix -> return $ prj ix env+ Const c -> return $ IR (constant (eltType (undefined::t)) c)+ PrimConst c -> return $ IR (constant (eltType (undefined::t)) (fromElt (primConst c)))+ PrimApp f x -> primFun f x+ IndexNil -> return indexNil+ IndexAny -> return indexAny+ IndexCons sh sz -> indexCons <$> cvtE sh <*> cvtE sz+ IndexHead ix -> indexHead <$> cvtE ix+ IndexTail ix -> indexTail <$> cvtE ix+ Prj ix tup -> prjT ix <$> cvtE tup+ Tuple tup -> cvtT tup+ Foreign asm f x -> foreignE asm f =<< cvtE x+ Cond c t e -> A.ifThenElse (cvtE c) (cvtE t) (cvtE e)+ IndexSlice slice slix sh -> indexSlice slice <$> cvtE slix <*> cvtE sh+ IndexFull slice slix sh -> indexFull slice <$> cvtE slix <*> cvtE sh+ ToIndex sh ix -> join $ intOfIndex <$> cvtE sh <*> cvtE ix+ FromIndex sh ix -> join $ indexOfInt <$> cvtE sh <*> cvtE ix+ Index acc ix -> index (cvtM acc) =<< cvtE ix+ LinearIndex acc ix -> linearIndex (cvtM acc) =<< cvtE ix+ ShapeSize sh -> shapeSize =<< cvtE sh+ Shape acc -> return $ shape (cvtM acc)+ Intersect sh1 sh2 -> join $ intersect <$> cvtE sh1 <*> cvtE sh2+ Union sh1 sh2 -> join $ union <$> cvtE sh1 <*> cvtE sh2+ While c f x -> while (cvtF1 c) (cvtF1 f) (cvtE x)++ indexNil :: IR Z+ indexNil = IR (constant (eltType Z) (fromElt Z))++ indexAny :: forall sh. Shape sh => IR (Any sh)+ indexAny = let any = Any :: Any sh+ in IR (constant (eltType any) (fromElt any))++ indexSlice :: SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+ -> IR slix+ -> IR sh+ -> IR sl+ indexSlice slice (IR slix) (IR sh) = IR $ restrict slice slix sh+ where+ restrict :: SliceIndex slix sl co sh -> Operands slix -> Operands sh -> Operands sl+ restrict SliceNil OP_Unit OP_Unit = OP_Unit+ restrict (SliceAll sliceIdx) (OP_Pair slx OP_Unit) (OP_Pair sl sz) =+ let sl' = restrict sliceIdx slx sl+ in OP_Pair sl' sz+ restrict (SliceFixed sliceIdx) (OP_Pair slx _i) (OP_Pair sl _sz) =+ restrict sliceIdx slx sl++ indexFull :: SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+ -> IR slix+ -> IR sl+ -> IR sh+ indexFull slice (IR slix) (IR sh) = IR $ extend slice slix sh+ where+ extend :: SliceIndex slix sl co sh -> Operands slix -> Operands sl -> Operands sh+ extend SliceNil OP_Unit OP_Unit = OP_Unit+ extend (SliceAll sliceIdx) (OP_Pair slx OP_Unit) (OP_Pair sl sz) =+ let sh' = extend sliceIdx slx sl+ in OP_Pair sh' sz+ extend (SliceFixed sliceIdx) (OP_Pair slx sz) sl =+ let sh' = extend sliceIdx slx sl+ in OP_Pair sh' sz++ prjT :: forall t e. (Elt t, Elt e) => TupleIdx (TupleRepr t) e -> IR t -> IR e+ prjT tix (IR ops) = IR $ go tix (eltType (undefined::t)) ops+ where+ go :: TupleIdx v e -> TupleType t' -> Operands t' -> Operands (EltRepr e)+ go ZeroTupIdx (PairTuple _ t) (OP_Pair _ v)+ | Just Refl <- matchTupleType t (eltType (undefined :: e))+ = v+ go (SuccTupIdx ix) (PairTuple t _) (OP_Pair tup _) = go ix t tup+ go _ _ _ = $internalError "prjT" "inconsistent valuation"++ cvtT :: forall t. (Elt t, IsTuple t) => Tuple (DelayedOpenExp env aenv) (TupleRepr t) -> CodeGen (IR t)+ cvtT tup = IR <$> go (eltType (undefined::t)) tup+ where+ go :: TupleType t' -> Tuple (DelayedOpenExp env aenv) tup -> CodeGen (Operands t')+ go UnitTuple NilTup+ = return OP_Unit+ go (PairTuple ta tb) (SnocTup a (b :: DelayedOpenExp env aenv b))+ -- We must assert that the reified type 'tb' of 'b' is actually+ -- equivalent to the type of 'b'. This can not fail, but is necessary+ -- because 'tb' observes the representation type of surface type 'b'.+ | Just Refl <- matchTupleType tb (eltType (undefined::b))+ = do a' <- go ta a+ IR b' <- cvtE b+ return $ OP_Pair a' b'+ go _ _ = $internalError "cvtT" "impossible evaluation"++ linearIndex :: (Shape sh, Elt e) => IRManifest arch aenv (Array sh e) -> IR Int -> CodeGen (IR e)+ linearIndex (IRManifest v) ix =+ readArray (irArray (aprj v aenv)) ix++ index :: (Shape sh, Elt e) => IRManifest arch aenv (Array sh e) -> IR sh -> CodeGen (IR e)+ index (IRManifest v) ix =+ let arr = irArray (aprj v aenv)+ in readArray arr =<< intOfIndex (irArrayShape arr) ix++ shape :: (Shape sh, Elt e) => IRManifest arch aenv (Array sh e) -> IR sh+ shape (IRManifest v) = irArrayShape (irArray (aprj v aenv))++ shapeSize :: forall sh. Shape sh => IR sh -> CodeGen (IR Int)+ shapeSize (IR extent) = go (eltType (undefined::sh)) extent+ where+ go :: TupleType t -> Operands t -> CodeGen (IR Int)+ go UnitTuple OP_Unit+ = return $ IR (constant (eltType (undefined :: Int)) 1)+ go (PairTuple tsh t) (OP_Pair sh sz)+ | Just Refl <- matchTupleType t (eltType (undefined::Int))+ = do+ a <- go tsh sh+ b <- A.mul numType a (IR sz)+ return b+ go (SingleTuple t) (op' t -> i)+ | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)+ = return $ ir t i+ go _ _+ = $internalError "shapeSize" "expected shape with Int components"++ intersect :: forall sh. Shape sh => IR sh -> IR sh -> CodeGen (IR sh)+ intersect (IR extent1) (IR extent2) = IR <$> go (eltType (undefined::sh)) extent1 extent2+ where+ go :: TupleType t -> Operands t -> Operands t -> CodeGen (Operands t)+ go UnitTuple OP_Unit OP_Unit+ = return OP_Unit+ go (SingleTuple t) sh1 sh2+ | Just Refl <- matchScalarType t (scalarType :: ScalarType Int) -- TLM: GHC hang if this is omitted+ = do IR x <- A.min t (IR sh1) (IR sh2)+ return x+ go (PairTuple tsh tsz) (OP_Pair sh1 sz1) (OP_Pair sh2 sz2)+ = do+ sz' <- go tsz sz1 sz2+ sh' <- go tsh sh1 sh2+ return $ OP_Pair sh' sz'+ go _ _ _+ = $internalError "intersect" "expected shape with Int components"++ union :: forall sh. Shape sh => IR sh -> IR sh -> CodeGen (IR sh)+ union (IR extent1) (IR extent2) = IR <$> go (eltType (undefined::sh)) extent1 extent2+ where+ go :: TupleType t -> Operands t -> Operands t -> CodeGen (Operands t)+ go UnitTuple OP_Unit OP_Unit+ = return OP_Unit+ go (SingleTuple t) sh1 sh2+ | Just Refl <- matchScalarType t (scalarType :: ScalarType Int) -- TLM: GHC hang if this is omitted+ = do IR x <- A.max t (IR sh1) (IR sh2)+ return x+ go (PairTuple tsh tsz) (OP_Pair sh1 sz1) (OP_Pair sh2 sz2)+ = do+ sz' <- go tsz sz1 sz2+ sh' <- go tsh sh1 sh2+ return $ OP_Pair sh' sz'+ go _ _ _+ = $internalError "union" "expected shape with Int components"++ while :: Elt a+ => IROpenFun1 arch env aenv (a -> Bool)+ -> IROpenFun1 arch env aenv (a -> a)+ -> IROpenExp arch env aenv a+ -> IROpenExp arch env aenv a+ while p f x =+ L.while (app1 p) (app1 f) =<< x++ foreignE :: (Elt a, Elt b, Foreign arch, A.Foreign asm)+ => asm (a -> b)+ -> DelayedFun () (a -> b)+ -> IR a+ -> IRExp arch () b+ foreignE asm no x =+ case foreignExp arch asm of+ Just f -> app1 f x+ Nothing | Lam (Body b) <- no -> llvmOfOpenExp arch b (Empty `Push` x) IM.empty+ _ -> error "when a grid's misaligned with another behind / that's a moiré..."++ primFun :: Elt r+ => PrimFun (a -> r)+ -> DelayedOpenExp env aenv a+ -> CodeGen (IR r)+ primFun f x =+ let+ -- The Accelerate language and its code generator are hyper-strict.+ -- However, we must not eagerly evaluate the arguments to logical+ -- operations (&&*) and (||*) so that they can short-circuit. Since we+ -- only have unary functions, this is a little tricky for us.+ --+ -- 'inl' and 'inr' attempt to destruct the incoming AST so that we can+ -- evaluate the left or right components of a pair individually. It+ -- should be noted that there are other cases which can evaluate to+ -- pairs; 'Constant', 'Let' and 'Var', for example, but these cases+ -- are (probably) not applicable in this context.+ --+ inl :: (Elt a, Elt b) => DelayedOpenExp env aenv (a,b) -> IROpenExp arch env aenv a+ inl (Tuple (SnocTup (SnocTup NilTup a) _)) = cvtE a+ inl t = cvtE $ Prj (SuccTupIdx ZeroTupIdx) t++ inr :: (Elt a, Elt b) => DelayedOpenExp env aenv (a,b) -> IROpenExp arch env aenv b+ inr (Tuple (SnocTup _ b)) = cvtE b+ inr t = cvtE $ Prj ZeroTupIdx t+ in+ case f of+ PrimAdd t -> A.uncurry (A.add t) =<< cvtE x+ PrimSub t -> A.uncurry (A.sub t) =<< cvtE x+ PrimMul t -> A.uncurry (A.mul t) =<< cvtE x+ PrimNeg t -> A.negate t =<< cvtE x+ PrimAbs t -> A.abs t =<< cvtE x+ PrimSig t -> A.signum t =<< cvtE x+ PrimQuot t -> A.uncurry (A.quot t) =<< cvtE x+ PrimRem t -> A.uncurry (A.rem t) =<< cvtE x+ PrimQuotRem t -> A.uncurry (A.quotRem t) =<< cvtE x+ PrimIDiv t -> A.uncurry (A.idiv t) =<< cvtE x+ PrimMod t -> A.uncurry (A.mod t) =<< cvtE x+ PrimDivMod t -> A.uncurry (A.divMod t) =<< cvtE x+ PrimBAnd t -> A.uncurry (A.band t) =<< cvtE x+ PrimBOr t -> A.uncurry (A.bor t) =<< cvtE x+ PrimBXor t -> A.uncurry (A.xor t) =<< cvtE x+ PrimBNot t -> A.complement t =<< cvtE x+ PrimBShiftL t -> A.uncurry (A.shiftL t) =<< cvtE x+ PrimBShiftR t -> A.uncurry (A.shiftR t) =<< cvtE x+ PrimBRotateL t -> A.uncurry (A.rotateL t) =<< cvtE x+ PrimBRotateR t -> A.uncurry (A.rotateR t) =<< cvtE x+ PrimPopCount t -> A.popCount t =<< cvtE x+ PrimCountLeadingZeros t -> A.countLeadingZeros t =<< cvtE x+ PrimCountTrailingZeros t -> A.countTrailingZeros t =<< cvtE x+ PrimFDiv t -> A.uncurry (A.fdiv t) =<< cvtE x+ PrimRecip t -> A.recip t =<< cvtE x+ PrimSin t -> A.sin t =<< cvtE x+ PrimCos t -> A.cos t =<< cvtE x+ PrimTan t -> A.tan t =<< cvtE x+ PrimSinh t -> A.sinh t =<< cvtE x+ PrimCosh t -> A.cosh t =<< cvtE x+ PrimTanh t -> A.tanh t =<< cvtE x+ PrimAsin t -> A.asin t =<< cvtE x+ PrimAcos t -> A.acos t =<< cvtE x+ PrimAtan t -> A.atan t =<< cvtE x+ PrimAsinh t -> A.asinh t =<< cvtE x+ PrimAcosh t -> A.acosh t =<< cvtE x+ PrimAtanh t -> A.atanh t =<< cvtE x+ PrimAtan2 t -> A.uncurry (A.atan2 t) =<< cvtE x+ PrimExpFloating t -> A.exp t =<< cvtE x+ PrimFPow t -> A.uncurry (A.fpow t) =<< cvtE x+ PrimSqrt t -> A.sqrt t =<< cvtE x+ PrimLog t -> A.log t =<< cvtE x+ PrimLogBase t -> A.uncurry (A.logBase t) =<< cvtE x+ PrimTruncate ta tb -> A.truncate ta tb =<< cvtE x+ PrimRound ta tb -> A.round ta tb =<< cvtE x+ PrimFloor ta tb -> A.floor ta tb =<< cvtE x+ PrimCeiling ta tb -> A.ceiling ta tb =<< cvtE x+ PrimIsNaN t -> A.isNaN t =<< cvtE x+ PrimLt t -> A.uncurry (A.lt t) =<< cvtE x+ PrimGt t -> A.uncurry (A.gt t) =<< cvtE x+ PrimLtEq t -> A.uncurry (A.lte t) =<< cvtE x+ PrimGtEq t -> A.uncurry (A.gte t) =<< cvtE x+ PrimEq t -> A.uncurry (A.eq t) =<< cvtE x+ PrimNEq t -> A.uncurry (A.neq t) =<< cvtE x+ PrimMax t -> A.uncurry (A.max t) =<< cvtE x+ PrimMin t -> A.uncurry (A.min t) =<< cvtE x+ PrimLAnd -> A.land (inl x) (inr x) -- short circuit+ PrimLOr -> A.lor (inl x) (inr x) -- short circuit+ PrimLNot -> A.lnot =<< cvtE x+ PrimOrd -> A.ord =<< cvtE x+ PrimChr -> A.chr =<< cvtE x+ PrimBoolToInt -> A.boolToInt =<< cvtE x+ PrimFromIntegral ta tb -> A.fromIntegral ta tb =<< cvtE x+ PrimToFloating ta tb -> A.toFloating ta tb =<< cvtE x+ PrimCoerce ta tb -> A.coerce ta tb =<< cvtE x+ -- no missing patterns, whoo!+++-- | Extract the head of an index+--+indexHead :: IR (sh :. sz) -> IR sz+indexHead (IR (OP_Pair _ sz)) = IR sz++-- | Extract the tail of an index+--+indexTail :: IR (sh :. sz) -> IR sh+indexTail (IR (OP_Pair sh _)) = IR sh++-- | Construct an index from the head and tail+--+indexCons :: IR sh -> IR sz -> IR (sh :. sz)+indexCons (IR sh) (IR sz) = IR (OP_Pair sh sz)+++-- | Convert a multidimensional array index into a linear index+--+intOfIndex :: forall sh. Shape sh => IR sh -> IR sh -> CodeGen (IR Int)+intOfIndex (IR extent) (IR index) = cvt (eltType (undefined::sh)) extent index+ where+ cvt :: TupleType t -> Operands t -> Operands t -> CodeGen (IR Int)+ cvt UnitTuple OP_Unit OP_Unit+ = return $ IR (constant (eltType (undefined :: Int)) 0)++ cvt (PairTuple tsh t) (OP_Pair sh sz) (OP_Pair ix i)+ | Just Refl <- matchTupleType t (eltType (undefined::Int))+ -- If we short-circuit the last dimension, we can avoid inserting+ -- a multiply by zero and add of the result.+ = case matchTupleType tsh (eltType (undefined::Z)) of+ Just Refl -> return (IR i)+ Nothing -> do+ a <- cvt tsh sh ix+ b <- A.mul numType a (IR sz)+ c <- A.add numType b (IR i)+ return c++ cvt (SingleTuple t) _ (op' t -> i)+ | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)+ = return $ ir t i++ cvt _ _ _+ = $internalError "intOfIndex" "expected shape with Int components"+++-- | Convert a linear index into into a multidimensional index+--+indexOfInt :: forall sh. Shape sh => IR sh -> IR Int -> CodeGen (IR sh)+indexOfInt (IR extent) index = IR <$> cvt (eltType (undefined::sh)) extent index+ where+ cvt :: TupleType t -> Operands t -> IR Int -> CodeGen (Operands t)+ cvt UnitTuple OP_Unit _+ = return OP_Unit++ cvt (PairTuple tsh tsz) (OP_Pair sh sz) i+ | Just Refl <- matchTupleType tsz (eltType (undefined::Int))+ = do+ i' <- A.quot integralType i (IR sz)+ -- If we assume the index is in range, there is no point computing+ -- the remainder of the highest dimension since (i < sz) must hold+ IR r <- case matchTupleType tsh (eltType (undefined::Z)) of+ Just Refl -> return i -- TODO: in debug mode assert (i < sz)+ Nothing -> A.rem integralType i (IR sz)+ sh' <- cvt tsh sh i'+ return $ OP_Pair sh' r++ cvt (SingleTuple t) _ (IR i)+ | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)+ = return i++ cvt _ _ _+ = $internalError "indexOfInt" "expected shape with Int components"+
+ Data/Array/Accelerate/LLVM/CodeGen/IR.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.IR+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.IR (++ IR(..), Operands(..),+ IROP(..),++) where++import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation++import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Array.Sugar+++-- | The datatype 'IR' represents the LLVM IR producing a value of type 'a'.+-- Note that the operands comprising this value are stored in representation+-- type.+--+data IR t where+ IR :: Operands (EltRepr t)+ -> IR t++-- We use a data family to represent sequences of LLVM (scalar) operands+-- representing a single Accelerate type. Using a data family rather than a type+-- family means that Operands is bijective.+--+data family Operands e :: *+data instance Operands () = OP_Unit+data instance Operands Int = OP_Int (Operand Int)+data instance Operands Int8 = OP_Int8 (Operand Int8)+data instance Operands Int16 = OP_Int16 (Operand Int16)+data instance Operands Int32 = OP_Int32 (Operand Int32)+data instance Operands Int64 = OP_Int64 (Operand Int64)+data instance Operands Word = OP_Word (Operand Word)+data instance Operands Word8 = OP_Word8 (Operand Word8)+data instance Operands Word16 = OP_Word16 (Operand Word16)+data instance Operands Word32 = OP_Word32 (Operand Word32)+data instance Operands Word64 = OP_Word64 (Operand Word64)+data instance Operands CShort = OP_CShort (Operand CShort)+data instance Operands CUShort = OP_CUShort (Operand CUShort)+data instance Operands CInt = OP_CInt (Operand CInt)+data instance Operands CUInt = OP_CUInt (Operand CUInt)+data instance Operands CLong = OP_CLong (Operand CLong)+data instance Operands CULong = OP_CULong (Operand CULong)+data instance Operands CLLong = OP_CLLong (Operand CLLong)+data instance Operands CULLong = OP_CULLong (Operand CULLong)+data instance Operands Float = OP_Float (Operand Float)+data instance Operands Double = OP_Double (Operand Double)+data instance Operands CFloat = OP_CFloat (Operand CFloat)+data instance Operands CDouble = OP_CDouble (Operand CDouble)+data instance Operands Bool = OP_Bool (Operand Bool)+data instance Operands Char = OP_Char (Operand Char)+data instance Operands CChar = OP_CChar (Operand CChar)+data instance Operands CSChar = OP_CSChar (Operand CSChar)+data instance Operands CUChar = OP_CUChar (Operand CUChar)+data instance Operands (a,b) = OP_Pair (Operands a) (Operands b)++-- Extra instances to support operands of pointer type+--+-- data instance Operands (Ptr Int) = OP_PtrInt (Operand (Ptr Int))+-- data instance Operands (Ptr Int8) = OP_PtrInt8 (Operand (Ptr Int8))+-- data instance Operands (Ptr Int16) = OP_PtrInt16 (Operand (Ptr Int16))+-- data instance Operands (Ptr Int32) = OP_PtrInt32 (Operand (Ptr Int32))+-- data instance Operands (Ptr Int64) = OP_PtrInt64 (Operand (Ptr Int64))+-- data instance Operands (Ptr Word) = OP_PtrWord (Operand (Ptr Word))+-- data instance Operands (Ptr Word8) = OP_PtrWord8 (Operand (Ptr Word8))+-- data instance Operands (Ptr Word16) = OP_PtrWord16 (Operand (Ptr Word16))+-- data instance Operands (Ptr Word32) = OP_PtrWord32 (Operand (Ptr Word32))+-- data instance Operands (Ptr Word64) = OP_PtrWord64 (Operand (Ptr Word64))+-- data instance Operands (Ptr CShort) = OP_PtrCShort (Operand (Ptr CShort))+-- data instance Operands (Ptr CUShort) = OP_PtrCUShort (Operand (Ptr CUShort))+-- data instance Operands (Ptr CInt) = OP_PtrCInt (Operand (Ptr CInt))+-- data instance Operands (Ptr CUInt) = OP_PtrCUInt (Operand (Ptr CUInt))+-- data instance Operands (Ptr CLong) = OP_PtrCLong (Operand (Ptr CLong))+-- data instance Operands (Ptr CULong) = OP_PtrCULong (Operand (Ptr CULong))+-- data instance Operands (Ptr CLLong) = OP_PtrCLLong (Operand (Ptr CLLong))+-- data instance Operands (Ptr CULLong) = OP_PtrCULLong (Operand (Ptr CULLong))+-- data instance Operands (Ptr Float) = OP_PtrFloat (Operand (Ptr Float))+-- data instance Operands (Ptr Double) = OP_PtrDouble (Operand (Ptr Double))+-- data instance Operands (Ptr CFloat) = OP_PtrCFloat (Operand (Ptr CFloat))+-- data instance Operands (Ptr CDouble) = OP_PtrCDouble (Operand (Ptr CDouble))+-- data instance Operands (Ptr Bool) = OP_PtrBool (Operand (Ptr Bool))+-- data instance Operands (Ptr Char) = OP_PtrChar (Operand (Ptr Char))+-- data instance Operands (Ptr CChar) = OP_PtrCChar (Operand (Ptr CChar))+-- data instance Operands (Ptr CSChar) = OP_PtrCSChar (Operand (Ptr CSChar))+-- data instance Operands (Ptr CUChar) = OP_PtrCUChar (Operand (Ptr CUChar))++-- type instance EltRepr (Ptr Int) = Ptr Int+-- type instance EltRepr (Ptr Int8) = Ptr Int8+-- type instance EltRepr (Ptr Int16) = Ptr Int16+-- type instance EltRepr (Ptr Int32) = Ptr Int32+-- type instance EltRepr (Ptr Int64) = Ptr Int64+-- type instance EltRepr (Ptr Word) = Ptr Word+-- type instance EltRepr (Ptr Word8) = Ptr Word8+-- type instance EltRepr (Ptr Word16) = Ptr Word16+-- type instance EltRepr (Ptr Word32) = Ptr Word32+-- type instance EltRepr (Ptr Word64) = Ptr Word64+-- type instance EltRepr (Ptr CShort) = Ptr CShort+-- type instance EltRepr (Ptr CUShort) = Ptr CUShort+-- type instance EltRepr (Ptr CInt) = Ptr CInt+-- type instance EltRepr (Ptr CUInt) = Ptr CUInt+-- type instance EltRepr (Ptr CLong) = Ptr CLong+-- type instance EltRepr (Ptr CULong) = Ptr CULong+-- type instance EltRepr (Ptr CLLong) = Ptr CLLong+-- type instance EltRepr (Ptr CULLong) = Ptr CULLong+-- type instance EltRepr (Ptr Float) = Ptr Float+-- type instance EltRepr (Ptr Double) = Ptr Double+-- type instance EltRepr (Ptr CFloat) = Ptr CFloat+-- type instance EltRepr (Ptr CDouble) = Ptr CDouble+-- type instance EltRepr (Ptr Bool) = Ptr Bool+-- type instance EltRepr (Ptr Char) = Ptr Char+-- type instance EltRepr (Ptr CChar) = Ptr CChar+-- type instance EltRepr (Ptr CSChar) = Ptr CSChar+-- type instance EltRepr (Ptr CUChar) = Ptr CUChar+-- type instance EltRepr (Ptr (a,b)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b))+-- type instance EltRepr (Ptr (a,b,c)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c))+-- type instance EltRepr (Ptr (a,b,c,d)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d))+-- type instance EltRepr (Ptr (a,b,c,d,e)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d), EltRepr (Ptr e))+-- type instance EltRepr (Ptr (a,b,c,d,e,f)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d), EltRepr (Ptr e), EltRepr (Ptr f))+-- type instance EltRepr (Ptr (a,b,c,d,e,f,g)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d), EltRepr (Ptr e), EltRepr (Ptr f), EltRepr (Ptr g))+-- type instance EltRepr (Ptr (a,b,c,d,e,f,g,h)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d), EltRepr (Ptr e), EltRepr (Ptr f), EltRepr (Ptr g), EltRepr (Ptr h))+-- type instance EltRepr (Ptr (a,b,c,d,e,f,g,h,i)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d), EltRepr (Ptr e), EltRepr (Ptr f), EltRepr (Ptr g), EltRepr (Ptr h), EltRepr (Ptr i))+-- type instance EltRepr (Ptr (a,b,c,d,e,f,g,h,i,j)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d), EltRepr (Ptr e), EltRepr (Ptr f), EltRepr (Ptr g), EltRepr (Ptr h), EltRepr (Ptr i), EltRepr (Ptr j))+-- type instance EltRepr (Ptr (a,b,c,d,e,f,g,h,i,j,k)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d), EltRepr (Ptr e), EltRepr (Ptr f), EltRepr (Ptr g), EltRepr (Ptr h), EltRepr (Ptr i), EltRepr (Ptr j), EltRepr (Ptr k))+-- type instance EltRepr (Ptr (a,b,c,d,e,f,g,h,i,j,k,l)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d), EltRepr (Ptr e), EltRepr (Ptr f), EltRepr (Ptr g), EltRepr (Ptr h), EltRepr (Ptr i), EltRepr (Ptr j), EltRepr (Ptr k), EltRepr (Ptr l))+-- type instance EltRepr (Ptr (a,b,c,d,e,f,g,h,i,j,k,l,m)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d), EltRepr (Ptr e), EltRepr (Ptr f), EltRepr (Ptr g), EltRepr (Ptr h), EltRepr (Ptr i), EltRepr (Ptr j), EltRepr (Ptr k), EltRepr (Ptr l), EltRepr (Ptr m))+-- type instance EltRepr (Ptr (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d), EltRepr (Ptr e), EltRepr (Ptr f), EltRepr (Ptr g), EltRepr (Ptr h), EltRepr (Ptr i), EltRepr (Ptr j), EltRepr (Ptr k), EltRepr (Ptr l), EltRepr (Ptr m), EltRepr (Ptr n))+-- type instance EltRepr (Ptr (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) = TupleRepr (EltRepr (Ptr a), EltRepr (Ptr b), EltRepr (Ptr c), EltRepr (Ptr d), EltRepr (Ptr e), EltRepr (Ptr f), EltRepr (Ptr g), EltRepr (Ptr h), EltRepr (Ptr i), EltRepr (Ptr j), EltRepr (Ptr k), EltRepr (Ptr l), EltRepr (Ptr m), EltRepr (Ptr n), EltRepr (Ptr o))++-- | Given some evidence that 'IR a' represents a scalar type, it can be+-- converted between the IR and Operand data types.+--+class IROP dict where+ op :: dict a -> IR a -> Operand a+ ir :: dict a -> Operand a -> IR a+ --+ op' :: dict a -> Operands a -> Operand a+ ir' :: dict a -> Operand a -> Operands a++instance IROP Type where+ op VoidType _ = LocalReference VoidType (Name []) -- TLM: ???+ op (PrimType t) x = op t x++ ir VoidType _ = IR OP_Unit+ ir (PrimType t) x = ir t x+ --+ ir' VoidType _ = OP_Unit+ ir' (PrimType t) x = ir' t x++ op' VoidType _ = LocalReference VoidType (Name []) -- TLM: ???+ op' (PrimType t) x = op' t x++instance IROP PrimType where+ op (ScalarPrimType t) = op t+ op t = $internalError "op" ("unhandled type: " ++ show t)+ ir (ScalarPrimType t) = ir t+ ir t = $internalError "ir" ("unhandeld type: " ++ show t)++ op' (ScalarPrimType t) = op' t+ op' t = $internalError "op'" ("unhandled type: " ++ show t)+ ir' (ScalarPrimType t) = ir' t+ ir' t = $internalError "ir'" ("unhandled type: " ++ show t)++instance IROP ScalarType where+ op (NumScalarType t) = op t+ op (NonNumScalarType t) = op t+ ir (NumScalarType t) = ir t+ ir (NonNumScalarType t) = ir t+ --+ op' (NumScalarType t) = op' t+ op' (NonNumScalarType t) = op' t+ ir' (NumScalarType t) = ir' t+ ir' (NonNumScalarType t) = ir' t++instance IROP NumType where+ op (IntegralNumType t) = op t+ op (FloatingNumType t) = op t+ ir (IntegralNumType t) = ir t+ ir (FloatingNumType t) = ir t+ --+ op' (IntegralNumType t) = op' t+ op' (FloatingNumType t) = op' t+ ir' (IntegralNumType t) = ir' t+ ir' (FloatingNumType t) = ir' t++instance IROP IntegralType where+ op (TypeInt _) (IR (OP_Int x)) = x+ op (TypeInt8 _) (IR (OP_Int8 x)) = x+ op (TypeInt16 _) (IR (OP_Int16 x)) = x+ op (TypeInt32 _) (IR (OP_Int32 x)) = x+ op (TypeInt64 _) (IR (OP_Int64 x)) = x+ op (TypeWord _) (IR (OP_Word x)) = x+ op (TypeWord8 _) (IR (OP_Word8 x)) = x+ op (TypeWord16 _) (IR (OP_Word16 x)) = x+ op (TypeWord32 _) (IR (OP_Word32 x)) = x+ op (TypeWord64 _) (IR (OP_Word64 x)) = x+ op (TypeCShort _) (IR (OP_CShort x)) = x+ op (TypeCUShort _) (IR (OP_CUShort x)) = x+ op (TypeCInt _) (IR (OP_CInt x)) = x+ op (TypeCUInt _) (IR (OP_CUInt x)) = x+ op (TypeCLong _) (IR (OP_CLong x)) = x+ op (TypeCULong _) (IR (OP_CULong x)) = x+ op (TypeCLLong _) (IR (OP_CLLong x)) = x+ op (TypeCULLong _) (IR (OP_CULLong x)) = x+ --+ ir (TypeInt _) = IR . OP_Int+ ir (TypeInt8 _) = IR . OP_Int8+ ir (TypeInt16 _) = IR . OP_Int16+ ir (TypeInt32 _) = IR . OP_Int32+ ir (TypeInt64 _) = IR . OP_Int64+ ir (TypeWord _) = IR . OP_Word+ ir (TypeWord8 _) = IR . OP_Word8+ ir (TypeWord16 _) = IR . OP_Word16+ ir (TypeWord32 _) = IR . OP_Word32+ ir (TypeWord64 _) = IR . OP_Word64+ ir (TypeCShort _) = IR . OP_CShort+ ir (TypeCUShort _) = IR . OP_CUShort+ ir (TypeCInt _) = IR . OP_CInt+ ir (TypeCUInt _) = IR . OP_CUInt+ ir (TypeCLong _) = IR . OP_CLong+ ir (TypeCULong _) = IR . OP_CULong+ ir (TypeCLLong _) = IR . OP_CLLong+ ir (TypeCULLong _) = IR . OP_CULLong+ --+ op' (TypeInt _) (OP_Int x) = x+ op' (TypeInt8 _) (OP_Int8 x) = x+ op' (TypeInt16 _) (OP_Int16 x) = x+ op' (TypeInt32 _) (OP_Int32 x) = x+ op' (TypeInt64 _) (OP_Int64 x) = x+ op' (TypeWord _) (OP_Word x) = x+ op' (TypeWord8 _) (OP_Word8 x) = x+ op' (TypeWord16 _) (OP_Word16 x) = x+ op' (TypeWord32 _) (OP_Word32 x) = x+ op' (TypeWord64 _) (OP_Word64 x) = x+ op' (TypeCShort _) (OP_CShort x) = x+ op' (TypeCUShort _) (OP_CUShort x) = x+ op' (TypeCInt _) (OP_CInt x) = x+ op' (TypeCUInt _) (OP_CUInt x) = x+ op' (TypeCLong _) (OP_CLong x) = x+ op' (TypeCULong _) (OP_CULong x) = x+ op' (TypeCLLong _) (OP_CLLong x) = x+ op' (TypeCULLong _) (OP_CULLong x) = x+ --+ ir' (TypeInt _) = OP_Int+ ir' (TypeInt8 _) = OP_Int8+ ir' (TypeInt16 _) = OP_Int16+ ir' (TypeInt32 _) = OP_Int32+ ir' (TypeInt64 _) = OP_Int64+ ir' (TypeWord _) = OP_Word+ ir' (TypeWord8 _) = OP_Word8+ ir' (TypeWord16 _) = OP_Word16+ ir' (TypeWord32 _) = OP_Word32+ ir' (TypeWord64 _) = OP_Word64+ ir' (TypeCShort _) = OP_CShort+ ir' (TypeCUShort _) = OP_CUShort+ ir' (TypeCInt _) = OP_CInt+ ir' (TypeCUInt _) = OP_CUInt+ ir' (TypeCLong _) = OP_CLong+ ir' (TypeCULong _) = OP_CULong+ ir' (TypeCLLong _) = OP_CLLong+ ir' (TypeCULLong _) = OP_CULLong++instance IROP FloatingType where+ op (TypeFloat _) (IR (OP_Float x)) = x+ op (TypeDouble _) (IR (OP_Double x)) = x+ op (TypeCFloat _) (IR (OP_CFloat x)) = x+ op (TypeCDouble _) (IR (OP_CDouble x)) = x+ --+ ir (TypeFloat _) = IR . OP_Float+ ir (TypeDouble _) = IR . OP_Double+ ir (TypeCFloat _) = IR . OP_CFloat+ ir (TypeCDouble _) = IR . OP_CDouble+ --+ op' (TypeFloat _) (OP_Float x) = x+ op' (TypeDouble _) (OP_Double x) = x+ op' (TypeCFloat _) (OP_CFloat x) = x+ op' (TypeCDouble _) (OP_CDouble x) = x+ --+ ir' (TypeFloat _) = OP_Float+ ir' (TypeDouble _) = OP_Double+ ir' (TypeCFloat _) = OP_CFloat+ ir' (TypeCDouble _) = OP_CDouble++instance IROP NonNumType where+ op (TypeBool _) (IR (OP_Bool x)) = x+ op (TypeChar _) (IR (OP_Char x)) = x+ op (TypeCChar _) (IR (OP_CChar x)) = x+ op (TypeCSChar _) (IR (OP_CSChar x)) = x+ op (TypeCUChar _) (IR (OP_CUChar x)) = x+ --+ ir (TypeBool _) = IR . OP_Bool+ ir (TypeChar _) = IR . OP_Char+ ir (TypeCChar _) = IR . OP_CChar+ ir (TypeCSChar _) = IR . OP_CSChar+ ir (TypeCUChar _) = IR . OP_CUChar+ --+ op' (TypeBool _) (OP_Bool x) = x+ op' (TypeChar _) (OP_Char x) = x+ op' (TypeCChar _) (OP_CChar x) = x+ op' (TypeCSChar _) (OP_CSChar x) = x+ op' (TypeCUChar _) (OP_CUChar x) = x+ --+ ir' (TypeBool _) = OP_Bool+ ir' (TypeChar _) = OP_Char+ ir' (TypeCChar _) = OP_CChar+ ir' (TypeCSChar _) = OP_CSChar+ ir' (TypeCUChar _) = OP_CUChar+
+ Data/Array/Accelerate/LLVM/CodeGen/Intrinsic.hs view
@@ -0,0 +1,71 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Intrinsic+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Intrinsic (++ Intrinsic(..)++) where++-- accelerate-llvm+import LLVM.AST.Type.Name++-- libraries+import Data.HashMap.Strict ( HashMap )+import qualified Data.HashMap.Strict as HashMap+++-- | During code generation we need to know the name of functions implementing+-- certain intrinsic maths operations. Depending on the backend, these functions+-- may not be implemented using the standard C math library.+--+-- This class allows a backend to provide a mapping from the C math library+-- function name to the name of the function which should be called instead. The+-- default implementation maps to the llvm intrinsic. For example:+--+-- sqrtf -> llvm.sqrt.f32+-- sqrt -> llvm.sqrt.f64+--+class Intrinsic arch where+ intrinsicForTarget :: arch -> HashMap String Label+ intrinsicForTarget _ = llvmIntrinsic+++llvmIntrinsic :: HashMap String Label+llvmIntrinsic =+ let floating base rest+ = (base, Label ("llvm." ++ base ++ ".f64"))+ : (base ++ "f", Label ("llvm." ++ base ++ ".f32"))+ : (base ++ "l", Label ("llvm." ++ base ++ ".f128"))+ : rest+ in+ HashMap.fromList $ foldr floating []+ [ "sqrt"+ , "powi"+ , "sin"+ , "cos"+ , "pow"+ , "exp"+ , "exp2"+ , "log"+ , "log10"+ , "log2"+ , "fma"+ , "fabs"+ , "copysign"+ , "floor"+ , "ceil"+ , "trunc"+ , "rint"+ , "nearbyint"+ , "round"+ ]+
+ Data/Array/Accelerate/LLVM/CodeGen/Loop.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Loop+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Loop+ where++import Prelude hiding ( fst, snd, uncurry )+import Control.Monad++import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Sugar hiding ( iter )++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+++-- | TODO: Iterate over a multidimensional index space.+--+-- Build nested loops that iterate over a hype-rectangular index space+-- between the given coordinates. The LLVM optimiser will be able to+-- vectorise nested loops, including when we insert conversions to the+-- corresponding linear index (e.g., in order to index arrays).+--+-- iterate+-- :: Shape sh+-- => IR sh -- ^ starting index+-- -> IR sh -- ^ final index+-- -> (IR sh -> CodeGen (IR a)) -- ^ body of the loop+-- -> CodeGen (IR a)+-- iterate from to body = error "CodeGen.Loop.iterate"+++-- | Execute the given function at each index in the range+--+imapFromStepTo+ :: (IsNum i, Elt i)+ => IR i -- ^ starting index (inclusive)+ -> IR i -- ^ step size+ -> IR i -- ^ final index (exclusive)+ -> (IR i -> CodeGen ()) -- ^ loop body+ -> CodeGen ()+imapFromStepTo start step end body =+ for start+ (\i -> lt scalarType i end)+ (\i -> add numType i step)+ body+++-- | Iterate with an accumulator between given start and end indices, executing+-- the given function at each.+--+iterFromStepTo+ :: (IsNum i, Elt i, Elt a)+ => IR i -- ^ starting index (inclusive)+ -> IR i -- ^ step size+ -> IR i -- ^ final index (exclusive)+ -> IR a -- ^ initial value+ -> (IR i -> IR a -> CodeGen (IR a)) -- ^ loop body+ -> CodeGen (IR a)+iterFromStepTo start step end seed body =+ iter start seed+ (\i -> lt scalarType i end)+ (\i -> add numType i step)+ body+++-- | A standard 'for' loop.+--+for :: Elt i+ => IR i -- ^ starting index+ -> (IR i -> CodeGen (IR Bool)) -- ^ loop test to keep going+ -> (IR i -> CodeGen (IR i)) -- ^ increment loop counter+ -> (IR i -> CodeGen ()) -- ^ body of the loop+ -> CodeGen ()+for start test incr body =+ void $ while test (\i -> body i >> incr i) start+++-- | An loop with iteration count and accumulator.+--+iter :: (Elt i, Elt a)+ => IR i -- ^ starting index+ -> IR a -- ^ initial value+ -> (IR i -> CodeGen (IR Bool)) -- ^ index test to keep looping+ -> (IR i -> CodeGen (IR i)) -- ^ increment loop counter+ -> (IR i -> IR a -> CodeGen (IR a)) -- ^ loop body+ -> CodeGen (IR a)+iter start seed test incr body = do+ r <- while (test . fst)+ (\v -> do v' <- uncurry body v -- update value and then...+ i' <- incr (fst v) -- ...calculate new index+ return $ pair i' v')+ (pair start seed)+ return $ snd r+++-- | A standard 'while' loop+--+while :: Elt a+ => (IR a -> CodeGen (IR Bool))+ -> (IR a -> CodeGen (IR a))+ -> IR a+ -> CodeGen (IR a)+while test body start = do+ loop <- newBlock "while.top"+ exit <- newBlock "while.exit"+ _ <- beginBlock "while.entry"++ -- Entry: generate the initial value+ p <- test start+ top <- cbr p loop exit++ -- Create the critical variable that will be used to accumulate the results+ prev <- fresh++ -- Generate the loop body. Afterwards, we insert a phi node at the head of the+ -- instruction stream, which selects the input value depending on which edge+ -- we entered the loop from: top or bottom.+ --+ setBlock loop+ next <- body prev+ p' <- test next+ bot <- cbr p' loop exit++ _ <- phi' loop prev [(start,top), (next,bot)]++ -- Now the loop exit+ setBlock exit+ phi [(start,top), (next,bot)]+
+ Data/Array/Accelerate/LLVM/CodeGen/Module.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Module+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Module+ where++-- llvm-hs+import qualified LLVM.AST as LLVM++-- standard library+import Data.Map ( Map )+++-- | A compiled module consists of a number of global functions (kernels). The+-- module additionally includes a map from the callable function definitions to+-- the metadata for that function.+--+data Module arch aenv a+ = Module { unModule :: LLVM.Module+ , moduleMetadata :: Map LLVM.Name (KernelMetadata arch)+ }++-- | A fully-instantiated skeleton is a [collection of] kernel(s) that can be compiled+-- by LLVM into a global function that we can execute.+--+data Kernel arch aenv a+ = Kernel { unKernel :: LLVM.Global+ , kernelMetadata :: KernelMetadata arch+ }++-- | Kernels can be annotated with extra target-specific information+--+data family KernelMetadata arch+
+ Data/Array/Accelerate/LLVM/CodeGen/Monad.hs view
@@ -0,0 +1,424 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Monad+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Monad (++ CodeGen,+ runLLVM,++ -- declarations+ fresh, freshName,+ declare,+ intrinsic,++ -- basic blocks+ Block,+ newBlock, setBlock, beginBlock, createBlocks,++ -- instructions+ instr, instr', do_, return_, retval_, br, cbr, phi, phi',+ instr_,++ -- metadata+ addMetadata,++) where++-- standard library+import Control.Applicative+import Control.Monad.State.Strict+import Data.Function+import Data.HashMap.Strict ( HashMap )+import Data.Map ( Map )+import Data.Sequence ( Seq )+import Data.Word+import Text.Printf+import Prelude+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map as Map+import qualified Data.Sequence as Seq++-- accelerate+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Array.Sugar ( Elt, eltType )+import qualified Data.Array.Accelerate.Debug as Debug++-- accelerate-llvm+import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Metadata+import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation+import LLVM.AST.Type.Terminator++import Data.Array.Accelerate.LLVM.Target+import Data.Array.Accelerate.LLVM.CodeGen.Downcast+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Intrinsic+import Data.Array.Accelerate.LLVM.CodeGen.Module+import Data.Array.Accelerate.LLVM.CodeGen.Type++import Data.Array.Accelerate.LLVM.CodeGen.Sugar ( IROpenAcc(..) )++-- llvm-hs+import qualified LLVM.AST as LLVM+import qualified LLVM.AST.Global as LLVM+++-- Code generation+-- ===============++-- | The code generation state for scalar functions and expressions.+--+-- We use two records: one to hold all the code generation state as it walks the+-- AST, and one for each of the basic blocks that are generated during the walk.+--+data CodeGenState = CodeGenState+ { blockChain :: Seq Block -- blocks for this function+ , symbolTable :: Map Label LLVM.Global -- global (external) function declarations+ , metadataTable :: HashMap String (Seq [Maybe Metadata]) -- module metadata to be collected+ , intrinsicTable :: HashMap String Label -- standard math intrinsic functions+ , next :: {-# UNPACK #-} !Word -- a name supply+ }++data Block = Block+ { blockLabel :: Label -- block label+ , instructions :: Seq (LLVM.Named LLVM.Instruction) -- stack of instructions+ , terminator :: LLVM.Terminator -- block terminator+ }++newtype CodeGen a = CodeGen { runCodeGen :: State CodeGenState a }+ deriving (Functor, Applicative, Monad, MonadState CodeGenState)+++{-# INLINEABLE runLLVM #-}+runLLVM+ :: forall arch aenv a. (Target arch, Intrinsic arch)+ => CodeGen (IROpenAcc arch aenv a)+ -> Module arch aenv a+runLLVM ll =+ let+ initialState = CodeGenState+ { blockChain = initBlockChain+ , symbolTable = Map.empty+ , metadataTable = HashMap.empty+ , intrinsicTable = intrinsicForTarget (undefined::arch)+ , next = 0+ }++ (kernels, md, st) = case runState (runCodeGen ll) initialState of+ (IROpenAcc ks, s) -> let (fs, as) = unzip [ (f , (LLVM.name f, a)) | Kernel f a <- ks ]+ in (fs, Map.fromList as, s)++ definitions = map LLVM.GlobalDefinition (kernels ++ Map.elems (symbolTable st))+ ++ createMetadata (metadataTable st)++ name | x:_ <- kernels+ , f@LLVM.Function{} <- x+ , LLVM.Name s <- LLVM.name f = s+ | otherwise = "<undefined>"++ in+ Module { moduleMetadata = md+ , unModule = LLVM.Module+ { LLVM.moduleName = name+ , LLVM.moduleSourceFileName = []+ , LLVM.moduleDataLayout = targetDataLayout (undefined::arch)+ , LLVM.moduleTargetTriple = targetTriple (undefined::arch)+ , LLVM.moduleDefinitions = definitions+ }+ }+++-- Basic Blocks+-- ============++-- | An initial block chain+--+initBlockChain :: Seq Block+initBlockChain+ = Seq.singleton+ $ Block "entry" Seq.empty ($internalError "entry" "block has no terminator")+++-- | Create a new basic block, but don't yet add it to the block chain. You need+-- to call 'setBlock' to append it to the chain, so that subsequent instructions+-- are added to this block.+--+-- Note: [Basic blocks]+--+-- The names of basic blocks are generated based on the base name provided to+-- the 'newBlock' function, as well as the current state (length) of the block+-- stream. By not immediately adding new blocks to the stream, we have the+-- advantage that:+--+-- 1. Instructions are generated "in order", and are always appended to the+-- stream. There is no need to search the stream for a block of the right+-- name.+--+-- 2. Blocks are named in groups, which helps readability. For example, the+-- blocks for the then and else branches of a conditional, created at the+-- same time, will be named similarly: 'if4.then' and 'if4.else', etc.+--+-- However, this leads to a slight awkwardness when walking the AST. Since a new+-- naming group scheme is only applied *after* a call to 'setBlock',+-- encountering (say) nested conditionals in the walk will generate logically+-- distinct blocks that happen to have the same name. This means that+-- instructions might be added to the wrong blocks, or the first set of blocks+-- will be emitted empty and/or without a terminator.+--+newBlock :: String -> CodeGen Block+newBlock nm =+ state $ \s ->+ let idx = Seq.length (blockChain s)+ label = let (h,t) = break (== '.') nm in (h ++ shows idx t)+ next = Block (Label label) Seq.empty err+ err = $internalError label "Block has no terminator"+ in+ ( next, s )+++-- | Add this block to the block stream. Any instructions pushed onto the stream+-- by 'instr' and friends will now apply to this block.+--+setBlock :: Block -> CodeGen ()+setBlock next =+ modify $ \s -> s { blockChain = blockChain s Seq.|> next }+++-- | Generate a new block and branch unconditionally to it.+--+beginBlock :: String -> CodeGen Block+beginBlock nm = do+ next <- newBlock nm+ _ <- br next+ setBlock next+ return next+++-- | Extract the block state and construct the basic blocks that form a function+-- body. The block stream is re-initialised, but module-level state such as the+-- global symbol table is left intact.+--+createBlocks :: CodeGen [LLVM.BasicBlock]+createBlocks+ = state+ $ \s -> let s' = s { blockChain = initBlockChain, next = 0 }+ blocks = makeBlock `fmap` blockChain s+ m = Seq.length (blockChain s)+ n = F.foldl' (\i b -> i + Seq.length (instructions b)) 0 (blockChain s)+ in+ trace (printf "generated %d instructions in %d blocks" (n+m) m) ( F.toList blocks , s' )+ where+ makeBlock Block{..} =+ LLVM.BasicBlock (downcast blockLabel) (F.toList instructions) (LLVM.Do terminator)+++-- Instructions+-- ------------++-- | Generate a fresh local reference+--+fresh :: forall a. Elt a => CodeGen (IR a)+fresh = IR <$> go (eltType (undefined::a))+ where+ go :: TupleType t -> CodeGen (Operands t)+ go UnitTuple = return OP_Unit+ go (PairTuple t2 t1) = OP_Pair <$> go t2 <*> go t1+ go (SingleTuple t) = ir' t . LocalReference (PrimType (ScalarPrimType t)) <$> freshName++-- | Generate a fresh (un)name.+--+freshName :: CodeGen (Name a)+freshName = state $ \s@CodeGenState{..} -> ( UnName next, s { next = next + 1 } )+++-- | Add an instruction to the state of the currently active block so that it is+-- computed, and return the operand (LocalReference) that can be used to later+-- refer to it.+--+instr :: Instruction a -> CodeGen (IR a)+instr ins = ir (typeOf ins) <$> instr' ins++instr' :: Instruction a -> CodeGen (Operand a)+instr' ins = do+ name <- freshName+ instr_ $ downcast (name := ins)+ return $ LocalReference (typeOf ins) name++-- | Execute an unnamed instruction+--+do_ :: Instruction () -> CodeGen ()+do_ ins = instr_ $ downcast (Do ins)++-- | Add raw assembly instructions to the execution stream+--+instr_ :: LLVM.Named LLVM.Instruction -> CodeGen ()+instr_ ins =+ modify $ \s ->+ case Seq.viewr (blockChain s) of+ Seq.EmptyR -> $internalError "instr_" "empty block chain"+ bs Seq.:> b -> s { blockChain = bs Seq.|> b { instructions = instructions b Seq.|> ins } }+++-- | Return void from a basic block+--+return_ :: CodeGen ()+return_ = void $ terminate Ret++-- | Return a value from a basic block+--+retval_ :: Operand a -> CodeGen ()+retval_ x = void $ terminate (RetVal x)+++-- | Unconditional branch. Return the name of the block that was branched from.+--+br :: Block -> CodeGen Block+br target = terminate $ Br (blockLabel target)+++-- | Conditional branch. Return the name of the block that was branched from.+--+cbr :: IR Bool -> Block -> Block -> CodeGen Block+cbr cond t f = terminate $ CondBr (op scalarType cond) (blockLabel t) (blockLabel f)+++-- | Add a phi node to the top of the current block+--+phi :: forall a. Elt a => [(IR a, Block)] -> CodeGen (IR a)+phi incoming = do+ crit <- fresh+ block <- state $ \s -> case Seq.viewr (blockChain s) of+ Seq.EmptyR -> $internalError "phi" "empty block chain"+ _ Seq.:> b -> ( b, s )+ phi' block crit incoming++phi' :: forall a. Elt a => Block -> IR a -> [(IR a, Block)] -> CodeGen (IR a)+phi' target (IR crit) incoming = IR <$> go (eltType (undefined::a)) crit [ (o,b) | (IR o, b) <- incoming ]+ where+ go :: TupleType t -> Operands t -> [(Operands t, Block)] -> CodeGen (Operands t)+ go UnitTuple OP_Unit _+ = return OP_Unit+ go (PairTuple t2 t1) (OP_Pair n2 n1) inc+ = OP_Pair <$> go t2 n2 [ (x, b) | (OP_Pair x _, b) <- inc ]+ <*> go t1 n1 [ (y, b) | (OP_Pair _ y, b) <- inc ]+ go (SingleTuple t) tup inc+ | LocalReference _ v <- op' t tup = ir' t <$> phi1 target v [ (op' t x, b) | (x, b) <- inc ]+ | otherwise = $internalError "phi" "expected critical variable to be local reference"+++phi1 :: Block -> Name a -> [(Operand a, Block)] -> CodeGen (Operand a)+phi1 target crit incoming =+ let cmp = (==) `on` blockLabel+ update b = b { instructions = downcast (crit := Phi t [ (p,blockLabel) | (p,Block{..}) <- incoming ]) Seq.<| instructions b }+ t = case incoming of+ [] -> $internalError "phi" "no incoming values specified"+ (o,_):_ -> case typeOf o of+ VoidType -> $internalError "phi" "operand has void type"+ PrimType x -> x+ in+ state $ \s ->+ case Seq.findIndexR (cmp target) (blockChain s) of+ Nothing -> $internalError "phi" "unknown basic block"+ Just i -> ( LocalReference (PrimType t) crit+ , s { blockChain = Seq.adjust update i (blockChain s) } )+++-- | Add a termination condition to the current instruction stream. Also return+-- the block that was just terminated.+--+terminate :: Terminator a -> CodeGen Block+terminate term =+ state $ \s ->+ case Seq.viewr (blockChain s) of+ Seq.EmptyR -> $internalError "terminate" "empty block chain"+ bs Seq.:> b -> ( b, s { blockChain = bs Seq.|> b { terminator = downcast term } } )+++-- | Add a global declaration to the symbol table+--+declare :: LLVM.Global -> CodeGen ()+declare g =+ let unique (Just q) | g /= q = $internalError "global" "duplicate symbol"+ | otherwise = Just g+ unique _ = Just g++ name = case LLVM.name g of+ LLVM.Name n -> Label n+ LLVM.UnName n -> Label (show n)+ in+ modify (\s -> s { symbolTable = Map.alter unique name (symbolTable s) })+++-- | Get name of the corresponding intrinsic function implementing a given C+-- function. If there is no mapping, the C function name is used.+--+intrinsic :: String -> CodeGen Label+intrinsic key =+ state $ \s ->+ let name = HashMap.lookupDefault (Label key) key (intrinsicTable s)+ in (name, s)++++-- Metadata+-- ========++-- | Insert a metadata key/value pair into the current module.+--+addMetadata :: String -> [Maybe Metadata] -> CodeGen ()+addMetadata key val =+ modify $ \s ->+ s { metadataTable = HashMap.insertWith (flip (Seq.><)) key (Seq.singleton val) (metadataTable s) }+++-- | Generate the metadata definitions for the file. Every key in the map+-- represents a named metadata definition. The values associated with that key+-- represent the metadata node definitions that will be attached to that+-- definition.+--+createMetadata :: HashMap String (Seq [Maybe Metadata]) -> [LLVM.Definition]+createMetadata md = build (HashMap.toList md) (Seq.empty, Seq.empty)+ where+ build :: [(String, Seq [Maybe Metadata])]+ -> (Seq LLVM.Definition, Seq LLVM.Definition) -- accumulator of (names, metadata)+ -> [LLVM.Definition]+ build [] (k,d) = F.toList (k Seq.>< d)+ build (x:xs) (k,d) =+ let (k',d') = meta (Seq.length d) x+ in build xs (k Seq.|> k', d Seq.>< d')++ meta :: Int -- number of metadata node definitions so far+ -> (String, Seq [Maybe Metadata]) -- current assoc of the metadata map+ -> (LLVM.Definition, Seq LLVM.Definition)+ meta n (key, vals)+ = let node i = LLVM.MetadataNodeID (fromIntegral (i+n))+ nodes = Seq.mapWithIndex (\i x -> LLVM.MetadataNodeDefinition (node i) (downcast (F.toList x))) vals+ name = LLVM.NamedMetadataDefinition key [ node i | i <- [0 .. Seq.length vals - 1] ]+ in+ (name, nodes)+++-- Debug+-- =====++{-# INLINE trace #-}+trace :: String -> a -> a+trace msg = Debug.trace Debug.dump_cc ("llvm: " ++ msg)+
+ Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot view
@@ -0,0 +1,18 @@+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Monad-boot+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Monad (CodeGen)+ where++import Control.Monad.State.Strict++data CodeGenState+newtype CodeGen a = CodeGen { runCodeGen :: State CodeGenState a }+
+ Data/Array/Accelerate/LLVM/CodeGen/Permute.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Permute+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Permute (++ IRPermuteFun(..),+ llvmOfPermuteFun,++ atomicCAS_rmw,+ atomicCAS_cmp,++) where++import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.CodeGen.Type+import Data.Array.Accelerate.LLVM.Foreign++import LLVM.AST.Type.AddrSpace+import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Instruction.Atomic+import LLVM.AST.Type.Instruction.RMW as RMW+import LLVM.AST.Type.Instruction.Volatile+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation++import Control.Applicative+import Prelude+++-- | A forward permutation might be specialised to use atomic instructions to+-- perform the read-modify-write of the output array directly, rather than+-- separately acquiring a lock. The basic operation is always provided in case+-- a backend does not support the atomic operation at that type, or if it is+-- executing sequentially.+--+-- For the atomicRMW case, the function is applied to the new value before+-- feeding to the atomic instruction to combine with the old.+--+data IRPermuteFun arch aenv t where+ IRPermuteFun :: { combine :: IRFun2 arch aenv (e -> e -> e)+ , atomicRMW :: Maybe+ ( RMWOperation+ , IRFun1 arch aenv (e -> e)+ )+ }+ -> IRPermuteFun arch aenv (e -> e -> e)+++-- | Analysis and code generation for forward permutation combination function.+--+-- Specialisation for atomic operations is currently limited to direct+-- applications of the function; that is, we don't dig down underneath+-- let-bindings.+--+llvmOfPermuteFun+ :: forall arch aenv e. Foreign arch+ => arch+ -> DelayedFun aenv (e -> e -> e)+ -> Gamma aenv+ -> IRPermuteFun arch aenv (e -> e -> e)+llvmOfPermuteFun arch fun aenv = IRPermuteFun{..}+ where+ combine = llvmOfFun2 arch fun aenv+ atomicRMW+ -- If the old value is not used (i.e. permute const) then we can just+ -- store the new value directly. Since we do not require the return value+ -- we can do this for any scalar value with a regular Store. This is not+ -- possible for product types however since we use an unzipped+ -- struct-of-array representation; this requires multiple store+ -- instructions so the different fields could get their value from+ -- different threads.+ --+ | Lam (Lam (Body body)) <- fun+ , SingleTuple{} <- eltType (undefined::e)+ , Just body' <- strengthenE latest body+ , fun' <- llvmOfFun1 arch (Lam (Body body')) aenv+ = Just (Exchange, fun')++ -- LLVM natively supports atomic operations on integral types only.+ -- However different targets may support atomic instructions on other+ -- scalar types (for example the NVPTX target supports atomic add and+ -- subtract on floating point values).+ --+ -- Additionally it is possible to implement atomic instructions using+ -- atomic compare-and-swap, which is likely to be more performant than the+ -- generic spin-lock based approach.+ --+ | Lam (Lam (Body body)) <- fun+ , SingleTuple{} <- eltType (undefined::e)+ , Just (rmw, x) <- rmwOp body+ , Just x' <- strengthenE latest x+ , fun' <- llvmOfFun1 arch (Lam (Body x')) aenv+ = Just (rmw, fun')++ | otherwise+ = Nothing++ rmwOp :: DelayedOpenExp (((),e),e) aenv e -> Maybe (RMWOperation, DelayedOpenExp (((),e),e) aenv e)+ rmwOp (PrimApp f xs)+ | PrimAdd{} <- f = (RMW.Add,) <$> extract xs+ | PrimSub{} <- f = (RMW.Sub,) <$> extract xs+ | PrimMin{} <- f = (RMW.Min,) <$> extract xs+ | PrimMax{} <- f = (RMW.Max,) <$> extract xs+ | PrimBOr{} <- f = (RMW.Or,) <$> extract xs+ | PrimBAnd{} <- f = (RMW.And,) <$> extract xs+ | PrimBXor{} <- f = (RMW.Xor,) <$> extract xs+ rmwOp _ = Nothing++ -- Determine which argument to a binary function was the new value being+ -- combined. This only works when the old value is used unmodified, but that+ -- is sufficient for us because otherwise it would not be suitable for the+ -- atomic update operation.+ --+ -- In the permutation function, the old value is given as the second+ -- argument, corresponding to ZeroIdx.+ --+ extract :: DelayedOpenExp (((),e),e) aenv (e,e) -> Maybe (DelayedOpenExp (((),e),e) aenv e)+ extract (Tuple (SnocTup (SnocTup NilTup x) y))+ | Just Refl <- match x (Var ZeroIdx) = Just y+ | Just Refl <- match y (Var ZeroIdx) = Just x+ extract _+ = Nothing++ -- Used with 'strengthenE' to ensure that the expression does not make use+ -- of the old value except in the combination function.+ latest :: (((),e),e) :?> ((),e)+ latest ZeroIdx = Nothing+ latest (SuccIdx ix) = Just ix+++-- Implementation of atomic RMW operation (e.g. (+), (-)) using atomic+-- compare-and-swap instructions, for targets which do not support the native+-- instruction at this type but do support CAS at this bit width.+--+-- > void casAdd(double *addr, double val)+-- > {+-- > uint64_t* addr_i = reinterpret_cast<uint64_t*> addr;+-- > uint64_t old = *addr_i;+-- >+-- > do {+-- > uint64_t expected = old;+-- > uint64_t new = reinterpret_cast<uint64_t>(val + reinterpret_cast<double>(expected));+-- >+-- > uint64_t old = atomicCAS(addr_i, expected, new);+-- > }+-- > while (old != expected);+-- > }+--+atomicCAS_rmw+ :: ScalarType t+ -> (IR t -> CodeGen (IR t))+ -> Operand (Ptr t)+ -> CodeGen ()+atomicCAS_rmw t update addr =+ case t of+ NonNumScalarType s -> nonnum s+ NumScalarType (FloatingNumType f) -> floating f+ NumScalarType (IntegralNumType i) -> integral i++ where+ nonnum :: NonNumType t -> CodeGen ()+ nonnum TypeBool{} = atomicCAS_rmw' t (integralType :: IntegralType Word8) update addr+ nonnum TypeChar{} = atomicCAS_rmw' t (integralType :: IntegralType Word32) update addr+ nonnum TypeCChar{} = atomicCAS_rmw' t (integralType :: IntegralType Word8) update addr+ nonnum TypeCSChar{} = atomicCAS_rmw' t (integralType :: IntegralType Word8) update addr+ nonnum TypeCUChar{} = atomicCAS_rmw' t (integralType :: IntegralType Word8) update addr++ floating :: FloatingType t -> CodeGen ()+ floating TypeFloat{} = atomicCAS_rmw' t (integralType :: IntegralType Word32) update addr+ floating TypeDouble{} = atomicCAS_rmw' t (integralType :: IntegralType Word64) update addr+ floating TypeCFloat{} = atomicCAS_rmw' t (integralType :: IntegralType Word32) update addr+ floating TypeCDouble{} = atomicCAS_rmw' t (integralType :: IntegralType Word64) update addr++ integral :: IntegralType t -> CodeGen ()+ integral i = atomicCAS_rmw' t i update addr+++-- Would like to add a (BitSizeEq t i) constraint, but we can't do that since we+-- have defined (BitSize Bool = 1)+atomicCAS_rmw'+ :: ScalarType t+ -> IntegralType i+ -> (IR t -> CodeGen (IR t))+ -> Operand (Ptr t)+ -> CodeGen ()+atomicCAS_rmw' t i update addr | EltDict <- integralElt i = do+ let si = NumScalarType (IntegralNumType i)+ --+ spin <- newBlock "rmw.spin"+ exit <- newBlock "rmw.exit"++ addr' <- instr' $ PtrCast (PtrPrimType (ScalarPrimType si) defaultAddrSpace) addr+ init' <- instr' $ Load si NonVolatile addr'+ old' <- fresh+ top <- br spin++ setBlock spin+ old <- instr' $ BitCast t (op i old')+ val <- update (ir t old)+ val' <- instr' $ BitCast si (op t val)+ r <- instr' $ CmpXchg i NonVolatile addr' (op i old') val' (CrossThread, AcquireRelease) Monotonic+ done <- instr' $ ExtractValue scalarType ZeroTupIdx r+ next' <- instr' $ ExtractValue si (SuccTupIdx ZeroTupIdx) r++ bot <- cbr (ir scalarType done) exit spin+ _ <- phi' spin old' [(ir i init',top), (ir i next',bot)]++ setBlock exit+++-- Implementation of atomic comparison operators (i.e. min, max) using+-- compare-and-swap, for targets which do not support the native instruction at+-- this type but do support CAS at this bit width. The old value is discarded.+--+-- For example, atomicMin is implemented similarly to the following (however the+-- loop condition is more complex):+--+-- > void casMin(double *addr, double val)+-- > {+-- > double old = *addr;+-- > uint64_t val_i = reinterpret_cast<uint64_t>(val);+-- > uint64_t addr_i = reinterpret_cast<uint64_t*>(addr);+-- >+-- > while (val < old) {+-- > uint64_t assumed_i = reinterpret_cast<uint64_t>(old);+-- > uint64_t old_i = atomicCAS(addr_i, assumed_i, val_i);+-- > old = reinterpret_cast<double>(old_i);+-- > }+-- > }+--+-- If the function returns 'True', then the given value should be written to the+-- address.+--+atomicCAS_cmp+ :: ScalarType t+ -> (ScalarType t -> IR t -> IR t -> CodeGen (IR Bool))+ -> Operand (Ptr t)+ -> Operand t+ -> CodeGen ()+atomicCAS_cmp t cmp addr val =+ case t of+ NonNumScalarType s -> nonnum s+ NumScalarType (FloatingNumType f) -> floating f+ NumScalarType (IntegralNumType i) -> integral i++ where+ nonnum :: NonNumType t -> CodeGen ()+ nonnum TypeBool{} = atomicCAS_cmp' t (integralType :: IntegralType Word8) cmp addr val+ nonnum TypeChar{} = atomicCAS_cmp' t (integralType :: IntegralType Word32) cmp addr val+ nonnum TypeCChar{} = atomicCAS_cmp' t (integralType :: IntegralType Word8) cmp addr val+ nonnum TypeCSChar{} = atomicCAS_cmp' t (integralType :: IntegralType Word8) cmp addr val+ nonnum TypeCUChar{} = atomicCAS_cmp' t (integralType :: IntegralType Word8) cmp addr val++ floating :: FloatingType t -> CodeGen ()+ floating TypeFloat{} = atomicCAS_cmp' t (integralType :: IntegralType Word32) cmp addr val+ floating TypeDouble{} = atomicCAS_cmp' t (integralType :: IntegralType Word64) cmp addr val+ floating TypeCFloat{} = atomicCAS_cmp' t (integralType :: IntegralType Word32) cmp addr val+ floating TypeCDouble{} = atomicCAS_cmp' t (integralType :: IntegralType Word64) cmp addr val++ integral :: IntegralType t -> CodeGen ()+ integral i = atomicCAS_cmp' t i cmp addr val+++-- Would like to add a (BitSizeEq t i) constraint, but we can't do that since we+-- have defined (BitSize Bool = 1)+atomicCAS_cmp'+ :: ScalarType t -- actual type of elements+ -> IntegralType i -- unsigned integral type of same bit size as 't'+ -> (ScalarType t -> IR t -> IR t -> CodeGen (IR Bool))+ -> Operand (Ptr t)+ -> Operand t+ -> CodeGen ()+atomicCAS_cmp' t i cmp addr val | EltDict <- scalarElt t = do+ let si = NumScalarType (IntegralNumType i)+ --+ test <- newBlock "cas.cmp"+ spin <- newBlock "cas.retry"+ exit <- newBlock "cas.exit"++ -- The new value and address to swap cast to integral type+ addr' <- instr' $ PtrCast (PtrPrimType (ScalarPrimType si) defaultAddrSpace) addr+ val' <- instr' $ BitCast si val+ old <- fresh++ -- Read the current value at the address+ start <- instr' $ Load t NonVolatile addr+ top <- br test++ -- Compare the new value with the current contents at that memory slot. If the+ -- comparison fails (e.g. we are computing atomicMin but the new value is+ -- already larger than the current value) then exit.+ setBlock test+ yes <- cmp t (ir t val) old+ _ <- cbr yes spin exit++ -- Attempt to exchange the memory at this location with the new value. The+ -- CmpXchg instruction returns the old value together with a flag indicating+ -- whether or not the swap occurred. If the swap is successful we are done,+ -- otherwise reapply the comparison value with the newly acquired value.+ setBlock spin+ old' <- instr' $ BitCast si (op t old)+ r <- instr' $ CmpXchg i NonVolatile addr' old' val' (CrossThread, AcquireRelease) Monotonic+ done <- instr' $ ExtractValue scalarType ZeroTupIdx r+ next <- instr' $ ExtractValue si (SuccTupIdx ZeroTupIdx) r+ next' <- instr' $ BitCast t next++ bot <- cbr (ir scalarType done) exit test+ _ <- phi' test old [(ir t start,top), (ir t next',bot)]++ setBlock exit+
+ Data/Array/Accelerate/LLVM/CodeGen/Ptr.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Ptr+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Ptr+ where++import LLVM.AST.Type.AddrSpace+import LLVM.AST.Type.Constant+import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation++import Data.Array.Accelerate.Error+++-- Treat an operand as a Ptr type. This is a hack because we can't unpack IR+-- terms of pointer type.+--+asPtr :: AddrSpace -> Operand t -> Operand (Ptr t)+asPtr as x =+ let+ retype :: Type a -> Type (Ptr a)+ retype VoidType = $internalError "asPtr" "unexpected void type"+ retype (PrimType t) = PrimType (PtrPrimType t as)+ --+ rename :: Name a -> Name (Ptr a)+ rename (Name n) = Name n+ rename (UnName n) = UnName n+ in+ case x of+ LocalReference t n -> LocalReference (retype t) (rename n)+ ConstantOperand (GlobalReference t n) -> ConstantOperand (GlobalReference (retype t) (rename n))+ ConstantOperand (UndefConstant t) -> ConstantOperand (UndefConstant (retype t))+ ConstantOperand ScalarConstant{} -> $internalError "asPtr" "unexpected scalar constant"++-- Treat a pointer operand as a scalar. This is a hack because we can't unpack+-- IR terms of pointer types.+--+unPtr :: Operand (Ptr t) -> Operand t+unPtr x =+ let+ retype :: Type (Ptr a) -> Type a+ retype (PrimType (PtrPrimType t _)) = PrimType t+ retype _ = $internalError "unPtr" "expected pointer type"+ --+ rename :: Name (Ptr a) -> Name a+ rename (Name n) = Name n+ rename (UnName n) = UnName n+ in+ case x of+ LocalReference t n -> LocalReference (retype t) (rename n)+ ConstantOperand (GlobalReference t n) -> ConstantOperand (GlobalReference (retype t) (rename n))+ ConstantOperand (UndefConstant t) -> ConstantOperand (UndefConstant (retype t))+ ConstantOperand ScalarConstant{} -> $internalError "unPtr" "unexpected scalar constant"+
+ Data/Array/Accelerate/LLVM/CodeGen/Skeleton.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Skeleton+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Skeleton (++ Skeleton(..),++) where++import Prelude hiding ( id )++-- accelerate+import Data.Array.Accelerate.AST hiding ( Val(..), prj, stencil, stencilAccess )+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Permute+import Data.Array.Accelerate.LLVM.CodeGen.Stencil+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+++-- | A class covering code generation for all of the primitive array operations.+-- Client backends implement an instance of this class.+--+-- Minimal complete definition:+-- * generate+-- * fold, fold1, foldSeg, fold1Seg+-- * scanl, scanl', scanl1, scanr, scanr', scanr1+-- * permute+--+class Skeleton arch where+ {-# MINIMAL generate, fold, fold1, foldSeg, fold1Seg, scanl, scanl', scanl1,+ scanr, scanr', scanr1, permute #-}++ generate :: (Shape sh, Elt e)+ => arch+ -> Gamma aenv+ -> IRFun1 arch aenv (sh -> e)+ -> CodeGen (IROpenAcc arch aenv (Array sh e))++ transform :: (Shape sh, Shape sh', Elt a, Elt b)+ => arch+ -> Gamma aenv+ -> IRFun1 arch aenv (sh' -> sh)+ -> IRFun1 arch aenv (a -> b)+ -> IRDelayed arch aenv (Array sh a)+ -> CodeGen (IROpenAcc arch aenv (Array sh' b))++ map :: (Shape sh, Elt a, Elt b)+ => arch+ -> Gamma aenv+ -> IRFun1 arch aenv (a -> b)+ -> IRDelayed arch aenv (Array sh a)+ -> CodeGen (IROpenAcc arch aenv (Array sh b))++ fold :: (Shape sh, Elt e)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (e -> e -> e)+ -> IRExp arch aenv e+ -> IRDelayed arch aenv (Array (sh:.Int) e)+ -> CodeGen (IROpenAcc arch aenv (Array sh e))++ fold1 :: (Shape sh, Elt e)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (e -> e -> e)+ -> IRDelayed arch aenv (Array (sh:.Int) e)+ -> CodeGen (IROpenAcc arch aenv (Array sh e))++ foldSeg :: (Shape sh, Elt e, Elt i, IsIntegral i)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (e -> e -> e)+ -> IRExp arch aenv e+ -> IRDelayed arch aenv (Array (sh:.Int) e)+ -> IRDelayed arch aenv (Segments i)+ -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))++ fold1Seg :: (Shape sh, Elt e, Elt i, IsIntegral i)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (e -> e -> e)+ -> IRDelayed arch aenv (Array (sh:.Int) e)+ -> IRDelayed arch aenv (Segments i)+ -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))++ scanl :: (Shape sh, Elt e)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (e -> e -> e)+ -> IRExp arch aenv e+ -> IRDelayed arch aenv (Array (sh:.Int) e)+ -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))++ scanl' :: (Shape sh, Elt e)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (e -> e -> e)+ -> IRExp arch aenv e+ -> IRDelayed arch aenv (Array (sh:.Int) e)+ -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e, Array sh e))++ scanl1 :: (Shape sh, Elt e)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (e -> e -> e)+ -> IRDelayed arch aenv (Array (sh:.Int) e)+ -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))++ scanr :: (Shape sh, Elt e)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (e -> e -> e)+ -> IRExp arch aenv e+ -> IRDelayed arch aenv (Array (sh:.Int) e)+ -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))++ scanr' :: (Shape sh, Elt e)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (e -> e -> e)+ -> IRExp arch aenv e+ -> IRDelayed arch aenv (Array (sh:.Int) e)+ -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e, Array sh e))++ scanr1 :: (Shape sh, Elt e)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (e -> e -> e)+ -> IRDelayed arch aenv (Array (sh:.Int) e)+ -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))++ permute :: (Shape sh, Shape sh', Elt e)+ => arch+ -> Gamma aenv+ -> IRPermuteFun arch aenv (e -> e -> e)+ -> IRFun1 arch aenv (sh -> sh')+ -> IRDelayed arch aenv (Array sh e)+ -> CodeGen (IROpenAcc arch aenv (Array sh' e))++ backpermute :: (Shape sh, Shape sh', Elt e)+ => arch+ -> Gamma aenv+ -> IRFun1 arch aenv (sh' -> sh)+ -> IRDelayed arch aenv (Array sh e)+ -> CodeGen (IROpenAcc arch aenv (Array sh' e))++ stencil :: (Stencil sh a stencil, Elt b)+ => arch+ -> Gamma aenv+ -> IRFun1 arch aenv (stencil -> b)+ -> Boundary (IR a)+ -> IRManifest arch aenv (Array sh a)+ -> CodeGen (IROpenAcc arch aenv (Array sh b))++ stencil2 :: (Stencil sh a stencil1, Stencil sh b stencil2, Elt c)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (stencil1 -> stencil2 -> c)+ -> Boundary (IR a)+ -> IRManifest arch aenv (Array sh a)+ -> Boundary (IR b)+ -> IRManifest arch aenv (Array sh b)+ -> CodeGen (IROpenAcc arch aenv (Array sh c))++ -- Default instances+ -- -----------------+ map = defaultMap+ backpermute = defaultBackpermute+ transform = defaultTransform+ stencil = defaultStencil1+ stencil2 = defaultStencil2+++{-# INLINE id #-}+id :: forall arch aenv a. IRFun1 arch aenv (a -> a)+id = IRFun1 return++{-# INLINEABLE defaultMap #-}+defaultMap+ :: (Skeleton arch, Shape sh, Elt a, Elt b)+ => arch+ -> Gamma aenv+ -> IRFun1 arch aenv (a -> b)+ -> IRDelayed arch aenv (Array sh a)+ -> CodeGen (IROpenAcc arch aenv (Array sh b))+defaultMap arch aenv f a+ = transform arch aenv id f a++{-# INLINEABLE defaultBackpermute #-}+defaultBackpermute+ :: (Skeleton arch, Shape sh, Shape sh', Elt e)+ => arch+ -> Gamma aenv+ -> IRFun1 arch aenv (sh' -> sh)+ -> IRDelayed arch aenv (Array sh e)+ -> CodeGen (IROpenAcc arch aenv (Array sh' e))+defaultBackpermute arch aenv p a+ = transform arch aenv p id a++{-# INLINEABLE defaultTransform #-}+defaultTransform+ :: (Skeleton arch, Shape sh', Elt b)+ => arch+ -> Gamma aenv+ -> IRFun1 arch aenv (sh' -> sh)+ -> IRFun1 arch aenv (a -> b)+ -> IRDelayed arch aenv (Array sh a)+ -> CodeGen (IROpenAcc arch aenv (Array sh' b))+defaultTransform arch aenv p f IRDelayed{..}+ = generate arch aenv . IRFun1 $ \ix -> do+ ix' <- app1 p ix+ a <- app1 delayedIndex ix'+ app1 f a++{-# INLINEABLE defaultStencil1 #-}+defaultStencil1+ :: (Skeleton arch, Stencil sh a stencil, Elt b)+ => arch+ -> Gamma aenv+ -> IRFun1 arch aenv (stencil -> b)+ -> Boundary (IR a)+ -> IRManifest arch aenv (Array sh a)+ -> CodeGen (IROpenAcc arch aenv (Array sh b))+defaultStencil1 arch aenv f boundary (IRManifest v)+ = generate arch aenv . IRFun1 $ \ix -> do+ sten <- stencilAccess boundary (irArray (aprj v aenv)) ix+ app1 f sten++{-# INLINEABLE defaultStencil2 #-}+defaultStencil2+ :: (Skeleton arch, Stencil sh a stencil1, Stencil sh b stencil2, Elt c)+ => arch+ -> Gamma aenv+ -> IRFun2 arch aenv (stencil1 -> stencil2 -> c)+ -> Boundary (IR a)+ -> IRManifest arch aenv (Array sh a)+ -> Boundary (IR b)+ -> IRManifest arch aenv (Array sh b)+ -> CodeGen (IROpenAcc arch aenv (Array sh c))+defaultStencil2 arch aenv f boundary1 (IRManifest v1) boundary2 (IRManifest v2)+ = generate arch aenv . IRFun1 $ \ix -> do+ sten1 <- stencilAccess boundary1 (irArray (aprj v1 aenv)) ix+ sten2 <- stencilAccess boundary2 (irArray (aprj v2 aenv)) ix+ app2 f sten1 sten2+
+ Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Stencil+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Stencil+ where++-- accelerate+import Data.Array.Accelerate.AST hiding ( Val(..), prj, stencilAccess )+import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Sugar hiding ( bound )+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Error++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic ( ifThenElse )+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Constant+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import qualified Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A++import Control.Applicative+import Prelude+++-- Generate the stencil pattern including boundary conditions+--+stencilAccess+ :: Stencil sh e stencil+ => Boundary (IR e)+ -> IRArray (Array sh e)+ -> IR sh+ -> CodeGen (IR stencil)+stencilAccess bndy arr = goR stencil (bounded bndy arr)+ where+ -- Base cases, nothing interesting to do here since we know the lower+ -- dimension is Z.+ --+ goR :: StencilR sh e stencil -> (IR sh -> CodeGen (IR e)) -> IR sh -> CodeGen (IR stencil)+ goR StencilRunit3 rf ix+ = let z :. i = unindex ix+ rf' d = do d' <- A.add numType i (int d)+ rf (index z d')+ in+ tup3 <$> rf' (-1)+ <*> rf ix+ <*> rf' 1++ goR StencilRunit5 rf ix+ = let z :. i = unindex ix+ rf' d = do d' <- A.add numType i (int d)+ rf (index z d')+ in+ tup5 <$> rf' (-2)+ <*> rf' (-1)+ <*> rf ix+ <*> rf' 1+ <*> rf' 2++ goR StencilRunit7 rf ix+ = let z :. i = unindex ix+ rf' d = do d' <- A.add numType i (int d)+ rf (index z d')+ in+ tup7 <$> rf' (-3)+ <*> rf' (-2)+ <*> rf' (-1)+ <*> rf ix+ <*> rf' 1+ <*> rf' 2+ <*> rf' 3++ goR StencilRunit9 rf ix+ = let z :. i = unindex ix+ rf' d = do d' <- A.add numType i (int d)+ rf (index z d')+ in+ tup9 <$> rf' (-4)+ <*> rf' (-3)+ <*> rf' (-2)+ <*> rf' (-1)+ <*> rf ix+ <*> rf' 1+ <*> rf' 2+ <*> rf' 3+ <*> rf' 4++ -- Recursive cases. Note that because the stencil pattern is defined with+ -- a cons ordering, whereas shapes (indices) are defined as a snoc list,+ -- when we recurse on the stencil structure we must manipulate the+ -- _innermost_ index component+ --+ goR (StencilRtup3 s1 s2 s3) rf ix =+ let (i, ix') = uncons ix+ rf' 0 ds = rf (cons i ds)+ rf' d ds = do d' <- A.add numType i (int d)+ rf (cons d' ds)+ in+ tup3 <$> goR s1 (rf' (-1)) ix'+ <*> goR s2 (rf' 0) ix'+ <*> goR s3 (rf' 1) ix'++ goR (StencilRtup5 s1 s2 s3 s4 s5) rf ix =+ let (i, ix') = uncons ix+ rf' 0 ds = rf (cons i ds)+ rf' d ds = do d' <- A.add numType i (int d)+ rf (cons d' ds)+ in+ tup5 <$> goR s1 (rf' (-2)) ix'+ <*> goR s2 (rf' (-1)) ix'+ <*> goR s3 (rf' 0) ix'+ <*> goR s4 (rf' 1) ix'+ <*> goR s5 (rf' 2) ix'++ goR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) rf ix =+ let (i, ix') = uncons ix+ rf' 0 ds = rf (cons i ds)+ rf' d ds = do d' <- A.add numType i (int d)+ rf (cons d' ds)+ in+ tup7 <$> goR s1 (rf' (-3)) ix'+ <*> goR s2 (rf' (-2)) ix'+ <*> goR s3 (rf' (-1)) ix'+ <*> goR s4 (rf' 0) ix'+ <*> goR s5 (rf' 1) ix'+ <*> goR s6 (rf' 2) ix'+ <*> goR s7 (rf' 3) ix'++ goR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) rf ix =+ let (i, ix') = uncons ix+ rf' 0 ds = rf (cons i ds)+ rf' d ds = do d' <- A.add numType i (int d)+ rf (cons d' ds)+ in+ tup9 <$> goR s1 (rf' (-4)) ix'+ <*> goR s2 (rf' (-3)) ix'+ <*> goR s3 (rf' (-2)) ix'+ <*> goR s4 (rf' (-1)) ix'+ <*> goR s5 (rf' 0) ix'+ <*> goR s6 (rf' 1) ix'+ <*> goR s7 (rf' 2) ix'+ <*> goR s8 (rf' 3) ix'+ <*> goR s9 (rf' 4) ix'+++-- Apply boundary conditions to the given index+--+bounded+ :: (Shape sh, Elt e)+ => Boundary (IR e)+ -> IRArray (Array sh e)+ -> IR sh+ -> CodeGen (IR e)+bounded bndy arr@IRArray{..} ix =+ case bndy of+ Constant v ->+ if inside irArrayShape ix+ then do i <- intOfIndex irArrayShape ix+ readArray arr i+ else return v+ _ -> do+ ix' <- bound irArrayShape ix+ i <- intOfIndex irArrayShape ix'+ readArray arr i+ --+ where+ -- Return the index, updated to obey the given boundary conditions (clamp,+ -- mirror, or wrap only).+ --+ bound :: forall sh. Shape sh => IR sh -> IR sh -> CodeGen (IR sh)+ bound (IR extent1) (IR extent2) = IR <$> go (eltType (undefined::sh)) extent1 extent2+ where+ go :: TupleType t -> Operands t -> Operands t -> CodeGen (Operands t)+ go UnitTuple OP_Unit OP_Unit+ = return OP_Unit+ go (PairTuple tsh ti) (OP_Pair sh sz) (OP_Pair ih iz)+ = do+ ix' <- go tsh sh ih+ i' <- go ti sz iz+ return $ OP_Pair ix' i'+ go (SingleTuple t) sz iz+ | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)+ = do+ IR i' <- if A.lt t (IR iz) (int 0)+ then+ case bndy of+ Clamp -> return (int 0)+ Mirror -> A.negate numType (IR iz)+ Wrap -> A.add numType (IR sz) (IR iz)+ Constant _ -> $internalError "bound" "unexpected boundary condition"+ else+ if A.gte t (IR iz) (IR sz)+ then+ case bndy of+ Clamp -> A.sub numType (IR sz) (int 1)+ Mirror -> do+ a <- A.add numType (IR sz) (int 2)+ b <- A.sub numType (IR iz) a+ c <- A.sub numType (IR sz) b+ return c+ Wrap -> A.sub numType (IR iz) (IR sz)+ Constant _ -> $internalError "bound" "unexpected boundary condition"+ else+ return (IR iz)+ return i'+ | otherwise+ = $internalError "bound" "expected shape with Int components"++ -- Return whether the index is inside the bounds of the given shape+ --+ inside :: forall sh. Shape sh => IR sh -> IR sh -> CodeGen (IR Bool)+ inside (IR extent1) (IR extent2) = go (eltType (undefined::sh)) extent1 extent2+ where+ go :: TupleType t -> Operands t -> Operands t -> CodeGen (IR Bool)+ go UnitTuple OP_Unit OP_Unit+ = return (bool True)+ go (PairTuple tsh ti) (OP_Pair sh sz) (OP_Pair ih iz)+ = if go ti sz iz+ then go tsh sh ih+ else return (bool False)+ go (SingleTuple t) sz iz+ | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)+ = if A.lt t (IR iz) (int 0)+ then return (bool False)+ else+ if A.gte t (IR iz) (IR sz)+ then return (bool False)+ else return (bool True)+ --+ | otherwise+ = $internalError "bound" "expected shape with Int components"+++-- Utilities+-- ---------++int :: Int -> IR Int+int x = IR (constant (eltType (undefined::Int)) x)++bool :: Bool -> IR Bool+bool b = IR (constant (eltType (undefined::Bool)) b)++unindex :: IR (sh :. Int) -> IR sh :. IR Int+unindex (IR (OP_Pair sh i)) = IR sh :. IR i++index :: IR sh -> IR Int -> IR (sh :. Int)+index (IR sh) (IR i) = IR (OP_Pair sh i)++tup3 :: IR a -> IR b -> IR c -> IR (a,b,c)+tup3 (IR a) (IR b) (IR c) = IR $ OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c++tup5 :: IR a -> IR b -> IR c -> IR d -> IR e -> IR (a,b,c,d,e)+tup5 (IR a) (IR b) (IR c) (IR d) (IR e) =+ IR $ OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c) d) e++tup7 :: IR a -> IR b -> IR c -> IR d -> IR e -> IR f -> IR g -> IR (a,b,c,d,e,f,g)+tup7 (IR a) (IR b) (IR c) (IR d) (IR e) (IR f) (IR g) =+ IR $ OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c) d) e) f) g++tup9 :: IR a -> IR b -> IR c -> IR d -> IR e -> IR f -> IR g -> IR h -> IR i -> IR (a,b,c,d,e,f,g,h,i)+tup9 (IR a) (IR b) (IR c) (IR d) (IR e) (IR f) (IR g) (IR h) (IR i) =+ IR $ OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c) d) e) f) g) h) i+++-- Add an _innermost_ dimension to a shape+--+cons :: forall sh. Shape sh => IR Int -> IR sh -> IR (sh :. Int)+cons (IR ix) (IR extent) = IR $ go (eltType (undefined::sh)) extent+ where+ go :: TupleType t -> Operands t -> Operands (t,Int)+ go UnitTuple OP_Unit = OP_Pair OP_Unit ix+ go (PairTuple th tz) (OP_Pair sh sz)+ | SingleTuple t <- tz+ , Just Refl <- matchScalarType t (scalarType :: ScalarType Int)+ = OP_Pair (go th sh) sz+ go _ _+ = $internalError "cons" "expected shape with Int components"+++-- Remove the _innermost_ dimension to a shape, and return the remainder+--+uncons :: forall sh. Shape sh => IR (sh :. Int) -> (IR Int, IR sh)+uncons (IR extent) = let (ix, extent') = go (eltType (undefined::(sh :. Int))) extent+ in (IR ix, IR extent')+ where+ go :: TupleType (t, Int) -> Operands (t, Int) -> (Operands Int, Operands t)+ go (PairTuple UnitTuple _) (OP_Pair OP_Unit v2) = (v2, OP_Unit)+ go (PairTuple t1@(PairTuple _ t2) _) (OP_Pair v1 v3)+ | SingleTuple t <- t2+ , Just Refl <- matchScalarType t (scalarType :: ScalarType Int)+ = let (i, v1') = go t1 v1+ in (i, OP_Pair v1' v3)+ go _ _+ = $internalError "uncons" "expected shape with Int components"+
+ Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Sugar+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Sugar (++ IRExp, IRFun1, IRFun2,+ IROpenExp, IROpenFun1(..), IROpenFun2(..),+ IROpenAcc(..), IRDelayed(..), IRManifest(..),++ IRArray(..),++) where++import LLVM.AST.Type.AddrSpace+import LLVM.AST.Type.Instruction.Volatile++import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Array.Sugar++import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Module+import {-# SOURCE #-} Data.Array.Accelerate.LLVM.CodeGen.Monad+++-- Scalar expressions+-- ------------------++-- | LLVM IR is in single static assignment, so we need to be able to generate+-- fresh names for each application of a scalar function or expression.+--+type IRExp arch aenv t = IROpenExp arch () aenv t+type IROpenExp arch env aenv t = CodeGen (IR t)++type IRFun1 arch aenv t = IROpenFun1 arch () aenv t+type IRFun2 arch aenv t = IROpenFun2 arch () aenv t++data IROpenFun1 arch env aenv t where+ IRFun1 :: { app1 :: IR a -> IROpenExp arch (env,a) aenv b }+ -> IROpenFun1 arch env aenv (a -> b)++data IROpenFun2 arch env aenv t where+ IRFun2 :: { app2 :: IR a -> IR b -> IROpenExp arch ((env,a),b) aenv c }+ -> IROpenFun2 arch env aenv (a -> b -> c)+++-- Arrays+-- ------++data IROpenAcc arch aenv arrs where+ IROpenAcc :: [Kernel arch aenv arrs]+ -> IROpenAcc arch aenv arrs++data IRDelayed arch aenv a where+ IRDelayed :: (Shape sh, Elt e) =>+ { delayedExtent :: IRExp arch aenv sh+ , delayedIndex :: IRFun1 arch aenv (sh -> e)+ , delayedLinearIndex :: IRFun1 arch aenv (Int -> e)+ }+ -> IRDelayed arch aenv (Array sh e)++data IRManifest arch aenv a where+ IRManifest :: Arrays arrs => Idx aenv arrs -> IRManifest arch aenv arrs+++data IRArray a where+ IRArray :: (Shape sh, Elt e)+ => { irArrayShape :: IR sh -- Array extent+ , irArrayData :: IR e -- Array payloads (should really be 'Ptr e')+ , irArrayAddrSpace :: AddrSpace+ , irArrayVolatility :: Volatility+ }+ -> IRArray (Array sh e)+
+ Data/Array/Accelerate/LLVM/CodeGen/Type.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Type+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.CodeGen.Type+ where++import Data.Array.Accelerate.Array.Sugar++import LLVM.AST.Type.Constant+import LLVM.AST.Type.Global+import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation+++-- | Does the concrete type represent signed or unsigned values?+--+class IsSigned dict where+ signed :: dict a -> Bool+ signed = not . unsigned+ --+ unsigned :: dict a -> Bool+ unsigned = not . signed++instance IsSigned ScalarType where+ signed (NumScalarType t) = signed t+ signed (NonNumScalarType t) = signed t++instance IsSigned BoundedType where+ signed (IntegralBoundedType t) = signed t+ signed (NonNumBoundedType t) = signed t++instance IsSigned NumType where+ signed (IntegralNumType t) = signed t+ signed (FloatingNumType t) = signed t++instance IsSigned IntegralType where+ signed t =+ case t of+ TypeInt _ -> True+ TypeInt8 _ -> True+ TypeInt16 _ -> True+ TypeInt32 _ -> True+ TypeInt64 _ -> True+ TypeCShort _ -> True+ TypeCInt _ -> True+ TypeCLong _ -> True+ TypeCLLong _ -> True+ _ -> False++instance IsSigned FloatingType where+ signed _ = True++instance IsSigned NonNumType where+ signed t =+ case t of+ TypeBool _ -> False+ TypeChar _ -> False+ TypeCUChar _ -> False+ TypeCSChar _ -> True+ TypeCChar _ -> True+++-- | Extract the reified scalar type dictionary of an operation+--+class TypeOf op where+ typeOf :: op a -> Type a++instance TypeOf Instruction where+ typeOf ins =+ case ins of+ Add _ x _ -> typeOf x+ Sub _ x _ -> typeOf x+ Mul _ x _ -> typeOf x+ Quot _ x _ -> typeOf x+ Rem _ x _ -> typeOf x+ Div _ x _ -> typeOf x+ ShiftL _ x _ -> typeOf x+ ShiftRL _ x _ -> typeOf x+ ShiftRA _ x _ -> typeOf x+ BAnd _ x _ -> typeOf x+ BOr _ x _ -> typeOf x+ BXor _ x _ -> typeOf x+ LAnd _ _ -> type'+ LOr _ _ -> type'+ LNot _ -> type'+ ExtractValue t _ _ -> PrimType (ScalarPrimType t)+ Load t _ _ -> PrimType (ScalarPrimType t)+ Store _ _ _ -> VoidType+ GetElementPtr x _ -> typeOf x+ Fence _ -> VoidType+ CmpXchg t _ _ _ _ _ _ -> PrimType $ TupleType+ $ UnitTuple `PairTuple` SingleTuple (NumScalarType (IntegralNumType t))+ `PairTuple` SingleTuple scalarType+ AtomicRMW _ _ _ _ x _ -> typeOf x+ FTrunc _ t _ -> PrimType (ScalarPrimType (NumScalarType (FloatingNumType t)))+ FExt _ t _ -> PrimType (ScalarPrimType (NumScalarType (FloatingNumType t)))+ Trunc _ t _ -> case t of+ IntegralBoundedType i -> PrimType (ScalarPrimType (NumScalarType (IntegralNumType i)))+ NonNumBoundedType n -> PrimType (ScalarPrimType (NonNumScalarType n))+ Ext _ t _ -> case t of+ IntegralBoundedType i -> PrimType (ScalarPrimType (NumScalarType (IntegralNumType i)))+ NonNumBoundedType n -> PrimType (ScalarPrimType (NonNumScalarType n))+ FPToInt _ t _ -> PrimType (ScalarPrimType (NumScalarType (IntegralNumType t)))+ IntToFP _ t _ -> PrimType (ScalarPrimType (NumScalarType (FloatingNumType t)))+ BitCast t _ -> PrimType (ScalarPrimType t)+ PtrCast t _ -> PrimType t+ Cmp{} -> type'+ Select t _ _ _ -> PrimType (ScalarPrimType t)+ Phi t _ -> PrimType t+ Call f _ -> funResultType f+ where+ funResultType :: GlobalFunction args t -> Type t+ funResultType (Lam _ _ l) = funResultType l+ funResultType (Body t _) = t++instance TypeOf Operand where+ typeOf op =+ case op of+ LocalReference t _ -> t+ ConstantOperand c -> typeOf c++instance TypeOf Constant where+ typeOf c =+ case c of+ ScalarConstant t _ -> PrimType (ScalarPrimType t)+ UndefConstant t -> t+ GlobalReference t _ -> t+++-- | Extract some evidence that a reified type implies that type is a valid+-- element+--+data EltDict a where+ EltDict :: Elt a => EltDict a++scalarElt :: ScalarType a -> EltDict a+scalarElt (NumScalarType t) = numElt t+scalarElt (NonNumScalarType t) = nonNumElt t++numElt :: NumType a -> EltDict a+numElt (IntegralNumType t) = integralElt t+numElt (FloatingNumType t) = floatingElt t++integralElt :: IntegralType a -> EltDict a+integralElt TypeInt{} = EltDict+integralElt TypeInt8{} = EltDict+integralElt TypeInt16{} = EltDict+integralElt TypeInt32{} = EltDict+integralElt TypeInt64{} = EltDict+integralElt TypeWord{} = EltDict+integralElt TypeWord8{} = EltDict+integralElt TypeWord16{} = EltDict+integralElt TypeWord32{} = EltDict+integralElt TypeWord64{} = EltDict+integralElt TypeCShort{} = EltDict+integralElt TypeCUShort{} = EltDict+integralElt TypeCInt{} = EltDict+integralElt TypeCUInt{} = EltDict+integralElt TypeCLong{} = EltDict+integralElt TypeCULong{} = EltDict+integralElt TypeCLLong{} = EltDict+integralElt TypeCULLong{} = EltDict++floatingElt :: FloatingType a -> EltDict a+floatingElt TypeFloat{} = EltDict+floatingElt TypeDouble{} = EltDict+floatingElt TypeCFloat{} = EltDict+floatingElt TypeCDouble{} = EltDict++nonNumElt :: NonNumType a -> EltDict a+nonNumElt TypeBool{} = EltDict+nonNumElt TypeChar{} = EltDict+nonNumElt TypeCChar{} = EltDict+nonNumElt TypeCSChar{} = EltDict+nonNumElt TypeCUChar{} = EltDict+
+ Data/Array/Accelerate/LLVM/Compile.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Compile+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Compile (++ Compile(..),+ compileAcc, compileAfun,++ ExecOpenAcc(..), ExecOpenAfun,+ ExecAcc, ExecAfun,+ ExecExp, ExecOpenExp,+ ExecFun, ExecOpenFun++) where++-- accelerate+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Trafo+import qualified Data.Array.Accelerate.Array.Sugar as A++import Data.Array.Accelerate.LLVM.Array.Data+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.Foreign+import Data.Array.Accelerate.LLVM.State++-- standard library+import Data.IntMap ( IntMap )+import Data.Monoid+import Control.Applicative hiding ( Const )+import Prelude hiding ( exp, unzip )+++class Foreign arch => Compile arch where+ data ExecutableR arch++ -- | Compile an accelerate computation into some backend-specific executable format+ --+ compileForTarget+ :: DelayedOpenAcc aenv a+ -> Gamma aenv+ -> LLVM arch (ExecutableR arch)+++-- | Annotate an open array expression with the information necessary to execute+-- each node directly.+--+data ExecOpenAcc arch aenv a where+ ExecAcc :: ExecutableR arch+ -> Gamma aenv+ -> PreOpenAcc (ExecOpenAcc arch) aenv a+ -> ExecOpenAcc arch aenv a++ EmbedAcc :: (Shape sh, Elt e)+ => PreExp (ExecOpenAcc arch) aenv sh+ -> ExecOpenAcc arch aenv (Array sh e)++ UnzipAcc :: (Elt t, Elt e)+ => TupleIdx (TupleRepr t) e+ -> Idx aenv (Array sh t)+ -> ExecOpenAcc arch aenv (Array sh e)+++-- An annotated AST suitable for execution+--+type ExecAcc arch a = ExecOpenAcc arch () a+type ExecAfun arch a = PreAfun (ExecOpenAcc arch) a++type ExecOpenAfun arch = PreOpenAfun (ExecOpenAcc arch)+type ExecOpenExp arch = PreOpenExp (ExecOpenAcc arch)+type ExecOpenFun arch = PreOpenFun (ExecOpenAcc arch)++type ExecExp arch = ExecOpenExp arch ()+type ExecFun arch = ExecOpenFun arch ()+++-- | Initialise code generation, compilation, and data transfer (if required)+-- for an array expression. The returned array computation is annotated to be+-- suitable for execution on the target:+--+-- * A list of the array variables embedded within scalar expressions+--+-- * The compiled LLVM code required to execute the kernel+--+{-# INLINEABLE compileAcc #-}+compileAcc+ :: (Compile arch, Remote arch)+ => DelayedAcc a+ -> LLVM arch (ExecAcc arch a)+compileAcc = compileOpenAcc++{-# INLINEABLE compileAfun #-}+compileAfun+ :: (Compile arch, Remote arch)+ => DelayedAfun f+ -> LLVM arch (ExecAfun arch f)+compileAfun = compileOpenAfun+++{-# INLINEABLE compileOpenAfun #-}+compileOpenAfun+ :: (Compile arch, Remote arch)+ => DelayedOpenAfun aenv f+ -> LLVM arch (PreOpenAfun (ExecOpenAcc arch) aenv f)+compileOpenAfun (Alam l) = Alam <$> compileOpenAfun l+compileOpenAfun (Abody b) = Abody <$> compileOpenAcc b+++{-# INLINEABLE compileOpenAcc #-}+compileOpenAcc+ :: forall arch _aenv _a. (Compile arch, Remote arch)+ => DelayedOpenAcc _aenv _a+ -> LLVM arch (ExecOpenAcc arch _aenv _a)+compileOpenAcc = traverseAcc+ where+ -- Traverse an open array expression in depth-first order. The top-level+ -- function 'traverseAcc' is intended for manifest arrays that we will+ -- generate LLVM code for. Array valued sub-terms, which might be manifest+ -- or delayed, are handled separately.+ --+ -- As the AST is traversed, we also collect a set of the indices of free+ -- array variables that were referred to within scalar sub-expressions.+ -- These will be required during code generation and execution.+ --+ traverseAcc :: forall aenv arrs. DelayedOpenAcc aenv arrs -> LLVM arch (ExecOpenAcc arch aenv arrs)+ traverseAcc Delayed{} = $internalError "compileOpenAcc" "unexpected delayed array"+ traverseAcc topAcc@(Manifest pacc) =+ case pacc of+ -- Environment and control flow+ Avar ix -> node $ pure (Avar ix)+ Alet a b -> node . pure =<< Alet <$> traverseAcc a <*> traverseAcc b+ Apply f a -> node =<< liftA2 Apply <$> travAF f <*> travA a+ Awhile p f a -> node =<< liftA3 Awhile <$> travAF p <*> travAF f <*> travA a+ Acond p t e -> node =<< liftA3 Acond <$> travE p <*> travA t <*> travA e+ Atuple tup -> node =<< liftA Atuple <$> travAtup tup+ Aprj ix tup -> node =<< liftA (Aprj ix) <$> travA tup++ -- Foreign+ Aforeign ff afun a -> foreignA ff afun a++ -- Array injection+ Unit e -> node =<< liftA Unit <$> travE e+ Use arrs -> useRemote (toArr arrs::arrs) >> node (pure (Use arrs))++ -- Index space transforms+ Reshape s a -> node =<< liftA2 Reshape <$> travE s <*> travA a+ Replicate slix e a -> exec =<< liftA2 (Replicate slix) <$> travE e <*> travA a+ Slice slix a e -> exec =<< liftA2 (Slice slix) <$> travA a <*> travE e+ Backpermute e f a -> exec =<< liftA3 Backpermute <$> travE e <*> travF f <*> travA a++ -- Producers+ Generate e f -> exec =<< liftA2 Generate <$> travE e <*> travF f+ Map f a+ | Just b <- unzip f a -> return b+ | otherwise -> exec =<< liftA2 Map <$> travF f <*> travA a+ ZipWith f a b -> exec =<< liftA3 ZipWith <$> travF f <*> travA a <*> travA b+ Transform e p f a -> exec =<< liftA4 Transform <$> travE e <*> travF p <*> travF f <*> travA a++ -- Consumers+ Fold f z a -> exec =<< liftA3 Fold <$> travF f <*> travE z <*> travA a+ Fold1 f a -> exec =<< liftA2 Fold1 <$> travF f <*> travA a+ FoldSeg f e a s -> exec =<< liftA4 FoldSeg <$> travF f <*> travE e <*> travA a <*> travA s+ Fold1Seg f a s -> exec =<< liftA3 Fold1Seg <$> travF f <*> travA a <*> travA s+ Scanl f e a -> exec =<< liftA3 Scanl <$> travF f <*> travE e <*> travA a+ Scanl' f e a -> exec =<< liftA3 Scanl' <$> travF f <*> travE e <*> travA a+ Scanl1 f a -> exec =<< liftA2 Scanl1 <$> travF f <*> travA a+ Scanr f e a -> exec =<< liftA3 Scanr <$> travF f <*> travE e <*> travA a+ Scanr' f e a -> exec =<< liftA3 Scanr' <$> travF f <*> travE e <*> travA a+ Scanr1 f a -> exec =<< liftA2 Scanr1 <$> travF f <*> travA a+ Permute f d g a -> exec =<< liftA4 Permute <$> travF f <*> travA d <*> travF g <*> travA a+ Stencil f b a -> exec =<< liftA2 (flip Stencil b) <$> travF f <*> travM a+ Stencil2 f b1 a1 b2 a2 -> exec =<< liftA3 stencil2 <$> travF f <*> travM a1 <*> travM a2+ where stencil2 f' a1' a2' = Stencil2 f' b1 a1' b2 a2'++ where+ travA :: DelayedOpenAcc aenv a -> LLVM arch (IntMap (Idx' aenv), ExecOpenAcc arch aenv a)+ travA acc = case acc of+ Manifest{} -> pure <$> traverseAcc acc+ Delayed{..} -> liftA2 (const EmbedAcc) <$> travF indexD <*> travE extentD++ travM :: (Shape sh, Elt e)+ => DelayedOpenAcc aenv (Array sh e) -> LLVM arch (IntMap (Idx' aenv), ExecOpenAcc arch aenv (Array sh e))+ travM acc = case acc of+ Manifest (Avar ix) -> (freevar ix,) <$> traverseAcc acc+ _ -> $internalError "compileOpenAcc" "expected array variable"++ travAF :: DelayedOpenAfun aenv f+ -> LLVM arch (IntMap (Idx' aenv), PreOpenAfun (ExecOpenAcc arch) aenv f)+ travAF afun = pure <$> compileOpenAfun afun++ travAtup :: Atuple (DelayedOpenAcc aenv) a+ -> LLVM arch (IntMap (Idx' aenv), Atuple (ExecOpenAcc arch aenv) a)+ travAtup NilAtup = return (pure NilAtup)+ travAtup (SnocAtup t a) = liftA2 SnocAtup <$> travAtup t <*> travA a++ travF :: DelayedOpenFun env aenv t+ -> LLVM arch (IntMap (Idx' aenv), PreOpenFun (ExecOpenAcc arch) env aenv t)+ travF (Body b) = liftA Body <$> travE b+ travF (Lam f) = liftA Lam <$> travF f++ exec :: (IntMap (Idx' aenv), PreOpenAcc (ExecOpenAcc arch) aenv arrs)+ -> LLVM arch (ExecOpenAcc arch aenv arrs)+ exec (aenv, eacc) = do+ let aval = makeGamma aenv+ kernel <- build topAcc aval+ return $! ExecAcc kernel aval eacc++ node :: (IntMap (Idx' aenv'), PreOpenAcc (ExecOpenAcc arch) aenv' arrs')+ -> LLVM arch (ExecOpenAcc arch aenv' arrs')+ node = fmap snd . wrap++ wrap :: (IntMap (Idx' aenv'), PreOpenAcc (ExecOpenAcc arch) aenv' arrs')+ -> LLVM arch (IntMap (Idx' aenv'), ExecOpenAcc arch aenv' arrs')+ wrap = return . liftA (ExecAcc noKernel mempty)++ -- Unzips of manifest array data can be done in constant time without+ -- executing any array programs. We split them out here into a separate+ -- case of 'ExecAcc' so that the execution phase does not have to+ -- continually perform the below check (in particular; 'run1').+ unzip :: PreFun DelayedOpenAcc aenv (a -> b)+ -> DelayedOpenAcc aenv (Array sh a)+ -> Maybe (ExecOpenAcc arch aenv (Array sh b))+ unzip f a+ | Lam (Body (Prj tix (Var ZeroIdx))) <- f+ , Delayed sh index _ <- a+ , Shape u <- sh+ , Manifest (Avar ix) <- u+ , Lam (Body (Index v (Var ZeroIdx))) <- index+ , Just Refl <- match u v+ = Just (UnzipAcc tix ix)+ unzip _ _+ = Nothing++ -- Is there a foreign version available for this backend? If so, we+ -- leave that node in the AST and strip out the remaining terms.+ -- Subsequent phases, if they encounter a foreign node, can assume that+ -- it is for them. Otherwise, drop this term and continue walking down+ -- the list of alternate implementations.+ foreignA :: (Arrays a, Arrays b, A.Foreign asm)+ => asm (a -> b)+ -> DelayedAfun (a -> b)+ -> DelayedOpenAcc aenv a+ -> LLVM arch (ExecOpenAcc arch aenv b)+ foreignA asm f a =+ case foreignAcc (undefined :: arch) asm of+ Just{} -> node =<< liftA (Aforeign asm err) <$> travA a+ Nothing -> traverseAcc $ Manifest (Apply (weaken absurd f) a)+ where+ absurd :: Idx () t -> Idx aenv t+ absurd = absurd+ err = $internalError "compile" "attempt to use fallback in foreign function"++ -- sadness+ noKernel = $internalError "compile" "no kernel module for this node"+++ -- Traverse a scalar expression+ --+ travE :: DelayedOpenExp env aenv e+ -> LLVM arch (IntMap (Idx' aenv), PreOpenExp (ExecOpenAcc arch) env aenv e)+ travE exp =+ case exp of+ Var ix -> return $ pure (Var ix)+ Const c -> return $ pure (Const c)+ PrimConst c -> return $ pure (PrimConst c)+ IndexAny -> return $ pure IndexAny+ IndexNil -> return $ pure IndexNil+ Foreign ff f x -> foreignE ff f x+ --+ Let a b -> liftA2 Let <$> travE a <*> travE b+ IndexCons t h -> liftA2 IndexCons <$> travE t <*> travE h+ IndexHead h -> liftA IndexHead <$> travE h+ IndexTail t -> liftA IndexTail <$> travE t+ IndexSlice slix x s -> liftA2 (IndexSlice slix) <$> travE x <*> travE s+ IndexFull slix x s -> liftA2 (IndexFull slix) <$> travE x <*> travE s+ ToIndex s i -> liftA2 ToIndex <$> travE s <*> travE i+ FromIndex s i -> liftA2 FromIndex <$> travE s <*> travE i+ Tuple t -> liftA Tuple <$> travT t+ Prj ix e -> liftA (Prj ix) <$> travE e+ Cond p t e -> liftA3 Cond <$> travE p <*> travE t <*> travE e+ While p f x -> liftA3 While <$> travF p <*> travF f <*> travE x+ PrimApp f e -> liftA (PrimApp f) <$> travE e+ Index a e -> liftA2 Index <$> travA a <*> travE e+ LinearIndex a e -> liftA2 LinearIndex <$> travA a <*> travE e+ Shape a -> liftA Shape <$> travA a+ ShapeSize e -> liftA ShapeSize <$> travE e+ Intersect x y -> liftA2 Intersect <$> travE x <*> travE y+ Union x y -> liftA2 Union <$> travE x <*> travE y++ where+ travA :: (Shape sh, Elt e)+ => DelayedOpenAcc aenv (Array sh e)+ -> LLVM arch (IntMap (Idx' aenv), ExecOpenAcc arch aenv (Array sh e))+ travA a = do+ a' <- traverseAcc a+ return $ (bind a', a')++ travT :: Tuple (DelayedOpenExp env aenv) t+ -> LLVM arch (IntMap (Idx' aenv), Tuple (PreOpenExp (ExecOpenAcc arch) env aenv) t)+ travT NilTup = return (pure NilTup)+ travT (SnocTup t e) = liftA2 SnocTup <$> travT t <*> travE e++ travF :: DelayedOpenFun env aenv t+ -> LLVM arch (IntMap (Idx' aenv), PreOpenFun (ExecOpenAcc arch) env aenv t)+ travF (Body b) = liftA Body <$> travE b+ travF (Lam f) = liftA Lam <$> travF f++ bind :: (Shape sh, Elt e) => ExecOpenAcc arch aenv (Array sh e) -> IntMap (Idx' aenv)+ bind (ExecAcc _ _ (Avar ix)) = freevar ix+ bind _ = $internalError "bind" "expected array variable"++ foreignE :: (Elt a, Elt b, A.Foreign asm)+ => asm (a -> b)+ -> DelayedFun () (a -> b)+ -> DelayedOpenExp env aenv a+ -> LLVM arch (IntMap (Idx' aenv), PreOpenExp (ExecOpenAcc arch) env aenv b)+ foreignE asm f x =+ case foreignExp (undefined :: arch) asm of+ Just{} -> liftA (Foreign asm err) <$> travE x+ Nothing | Lam (Body b) <- f -> liftA2 Let <$> travE x <*> travE (weaken absurd (weakenE zero b))+ _ -> error "the slow regard of silent things"+ where+ absurd :: Idx () t -> Idx aenv t+ absurd = absurd+ err = $internalError "foreignE" "attempt to use fallback in foreign expression"++ zero :: Idx ((), a) t -> Idx (env,a) t+ zero ZeroIdx = ZeroIdx+ zero notzero = zero notzero+++-- Compilation+-- -----------++-- | Generate code that will be used to evaluate an array computation. Pass the+-- generated code to the appropriate backend handler, which may then, for+-- example, compile and link the code into the running executable.+--+-- TODO:+-- * asynchronous compilation+-- * kernel caching+--+{-# INLINEABLE build #-}+build :: forall arch aenv a. Compile arch+ => DelayedOpenAcc aenv a+ -> Gamma aenv+ -> LLVM arch (ExecutableR arch)+build acc aenv =+ compileForTarget acc aenv+++-- Applicative+-- -----------+--+liftA4 :: Applicative f => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e+liftA4 f a b c d = f <$> a <*> b <*> c <*> d+
+ Data/Array/Accelerate/LLVM/Execute.hs view
@@ -0,0 +1,489 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Execute+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Execute (++ Execute(..), Gamma,+ executeAcc, executeAfun1,++) where++-- accelerate+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) )+import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Interpreter ( evalPrim, evalPrimConst, evalPrj )+import qualified Data.Array.Accelerate.Array.Sugar as S+import qualified Data.Array.Accelerate.Array.Representation as R++import Data.Array.Accelerate.LLVM.Array.Data+import Data.Array.Accelerate.LLVM.Compile+import Data.Array.Accelerate.LLVM.Foreign+import Data.Array.Accelerate.LLVM.State++import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma )++import Data.Array.Accelerate.LLVM.Execute.Async hiding ( join )+import Data.Array.Accelerate.LLVM.Execute.Environment++-- library+import Control.Monad+import Control.Applicative hiding ( Const )+import Prelude hiding ( exp, map, unzip, scanl, scanr, scanl1, scanr1 )+++class (Remote arch, Foreign arch) => Execute arch where+ map :: (Shape sh, Elt b)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh+ -> LLVM arch (Array sh b)++ generate :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh+ -> LLVM arch (Array sh e)++ transform :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh+ -> LLVM arch (Array sh e)++ backpermute :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh+ -> LLVM arch (Array sh e)++ fold :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh :. Int+ -> LLVM arch (Array sh e)++ fold1 :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh :. Int+ -> LLVM arch (Array sh e)++ foldSeg :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh :. Int+ -> DIM1+ -> LLVM arch (Array (sh:.Int) e)++ fold1Seg :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh :. Int+ -> DIM1+ -> LLVM arch (Array (sh:.Int) e)++ scanl :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh :. Int+ -> LLVM arch (Array (sh:.Int) e)++ scanl1 :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh :. Int+ -> LLVM arch (Array (sh:.Int) e)++ scanl' :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh :. Int+ -> LLVM arch (Array (sh:.Int) e, Array sh e)++ scanr :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh :. Int+ -> LLVM arch (Array (sh:.Int) e)++ scanr1 :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh :. Int+ -> LLVM arch (Array (sh:.Int) e)++ scanr' :: (Shape sh, Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> sh :. Int+ -> LLVM arch (Array (sh:.Int) e, Array sh e)++ permute :: (Shape sh, Shape sh', Elt e)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> Bool+ -> sh+ -> Array sh' e+ -> LLVM arch (Array sh' e)++ stencil1 :: (Shape sh, Elt a, Elt b)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> Array sh a+ -> LLVM arch (Array sh b)++ stencil2 :: (Shape sh, Elt a, Elt b, Elt c)+ => ExecutableR arch+ -> Gamma aenv+ -> AvalR arch aenv+ -> StreamR arch+ -> Array sh a+ -> Array sh b+ -> LLVM arch (Array sh c)+++-- Array expression evaluation+-- ---------------------------++-- Computations are evaluated by traversing the AST bottom up, and for each node+-- distinguishing between three cases:+--+-- 1. If it is a Use node, we return a reference to the array data.+--+-- 2. If it is a non-skeleton node, such as a let-binding or shape conversion,+-- then execute directly by updating the environment or similar.+--+-- 3. If it is a skeleton node, then we need to execute the compiled kernel for+-- that node.+--+{-# INLINEABLE executeAcc #-}+executeAcc+ :: forall arch a. Execute arch+ => ExecAcc arch a+ -> LLVM arch a+executeAcc acc =+ get =<< async (executeOpenAcc acc Aempty)++{-# INLINEABLE executeAfun1 #-}+executeAfun1+ :: forall arch a b. (Execute arch, Arrays a)+ => ExecAfun arch (a -> b)+ -> a+ -> LLVM arch b+executeAfun1 afun arrs = do+ AsyncR _ a <- async (useRemoteAsync arrs)+ executeOpenAfun1 afun Aempty a+++-- Execute an open array function of one argument+--+{-# INLINEABLE executeOpenAfun1 #-}+executeOpenAfun1+ :: Execute arch+ => ExecOpenAfun arch aenv (a -> b)+ -> AvalR arch aenv+ -> AsyncR arch a+ -> LLVM arch b+executeOpenAfun1 (Alam (Abody f)) aenv a = get =<< async (executeOpenAcc f (aenv `Apush` a))+executeOpenAfun1 _ _ _ = error "boop!"+++-- Execute an open array computation+--+{-# INLINEABLE executeOpenAcc #-}+executeOpenAcc+ :: forall arch aenv arrs. Execute arch+ => ExecOpenAcc arch aenv arrs+ -> AvalR arch aenv+ -> StreamR arch+ -> LLVM arch arrs+executeOpenAcc EmbedAcc{} _ _ =+ $internalError "execute" "unexpected delayed array"+executeOpenAcc (ExecAcc kernel gamma pacc) aenv stream =+ case pacc of++ -- Array introduction+ Use arr -> return (toArr arr)+ Unit x -> newRemote Z . const =<< travE x++ -- Environment manipulation+ Avar ix -> do let AsyncR event arr = aprj ix aenv+ after stream event+ return arr+ Alet bnd body -> do bnd' <- async (executeOpenAcc bnd aenv)+ body' <- executeOpenAcc body (aenv `Apush` bnd') stream+ return body'+ Apply f a -> executeOpenAfun1 f aenv =<< async (executeOpenAcc a aenv)+ Atuple tup -> toAtuple <$> travT tup+ Aprj ix tup -> evalPrj ix . fromAtuple <$> travA tup+ Acond p t e -> acond t e =<< travE p+ Awhile p f a -> awhile p f =<< travA a++ -- Foreign function+ Aforeign asm _ a -> foreignA asm =<< travA a++ -- Producers+ Map _ a -> map kernel gamma aenv stream =<< extent a+ Generate sh _ -> generate kernel gamma aenv stream =<< travE sh+ Transform sh _ _ _ -> transform kernel gamma aenv stream =<< travE sh+ Backpermute sh _ _ -> backpermute kernel gamma aenv stream =<< travE sh+ Reshape sh a -> reshape <$> travE sh <*> travA a++ -- Consumers+ Fold _ _ a -> fold kernel gamma aenv stream =<< extent a+ Fold1 _ a -> fold1 kernel gamma aenv stream =<< extent a+ FoldSeg _ _ a s -> join $ foldSeg kernel gamma aenv stream <$> extent a <*> extent s+ Fold1Seg _ a s -> join $ fold1Seg kernel gamma aenv stream <$> extent a <*> extent s+ Scanl _ _ a -> scanl kernel gamma aenv stream =<< extent a+ Scanr _ _ a -> scanr kernel gamma aenv stream =<< extent a+ Scanl1 _ a -> scanl1 kernel gamma aenv stream =<< extent a+ Scanr1 _ a -> scanr1 kernel gamma aenv stream =<< extent a+ Scanl' _ _ a -> scanl' kernel gamma aenv stream =<< extent a+ Scanr' _ _ a -> scanr' kernel gamma aenv stream =<< extent a+ Permute _ d _ a -> join $ permute kernel gamma aenv stream (inplace d) <$> extent a <*> travA d+ Stencil _ _ a -> stencil1 kernel gamma aenv stream =<< travA a+ Stencil2 _ _ a _ b -> join $ stencil2 kernel gamma aenv stream <$> travA a <*> travA b++ -- Removed by fusion+ Replicate{} -> fusionError+ Slice{} -> fusionError+ ZipWith{} -> fusionError++ where+ fusionError :: error+ fusionError = $internalError "execute" $ "unexpected fusible material: " ++ showPreAccOp pacc++ -- Term traversals+ -- ---------------+ travA :: ExecOpenAcc arch aenv a -> LLVM arch a+ travA acc = executeOpenAcc acc aenv stream++ travE :: ExecExp arch aenv t -> LLVM arch t+ travE exp = executeExp exp aenv stream++ travT :: Atuple (ExecOpenAcc arch aenv) t -> LLVM arch t+ travT NilAtup = return ()+ travT (SnocAtup t a) = (,) <$> travT t <*> travA a++ -- get the extent of an embedded array+ extent :: Shape sh => ExecOpenAcc arch aenv (Array sh e) -> LLVM arch sh+ extent ExecAcc{} = $internalError "executeOpenAcc" "expected delayed array"+ extent (EmbedAcc sh) = travE sh+ extent (UnzipAcc _ ix) = let AsyncR _ a = aprj ix aenv+ in return $ shape a++ inplace :: ExecOpenAcc arch aenv a -> Bool+ inplace (ExecAcc _ _ Avar{}) = False+ inplace _ = True++ -- Skeleton implementation+ -- -----------------------++ -- Change the shape of an array without altering its contents. This does not+ -- execute any kernel programs.+ reshape :: Shape sh => sh -> Array sh' e -> Array sh e+ reshape sh (Array sh' adata)+ = $boundsCheck "reshape" "shape mismatch" (size sh == R.size sh')+ $ Array (fromElt sh) adata++ -- Array level conditional+ acond :: ExecOpenAcc arch aenv a -> ExecOpenAcc arch aenv a -> Bool -> LLVM arch a+ acond yes _ True = travA yes+ acond _ no False = travA no++ -- Array loops+ awhile :: ExecOpenAfun arch aenv (a -> Scalar Bool)+ -> ExecOpenAfun arch aenv (a -> a)+ -> a+ -> LLVM arch a+ awhile p f a = do+ e <- checkpoint stream+ r <- executeOpenAfun1 p aenv (AsyncR e a)+ ok <- indexRemote r 0+ if ok then awhile p f =<< executeOpenAfun1 f aenv (AsyncR e a)+ else return a++ -- Foreign functions+ foreignA :: (Arrays a, Arrays b, Foreign arch, S.Foreign asm)+ => asm (a -> b)+ -> a+ -> LLVM arch b+ foreignA asm a =+ case foreignAcc (undefined :: arch) asm of+ Just f -> f stream a+ Nothing -> $internalError "foreignA" "failed to recover foreign function the second time"++executeOpenAcc (UnzipAcc tup v) aenv stream = do+ let AsyncR event arr = aprj v aenv+ after stream event+ return $ unzip tup arr+ where+ unzip :: forall t sh e. (Elt t, Elt e) => TupleIdx (TupleRepr t) e -> Array sh t -> Array sh e+ unzip tix (Array sh adata) = Array sh $ go tix (eltType (undefined::t)) adata+ where+ go :: TupleIdx v e -> TupleType t' -> ArrayData t' -> ArrayData (EltRepr e)+ go (SuccTupIdx ix) (PairTuple t _) (AD_Pair x _) = go ix t x+ go ZeroTupIdx (PairTuple _ t) (AD_Pair _ x)+ | Just Refl <- matchTupleType t (eltType (undefined::e)) = x+ go _ _ _ = $internalError "unzip" "inconsistent valuation"+++-- Scalar expression evaluation+-- ----------------------------++{-# INLINEABLE executeExp #-}+executeExp+ :: Execute arch+ => ExecExp arch aenv t+ -> AvalR arch aenv+ -> StreamR arch+ -> LLVM arch t+executeExp exp aenv stream = executeOpenExp exp Empty aenv stream++{-# INLINEABLE executeOpenExp #-}+executeOpenExp+ :: forall arch env aenv exp. Execute arch+ => ExecOpenExp arch env aenv exp+ -> Val env+ -> AvalR arch aenv+ -> StreamR arch+ -> LLVM arch exp+executeOpenExp rootExp env aenv stream = travE rootExp+ where+ travE :: ExecOpenExp arch env aenv t -> LLVM arch t+ travE exp = case exp of+ Var ix -> return (prj ix env)+ Let bnd body -> travE bnd >>= \x -> executeOpenExp body (env `Push` x) aenv stream+ Const c -> return (toElt c)+ PrimConst c -> return (evalPrimConst c)+ PrimApp f x -> evalPrim f <$> travE x+ Tuple t -> toTuple <$> travT t+ Prj ix e -> evalPrj ix . fromTuple <$> travE e+ Cond p t e -> travE p >>= \x -> if x then travE t else travE e+ While p f x -> while p f =<< travE x+ IndexAny -> return Any+ IndexNil -> return Z+ IndexCons sh sz -> (:.) <$> travE sh <*> travE sz+ IndexHead sh -> (\(_ :. ix) -> ix) <$> travE sh+ IndexTail sh -> (\(ix :. _) -> ix) <$> travE sh+ IndexSlice ix slix sh -> indexSlice ix <$> travE slix <*> travE sh+ IndexFull ix slix sl -> indexFull ix <$> travE slix <*> travE sl+ ToIndex sh ix -> toIndex <$> travE sh <*> travE ix+ FromIndex sh ix -> fromIndex <$> travE sh <*> travE ix+ Intersect sh1 sh2 -> intersect <$> travE sh1 <*> travE sh2+ Union sh1 sh2 -> union <$> travE sh1 <*> travE sh2+ ShapeSize sh -> size <$> travE sh+ Shape acc -> shape <$> travA acc+ Index acc ix -> join $ index <$> travA acc <*> travE ix+ LinearIndex acc ix -> join $ indexRemote <$> travA acc <*> travE ix+ Foreign _ f x -> foreignE f x++ -- Helpers+ -- -------++ travT :: Tuple (ExecOpenExp arch env aenv) t -> LLVM arch t+ travT tup = case tup of+ NilTup -> return ()+ SnocTup t e -> (,) <$> travT t <*> travE e++ travA :: ExecOpenAcc arch aenv a -> LLVM arch a+ travA acc = executeOpenAcc acc aenv stream++ foreignE :: ExecFun arch () (a -> b) -> ExecOpenExp arch env aenv a -> LLVM arch b+ foreignE (Lam (Body f)) x = travE x >>= \e -> executeOpenExp f (Empty `Push` e) Aempty stream+ foreignE _ _ = error "I bless the rains down in Africa"++ travF1 :: ExecOpenFun arch env aenv (a -> b) -> a -> LLVM arch b+ travF1 (Lam (Body f)) x = executeOpenExp f (env `Push` x) aenv stream+ travF1 _ _ = error "LANAAAAAAAA!"++ while :: ExecOpenFun arch env aenv (a -> Bool) -> ExecOpenFun arch env aenv (a -> a) -> a -> LLVM arch a+ while p f x = do+ ok <- travF1 p x+ if ok then while p f =<< travF1 f x+ else return x++ indexSlice :: (Elt slix, Elt sh, Elt sl)+ => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+ -> slix+ -> sh+ -> sl+ indexSlice ix slix sh = toElt $ restrict ix (fromElt slix) (fromElt sh)+ where+ restrict :: SliceIndex slix sl co sh -> slix -> sh -> sl+ restrict SliceNil () () = ()+ restrict (SliceAll sliceIdx) (slx, ()) (sl, sz) = (restrict sliceIdx slx sl, sz)+ restrict (SliceFixed sliceIdx) (slx, _) (sl, _) = restrict sliceIdx slx sl++ indexFull :: (Elt slix, Elt sh, Elt sl)+ => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+ -> slix+ -> sl+ -> sh+ indexFull ix slix sl = toElt $ extend ix (fromElt slix) (fromElt sl)+ where+ extend :: SliceIndex slix sl co sh -> slix -> sl -> sh+ extend SliceNil () () = ()+ extend (SliceAll sliceIdx) (slx, ()) (sh, sz) = (extend sliceIdx slx sh, sz)+ extend (SliceFixed sliceIdx) (slx, sz) sh = (extend sliceIdx slx sh, sz)++ index :: Shape sh => Array sh e -> sh -> LLVM arch e+ index arr ix = linearIndex arr (toIndex (shape arr) ix)++ linearIndex :: Array sh e -> Int -> LLVM arch e+ linearIndex arr ix = do+ block =<< checkpoint stream+ indexRemote arr ix+
+ Data/Array/Accelerate/LLVM/Execute/Async.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Execute.Async+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Execute.Async+ where++import Data.Array.Accelerate.LLVM.State+++-- Asynchronous operations+-- -----------------------++-- | The result of a potentially parallel computation which will be available at+-- some point (presumably, in the future). This is essentially a write-once+-- IVar.+--+data AsyncR arch a = AsyncR !(EventR arch) !a++class Async arch where+ -- | Streams (i.e. threads) can execute concurrently with other streams, but+ -- operations within the same stream proceed sequentially.+ --+ type StreamR arch++ -- | An Event marks a point in the execution stream, possibly in the future.+ -- Since execution within a stream is sequential, events can be used to test+ -- the progress of a computation and synchronise between different streams.+ --+ type EventR arch++ -- | Create a new execution stream that can be used to track (potentially+ -- parallel) computations+ --+ fork :: LLVM arch (StreamR arch)++ -- | Mark the given execution stream as closed. The stream may still be+ -- executing in the background, but no new work may be submitted to it.+ --+ join :: StreamR arch -> LLVM arch ()++ -- | Generate a new event at the end of the given execution stream. It will be+ -- filled once all prior work submitted to the stream has completed.+ --+ checkpoint :: StreamR arch -> LLVM arch (EventR arch)++ -- | Make all future work submitted to the given execution stream wait until+ -- the given event has passed. Typically the event is from a different+ -- execution stream, therefore this function is intended to enable+ -- non-blocking cross-stream coordination.+ --+ after :: StreamR arch -> EventR arch -> LLVM arch ()++ -- | Block execution of the calling thread until the given event has been+ -- recorded.+ --+ block :: EventR arch -> LLVM arch ()+++-- | Wait for an asynchronous operation to complete, then return it.+--+get :: Async arch => AsyncR arch a -> LLVM arch a+get (AsyncR e a) = block e >> return a++-- | Execute the given operation asynchronously in a new execution stream.+--+async :: Async arch+ => (StreamR arch -> LLVM arch a)+ -> LLVM arch (AsyncR arch a)+async f = do+ s <- fork+ r <- f s+ e <- checkpoint s+ join s+ return $ AsyncR e r+
+ Data/Array/Accelerate/LLVM/Execute/Environment.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Execute.Environment+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Execute.Environment+ where++-- accelerate+import Data.Array.Accelerate.AST+#if __GLASGOW_HASKELL__ < 800+import Data.Array.Accelerate.Error+#endif++import Data.Array.Accelerate.LLVM.Execute.Async+++-- Array environments+-- ------------------++-- Valuation for an environment of array computations+--+data AvalR arch env where+ Aempty :: AvalR arch ()+ Apush :: AvalR arch env -> AsyncR arch t -> AvalR arch (env, t)+++-- Projection of a value from a valuation using a de Bruijn index.+--+aprj :: Idx env t -> AvalR arch env -> AsyncR arch t+aprj ZeroIdx (Apush _ x) = x+aprj (SuccIdx idx) (Apush val _) = aprj idx val+#if __GLASGOW_HASKELL__ < 800+aprj _ _ = $internalError "aprj" "inconsistent valuation"+#endif+
+ Data/Array/Accelerate/LLVM/Execute/Marshal.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Execute.Marshal+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Execute.Marshal+ where++-- accelerate+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Sugar+import qualified Data.Array.Accelerate.Array.Representation as R++import Data.Array.Accelerate.LLVM.Execute.Async++-- libraries+import Data.DList ( DList )+import qualified Data.DList as DL+++-- Marshalling arguments+-- ---------------------++-- | Convert function arguments into stream a form suitable for CUDA function calls+--+marshal :: Marshalable t args => t -> StreamR t -> args -> IO [ArgR t]+marshal target stream args = DL.toList `fmap` marshal' target stream args+++-- | A type family that is used to specify a concrete kernel argument and+-- stream/context type for a given backend target.+--+type family ArgR target+++-- | Data which can be marshalled as function arguments to kernels.+--+-- These are just the basic definitions that don't require backend specific+-- knowledge. To complete the definition, a backend must provide instances for:+--+-- * Int -- for shapes+-- * ArrayData e -- for array data+-- * (Gamma aenv, Aval aenv) -- for free array variables+--+class Marshalable t a where+ marshal' :: t -> StreamR t -> a -> IO (DList (ArgR t))++instance Marshalable t () where+ marshal' _ _ () = return DL.empty++instance (Marshalable t a, Marshalable t b) => Marshalable t (a, b) where+ marshal' t s (a, b) =+ DL.concat `fmap` sequence [marshal' t s a, marshal' t s b]++instance (Marshalable t a, Marshalable t b, Marshalable t c) => Marshalable t (a, b, c) where+ marshal' t s (a, b, c) =+ DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c]++instance (Marshalable t a, Marshalable t b, Marshalable t c, Marshalable t d) => Marshalable t (a, b, c, d) where+ marshal' t s (a, b, c, d) =+ DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c, marshal' t s d]++instance (Marshalable t a, Marshalable t b, Marshalable t c, Marshalable t d, Marshalable t e)+ => Marshalable t (a, b, c, d, e) where+ marshal' t s (a, b, c, d, e) =+ DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c, marshal' t s d, marshal' t s e]++instance (Marshalable t a, Marshalable t b, Marshalable t c, Marshalable t d, Marshalable t e, Marshalable t f)+ => Marshalable t (a, b, c, d, e, f) where+ marshal' t s (a, b, c, d, e, f) =+ DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c, marshal' t s d, marshal' t s e, marshal' t s f]++instance (Marshalable t a, Marshalable t b, Marshalable t c, Marshalable t d, Marshalable t e, Marshalable t f, Marshalable t g)+ => Marshalable t (a, b, c, d, e, f, g) where+ marshal' t s (a, b, c, d, e, f, g) =+ DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c, marshal' t s d, marshal' t s e, marshal' t s f, marshal' t s g]++instance (Marshalable t a, Marshalable t b, Marshalable t c, Marshalable t d, Marshalable t e, Marshalable t f, Marshalable t g, Marshalable t h)+ => Marshalable t (a, b, c, d, e, f, g, h) where+ marshal' t s (a, b, c, d, e, f, g, h) =+ DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c, marshal' t s d, marshal' t s e, marshal' t s f, marshal' t s g, marshal' t s h]++instance Marshalable t a => Marshalable t [a] where+ marshal' t s = fmap DL.concat . mapM (marshal' t s)++instance (Shape sh, Marshalable t Int, Marshalable t (ArrayData (EltRepr e)))+ => Marshalable t (Array sh e) where+ marshal' t s (Array sh adata) =+ marshal' t s (adata, reverse (R.shapeToList sh))+
+ Data/Array/Accelerate/LLVM/Foreign.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Foreign+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Foreign+ where++import Data.Array.Accelerate.Array.Sugar as A++import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Execute.Async+import Data.Array.Accelerate.LLVM.State++import Data.Typeable+++-- | Interface for backends to provide foreign function implementations for+-- array and scalar expressions.+--+class Foreign arch where+ foreignAcc :: (A.Foreign asm, Typeable a, Typeable b)+ => arch {- dummy -}+ -> asm (a -> b)+ -> Maybe (StreamR arch -> a -> LLVM arch b)+ foreignAcc _ _ = Nothing++ foreignExp :: (A.Foreign asm, Typeable x, Typeable y)+ => arch {- dummy -}+ -> asm (x -> y)+ -> Maybe (IRFun1 arch () (x -> y))+ foreignExp _ _ = Nothing+
+ Data/Array/Accelerate/LLVM/State.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.State+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.State+ where++-- library+import Control.Applicative ( Applicative )+import Control.Concurrent ( forkIO, threadDelay )+import Control.Monad.State ( StateT, MonadState, evalStateT )+import Control.Monad.Catch ( MonadCatch, MonadThrow, MonadMask )+import Control.Monad.Trans ( MonadIO )+import Prelude+++-- Execution state+-- ===============++-- | The LLVM monad, for executing array computations. This consists of a stack+-- for the LLVM execution context as well as the per-execution target specific+-- state 'target'.+--+newtype LLVM target a = LLVM { runLLVM :: StateT target IO a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadState target, MonadThrow, MonadCatch, MonadMask)++-- | Extract the execution state: 'gets llvmTarget'+--+llvmTarget :: t -> t+llvmTarget = id++-- | Evaluate the given target with an LLVM context+--+evalLLVM :: t -> LLVM t a -> IO a+evalLLVM target acc =+ evalStateT (runLLVM acc) target+++-- | Make sure the GC knows that we want to keep this thing alive forever.+--+-- We may want to introduce some way to actually shut this down if, for example,+-- the object has not been accessed in a while (whatever that means).+--+-- Broken in ghci-7.6.1 Mac OS X due to bug #7299.+--+keepAlive :: a -> IO a+keepAlive x = forkIO (caffeine x) >> return x+ where+ caffeine hit = do threadDelay (5 * 1000 * 1000) -- microseconds = 5 seconds+ caffeine hit+
+ Data/Array/Accelerate/LLVM/Target.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Target+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Target+ where++-- llvm-hs+import LLVM.AST.DataLayout ( DataLayout )+++-- | Describes some target specific information needed for code generation+--+class Target t where+ targetTriple :: t {- dummy -} -> Maybe String+ targetDataLayout :: t {- dummy -} -> Maybe DataLayout+
+ Data/Array/Accelerate/LLVM/Util.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Util+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- Generate types for the reified elements of an array computation+--++module Data.Array.Accelerate.LLVM.Util+ where++-- accelerate+import Data.Array.Accelerate.Error++-- standard library+import Data.Word+import qualified Data.Bits as B+++-- | The number of bits in a type+--+{-# INLINE bitSize #-}+bitSize :: B.Bits a => a -> Word32+bitSize x+ | Just s <- B.bitSizeMaybe x = fromIntegral s+ | otherwise = $internalError "bitSize" "could not determine bit size of type"+++-- | Convert a boolean value into an integral value, where False is zero and+-- True is one.+--+{-# INLINE fromBool #-}+fromBool :: Integral i => Bool -> i+fromBool True = 1+fromBool False = 0++-- | Convert an integral value into a boolean. We follow the C convention, where+-- zero is False and all other values represent True.+--+{-# INLINE toBool #-}+toBool :: Integral i => i -> Bool+toBool 0 = False+toBool _ = True+
+ Data/Range/Range.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Range.Range+-- Copyright : [2014..2017] Trevor L. McDonell+-- [2014..2014] Vinod Grover (NVIDIA Corporation)+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Range.Range+ where++-- accelerate+import Data.Array.Accelerate.Error++-- standard library+import Prelude hiding ( take, splitAt )+import GHC.Base ( quotInt )+import Text.Printf++import Data.Sequence ( Seq )+import qualified Data.Sequence as Seq+++-- | A simple range data type+--+data Range+ = Empty -- ^ The empty range+ | IE !Int !Int -- ^ A range span with inclusive left, exclusive right+ deriving Eq++instance Show Range where+ show Empty = "empty"+ show (IE u v)+ | u == pred v = printf "singleton %d" u+ | otherwise = printf "[%d...%d]" u (pred v) -- note display with inclusive ends+++-- | An empty interval+{-# INLINE empty #-}+empty :: Range+empty = Empty++-- | Check if an interval is empty+--+{-# INLINE null #-}+null :: Range -> Bool+null Empty = True+null _ = False++-- | A singleton point+--+{-# INLINE singleton #-}+singleton :: Int -> Range+singleton !a = IE a (succ a)++-- | A range span with exclusive endpoint [u,v).+--+{-# INLINE (...) #-}+(...) :: Int -> Int -> Range+u ... v+ | u <= v = IE u (succ v)+ | otherwise = Empty+infix 3 ...+++-- | /O(1)/. The number of elements defined by the range interval+--+{-# INLINE size #-}+size :: Range -> Int+size range =+ case range of+ Empty -> 0+ IE u v -> v - u+++-- | /O(1)/. Split an interval into two roughly equally sized ranges. If the interval is+-- odd then the first interval gets the extra element.+--+{-# INLINE bisect #-}+bisect :: Range -> (Range, Range)+bisect range =+ case range of+ Empty -> (Empty, Empty)+ IE u v ->+ let n = size range+ m = (n + 1) `quotInt` 2+ o = u+m++ x = IE u o+ y | o < v = IE o v+ | otherwise = Empty+ in+ (x, y)+++-- | /O(1)/. Return the first @n@ elements of the range, or the range itself if+-- @n > size@.+--+{-# INLINE take #-}+take :: Int -> Range -> Range+take !n !_ | n <= 0 = Empty+take !n !range =+ case range of+ Empty -> Empty+ IE u v -> IE u ((u+n) `min` v)+++-- | /O(1)/. A tuple where the first element is the first @n@ elements of the range, and+-- the second is the remainder of the list (if any).+--+{-# INLINE splitAt #-}+splitAt :: Int -> Range -> (Range, Range)+splitAt !n !range | n <= 0 = (Empty, range)+splitAt !n !range =+ case range of+ Empty -> (Empty, Empty)+ IE u v ->+ let m = u+n+ x = IE u (m `min` v)+ y | m < v = IE m v+ | otherwise = Empty+ in+ (x, y)+++-- | If the two ranges are adjacent, return one combined range. The ranges must+-- not be empty.+--+{-# INLINE merge #-}+merge :: Range -> Range -> Maybe Range+merge (IE u v) (IE x y)+ | v == x = Just (IE u y)+ | otherwise = Nothing+merge _ _ = $internalError "merge" "empty range encountered"+++-- | /O(1)/. Add a new range to the end of the given sequence. We assume that+-- ranges are non-overlapping and non-empty. If the new range is adjacent to the+-- last range on the sequence, the ranges are appended.+--+{-# INLINEABLE append #-}+append :: Seq Range -> Range -> Seq Range+append rs Empty = rs+append rs next =+ case Seq.viewr rs of+ Seq.EmptyR -> Seq.singleton next+ rs' Seq.:> prev+ | Just r <- merge prev next -> rs' Seq.|> r+ | otherwise -> rs Seq.|> next+++-- | /O(n log n)/. Compress the given ranges into the fewest number of sections+-- as possible. The ranges must not be empty.+--+{-# INLINEABLE compress #-}+compress :: Seq Range -> Seq Range+compress = squash . Seq.unstableSortBy cmp+ where+ -- Compare by the lower bound. Assume ranges are non-overlapping.+ --+ cmp (IE u _) (IE v _) = compare u v+ cmp _ _ = $internalError "compress" "empty range encountered"++ -- Look at the first two elements, compress them if they are adjacent, and+ -- continue walking down the sequence doing the same. If we merge a range,+ -- be sure to continue attempting to merge that with subsequent ranges+ --+ squash rrs =+ case Seq.viewl rrs of+ Seq.EmptyL -> Seq.empty+ r1 Seq.:< rs -> case Seq.viewl rs of+ Seq.EmptyL -> rrs+ r2 Seq.:< rs'+ | Just r12 <- merge r1 r2 -> squash $ r12 Seq.<| rs'+ | otherwise -> r1 Seq.<| squash rs+
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright (c) [2014..2017] The Accelerate Team. 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 names of the contributors nor of their affiliations 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 ''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 HOLDERS 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.
+ LLVM/AST/Type/AddrSpace.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.AddrSpace+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- Pointers exist in a particular address space+--++module LLVM.AST.Type.AddrSpace (++ AddrSpace(..),+ defaultAddrSpace,++) where++import LLVM.AST.AddrSpace+++-- | The default address space is number zero. The semantics of non-zero address+-- spaces are target dependent.+--+defaultAddrSpace :: AddrSpace+defaultAddrSpace = AddrSpace 0+
+ LLVM/AST/Type/Constant.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Constant+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Constant+ where++import LLVM.AST.Type.Name+import LLVM.AST.Type.Representation+++-- | Although constant expressions and instructions have many similarities,+-- there are important differences - so they're represented using different+-- types in this AST. At the cost of making it harder to move an code back and+-- forth between being constant and not, this approach embeds more of the rules+-- of what IR is legal into the Haskell types.+--+-- <http://llvm.org/docs/LangRef.html#constants>+--+-- <http://llvm.org/docs/LangRef.html#constant-expressions>+--+data Constant a where+ ScalarConstant :: ScalarType a+ -> a+ -> Constant a++ UndefConstant :: Type a+ -> Constant a++ GlobalReference :: Type a+ -> Name a+ -> Constant a+
+ LLVM/AST/Type/Flags.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Flags+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Flags (++ NSW(..), NUW(..), FastMathFlags(..)++) where++import Data.Default.Class+import LLVM.AST.Instruction ( FastMathFlags(..) )+++-- If the 'NoSignedWrap' or 'NoUnsignedWrap' keywords are present, the result+-- value of an operation is a poison value if signed and/or unsigned overflow,+-- respectively, occurs.+--+data NSW = NoSignedWrap | SignedWrap+data NUW = NoUnsignedWrap | UnsignedWrap++instance Default NSW where+ def = SignedWrap++instance Default NUW where+ def = UnsignedWrap++instance Default FastMathFlags where+ def = UnsafeAlgebra+
+ LLVM/AST/Type/Global.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Global+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Global+ where++import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation+++-- | Parameters for functions+--+data Parameter a where+ Parameter :: PrimType a -> Name a -> Parameter a++-- | Attributes for the function call instruction+--+data FunctionAttribute+ = NoReturn+ | NoUnwind+ | ReadOnly+ | ReadNone+ | AlwaysInline+ | NoDuplicate+ | Convergent++-- | Attribute groups are groups of attributes that are referenced by+-- objects within the IR. To use an attribute group, an object must+-- reference its GroupID.+--+data GroupID = GroupID !Word++-- | A global function definition.+--+data GlobalFunction args t where+ Body :: Type r -> Label -> GlobalFunction '[] r+ Lam :: PrimType a -> Operand a -> GlobalFunction args t -> GlobalFunction (a ': args) t++data HList (l :: [*]) where+ HNil :: HList '[]+ HCons :: e -> HList l -> HList (e ': l)+
+ LLVM/AST/Type/Instruction.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Instruction+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Instruction+ where++import LLVM.AST.Type.Global+import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation++import LLVM.AST.Type.Instruction.Atomic+import LLVM.AST.Type.Instruction.Compare+import LLVM.AST.Type.Instruction.RMW+import LLVM.AST.Type.Instruction.Volatile++import Data.Array.Accelerate.Product ( ProdRepr, TupleIdx )++import Prelude hiding ( Ordering )+++-- | Non-terminating instructions+--+-- * <http://llvm.org/docs/LangRef.html#binaryops>+--+-- * <http://llvm.org/docs/LangRef.html#bitwiseops>+--+-- * <http://llvm.org/docs/LangRef.html#memoryops>+--+-- * <http://llvm.org/docs/LangRef.html#otherops>+--+--+data Instruction a where+ -- Binary Operations+ -- <http://llvm.org/docs/LangRef.html#binary-operations>++ -- <http://llvm.org/docs/LangRef.html#add-instruction>+ -- <http://llvm.org/docs/LangRef.html#fadd-instruction>+ --+ Add :: NumType a+ -> Operand a+ -> Operand a+ -> Instruction a++ -- <http://llvm.org/docs/LangRef.html#sub-instruction>+ -- <http://llvm.org/docs/LangRef.html#fsub-instruction>+ --+ Sub :: NumType a+ -> Operand a+ -> Operand a+ -> Instruction a++ -- <http://llvm.org/docs/LangRef.html#mul-instruction>+ -- <http://llvm.org/docs/LangRef.html#fmul-instruction>+ --+ Mul :: NumType a+ -> Operand a+ -> Operand a+ -> Instruction a++ -- <http://llvm.org/docs/LangRef.html#udiv-instruction>+ -- <http://llvm.org/docs/LangRef.html#sdiv-instruction>+ --+ Quot :: IntegralType a+ -> Operand a+ -> Operand a+ -> Instruction a++ -- <http://llvm.org/docs/LangRef.html#urem-instruction>+ -- <http://llvm.org/docs/LangRef.html#srem-instruction>+ --+ Rem :: IntegralType a+ -> Operand a+ -> Operand a+ -> Instruction a++ -- <http://llvm.org/docs/LangRef.html#fdiv-instruction>+ --+ Div :: FloatingType a+ -> Operand a+ -> Operand a+ -> Instruction a++ -- <http://llvm.org/docs/LangRef.html#shl-instruction>+ --+ ShiftL :: IntegralType a+ -> Operand a+ -> Operand a+ -> Instruction a++ -- <http://llvm.org/docs/LangRef.html#lshr-instruction>+ --+ ShiftRL :: IntegralType a+ -> Operand a+ -> Operand a+ -> Instruction a++ -- <http://llvm.org/docs/LangRef.html#ashr-instruction>+ ShiftRA :: IntegralType a+ -> Operand a+ -> Operand a+ -> Instruction a++ -- Bitwise Binary Operations+ -- <http://llvm.org/docs/LangRef.html#bitwise-binary-operations>+ -- <http://llvm.org/docs/LangRef.html#and-instruction>+ --+ BAnd :: IntegralType a+ -> Operand a+ -> Operand a+ -> Instruction a++ LAnd :: Operand Bool+ -> Operand Bool+ -> Instruction Bool++ -- <http://llvm.org/docs/LangRef.html#or-instruction>+ --+ BOr :: IntegralType a+ -> Operand a+ -> Operand a+ -> Instruction a++ LOr :: Operand Bool+ -> Operand Bool+ -> Instruction Bool++ -- <http://llvm.org/docs/LangRef.html#xor-instruction>+ --+ BXor :: IntegralType a+ -> Operand a+ -> Operand a+ -> Instruction a++ LNot :: Operand Bool+ -> Instruction Bool++ -- Vector Operations+ -- <http://llvm.org/docs/LangRef.html#vector-operations>+ -- ExtractElement+ -- InsertElement+ -- ShuffleVector++ -- Aggregate Operations+ -- <http://llvm.org/docs/LangRef.html#aggregate-operations>+ ExtractValue :: ScalarType t+ -> TupleIdx (ProdRepr tup) t+ -> Operand tup+ -> Instruction t++ -- InsertValue++ -- Memory Access and Addressing Operations+ -- <http://llvm.org/docs/LangRef.html#memory-access-and-addressing-operations>+ -- Alloca++ -- <http://llvm.org/docs/LangRef.html#load-instruction>+ --+ Load :: ScalarType a+ -> Volatility+ -> Operand (Ptr a)+ -> Instruction a++ -- <http://llvm.org/docs/LangRef.html#store-instruction>+ --+ Store :: Volatility+ -> Operand (Ptr a)+ -> Operand a+ -> Instruction ()++ -- <http://llvm.org/docs/LangRef.html#getelementptr-instruction>+ --+ GetElementPtr :: Operand (Ptr a)+ -> [Operand i]+ -> Instruction (Ptr a)++ -- <http://llvm.org/docs/LangRef.html#i-fence>+ --+ Fence :: Atomicity+ -> Instruction ()++ -- <http://llvm.org/docs/LangRef.html#cmpxchg-instruction>+ --+ CmpXchg :: IntegralType a+ -> Volatility+ -> Operand (Ptr a)+ -> Operand a -- expected value+ -> Operand a -- replacement value+ -> Atomicity -- on success+ -> MemoryOrdering -- on failure (see docs for restrictions)+ -> Instruction (a, Bool)++ -- <http://llvm.org/docs/LangRef.html#atomicrmw-instruction>+ --+ AtomicRMW :: IntegralType a+ -> Volatility+ -> RMWOperation+ -> Operand (Ptr a)+ -> Operand a+ -> Atomicity+ -> Instruction a++ -- <http://llvm.org/docs/LangRef.html#trunc-to-instruction>+ --+ Trunc :: BoundedType a -- precondition: BitSize a > BitSize b+ -> BoundedType b+ -> Operand a+ -> Instruction b++ -- <http://llvm.org/docs/LangRef.html#fptrunc-to-instruction>+ --+ FTrunc :: FloatingType a -- precondition: BitSize a > BitSize b+ -> FloatingType b+ -> Operand a+ -> Instruction b++ -- <http://llvm.org/docs/LangRef.html#zext-to-instruction>+ -- <http://llvm.org/docs/LangRef.html#sext-to-instruction>+ --+ Ext :: BoundedType a -- precondition: BitSize a < BitSize b+ -> BoundedType b+ -> Operand a+ -> Instruction b++ -- <http://llvm.org/docs/LangRef.html#fpext-to-instruction>+ --+ FExt :: FloatingType a -- precondition: BitSize a < BitSize b+ -> FloatingType b+ -> Operand a+ -> Instruction b++ -- <http://llvm.org/docs/LangRef.html#fptoui-to-instruction>+ -- <http://llvm.org/docs/LangRef.html#fptosi-to-instruction>+ --+ FPToInt :: FloatingType a+ -> IntegralType b+ -> Operand a+ -> Instruction b++ -- <http://llvm.org/docs/LangRef.html#uitofp-to-instruction>+ -- <http://llvm.org/docs/LangRef.html#sitofp-to-instruction>+ --+ IntToFP :: Either (IntegralType a) (NonNumType a)+ -> FloatingType b+ -> Operand a+ -> Instruction b++ -- <http://llvm.org/docs/LangRef.html#bitcast-to-instruction>+ --+ BitCast :: ScalarType b -- precondition: BitSize a == BitSize b+ -> Operand a+ -> Instruction b++ PtrCast :: PrimType (Ptr b) -- precondition: same address space+ -> Operand (Ptr a)+ -> Instruction (Ptr b)++ -- PtrToInt+ -- IntToPtr+ -- AddrSpaceCast++ -- Other Operations+ -- <http://llvm.org/docs/LangRef.html#other-operations>++ -- <http://llvm.org/docs/LangRef.html#icmp-instruction>+ -- <http://llvm.org/docs/LangRef.html#fcmp-instruction>+ --+ -- We treat non-scalar types as signed/unsigned integer values.+ --+ Cmp :: ScalarType a+ -> Ordering+ -> Operand a+ -> Operand a+ -> Instruction Bool++ -- <http://llvm.org/docs/LangRef.html#phi-instruction>+ --+ Phi :: PrimType a+ -> [(Operand a, Label)]+ -> Instruction a++ -- <http://llvm.org/docs/LangRef.html#call-instruction>+ --+ Call :: GlobalFunction args t+ -> [Either GroupID FunctionAttribute]+ -> Instruction t++ -- <http://llvm.org/docs/LangRef.html#select-instruction>+ --+ Select :: ScalarType a+ -> Operand Bool+ -> Operand a+ -> Operand a+ -> Instruction a++ -- VAArg+ -- LandingPad+++-- | Instances of instructions may be given a name, allowing their results to be+-- referenced as Operands. Instructions returning void (e.g. function calls)+-- don't need names.+--+data Named ins a where+ (:=) :: Name a -> ins a -> Named ins a+ Do :: ins () -> Named ins ()+
+ LLVM/AST/Type/Instruction/Atomic.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Instruction.Atomic+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Instruction.Atomic+ where++-- | Atomic instructions take ordering parameters that determine which other+-- atomic instructions on the same address they synchronise with.+--+-- <http://llvm.org/docs/Atomics.html>+--+-- <http://llvm.org/docs/LangRef.html#atomic-memory-ordering-constraints>+--+data MemoryOrdering+ = Unordered+ | Monotonic+ | Acquire+ | Release+ | AcquireRelease+ | SequentiallyConsistent++-- | If an atomic operation is marked as 'singlethread', it only participates in+-- modifications and SequentiallyConsistent total orderings with other+-- operations running in the same thread.+--+-- <http://llvm.org/docs/LangRef.html#singlethread>++data Synchronisation+ = SingleThread+ | CrossThread++-- | The atomicity of an instruction determines the constraints on the+-- visibility of the effects of that instruction.+--+type Atomicity = (Synchronisation, MemoryOrdering)+
+ LLVM/AST/Type/Instruction/Compare.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Instruction.Compare+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Instruction.Compare+ where++-- | Ordering predicate for comparison instructions+--+data Ordering = EQ | NE | LT | LE | GT | GE+
+ LLVM/AST/Type/Instruction/RMW.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Instruction.RMW+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Instruction.RMW+ where++-- | Operations for the 'AtomicRMW' instruction.+--+-- <http://llvm.org/docs/LangRef.html#atomicrmw-instruction>+--+data RMWOperation+ = Exchange+ | Add+ | Sub+ | And+ | Nand+ | Or+ | Xor+ | Min+ | Max+
+ LLVM/AST/Type/Instruction/Volatile.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Instruction.Volatile+-- Copyright : [2016..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Instruction.Volatile+ where++-- | Loads and stores may be marked as 'volatile'. The LLVM optimiser will not+-- change the number of volatile operations or their order with respect to other+-- volatile operations, but may change the order of volatile operations relative+-- to non-volatile operations.+--+-- Note that in LLVM IR, volatility and atomicity are orthogonal; 'volatile' has+-- no cross-thread synchronisation behaviour.+--+-- <http://llvm.org/docs/LangRef.html#volatile-memory-accesses>+--+data Volatility = Volatile | NonVolatile+
+ LLVM/AST/Type/Metadata.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Metadata+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Metadata+ where++import LLVM.AST.Type.Operand+import qualified LLVM.AST.Operand as LLVM+++-- | <http://llvm.org/docs/LangRef.html#metadata>+--+-- Metadata does not have a type, and is not a value.+--+data MetadataNode+ = MetadataNode [Maybe Metadata]+ | MetadataNodeReference LLVM.MetadataNodeID++data Metadata where+ MetadataStringOperand :: String -> Metadata+ MetadataOperand :: Operand a -> Metadata+ MetadataNodeOperand :: MetadataNode -> Metadata+
+ LLVM/AST/Type/Name.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RoleAnnotations #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Name+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Name+ where++import Data.Data+import Data.Word+import Data.String+import Prelude+++-- | Objects of various sorts in LLVM IR are identified by address in the LLVM+-- C++ API, and may be given a string name. When printed to (resp. read from)+-- human-readable LLVM assembly, objects without string names are numbered+-- sequentially (resp. must be numbered sequentially). String names may be+-- quoted, and are quoted when printed if they would otherwise be misread - e.g.+-- when containing special characters.+--+-- > 7+--+-- means the seventh unnamed object, while+--+-- > "7"+--+-- means the object named with the string "7".+--+-- This libraries handling of 'UnName's during translation of the AST down into+-- C++ IR is somewhat more forgiving than the LLVM assembly parser: it does not+-- require that unnamed values be numbered sequentially; however, the numbers of+-- 'UnName's passed into C++ cannot be preserved in the C++ objects. If the C+++-- IR is printed as assembly or translated into a Haskell AST, unnamed nodes+-- will be renumbered sequentially. Thus unnamed node numbers should be thought+-- of as having any scope limited to the 'LLVM.AST.Module' in which they+-- are used.+--+type role Name representational+data Name a+ = Name String -- ^ a string name+ | UnName Word -- ^ a number for a nameless thing+ deriving (Eq, Ord, Read, Show, Typeable, Data)++instance IsString (Name a) where+ fromString = Name+++-- TLM: 'Name' is used a lot over the place, to refer to things like variables+-- as well as basic block labels. In the first case the type makes sense,+-- but what about the latter? Should basic blocks have type '()', or 'IO+-- ()', or the type of the thing that they "return" (although, from memory+-- BBs don't really return anything, they just compute a bunch of stuff+-- which is now in scope. Hmm... the only types that we can truly know are+-- the inputs to the basic block bound via phi nodes, but this is+-- unsatisfactory... )+--++data Label = Label String+ deriving (Eq, Ord, Read, Show, Typeable, Data)++instance IsString Label where+ fromString = Label+
+ LLVM/AST/Type/Operand.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Operand+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Operand (++ Operand(..),++) where++import LLVM.AST.Type.Constant+import LLVM.AST.Type.Name+import LLVM.AST.Type.Representation+++-- | An 'Operand' is roughly anything that is an argument to an 'Instruction'+--+data Operand a where+ LocalReference :: Type a -> Name a -> Operand a+ ConstantOperand :: Constant a -> Operand a+
+ LLVM/AST/Type/Representation.hs view
@@ -0,0 +1,429 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Representation+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Representation (++ module LLVM.AST.Type.Representation,+ module Data.Array.Accelerate.Type,+ Ptr,+ AddrSpace(..),++) where++import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Product++import LLVM.AST.Type.AddrSpace++import Foreign.Ptr+import Text.Printf+++-- Witnesses to observe the LLVM type hierarchy:+--+-- <http://llvm.org/docs/LangRef.html#type-system>+--+-- Type+-- * void+-- * labels & metadata+-- * function types+-- * first class types (basic types)+-- * primitive types (single value types, things that go in registers)+-- * multi (SIMD vectors of primitive types: pointer and single values)+-- * single value types+-- * int+-- * float+-- * ptr (any first-class or function type)+-- * aggregate types+-- * (static) array+-- * [opaque] structure+--+-- We actually don't want to encode this hierarchy as shown above, since it is+-- not precise enough for our purposes. For example, the `Add` instruction+-- operates on operands of integer type or vector (multi) of integer types, so+-- we would probably prefer to add multi-types as a sub-type of IntegralType,+-- FloatingType, etc.+--+-- We minimally extend Accelerate's existing type hierarchy to support the+-- features we require for code generation: void types, pointer types, and+-- simple aggregate structures (for CmpXchg).+--++data Type a where+ VoidType :: Type ()+ PrimType :: PrimType a -> Type a++data PrimType a where+ ScalarPrimType :: ScalarType a -> PrimType a+ PtrPrimType :: PrimType a -> AddrSpace -> PrimType (Ptr a) -- volatility?+ TupleType :: TupleType (ProdRepr a) -> PrimType a -- HAX: aggregate structures+ ArrayType :: Word64 -> ScalarType a -> PrimType a -- HAX: static array+++-- | All types+--++class IsType a where+ type' :: Type a++instance IsType () where+ type' = VoidType++instance IsType Int where+ type' = PrimType primType++instance IsType Int8 where+ type' = PrimType primType++instance IsType Int16 where+ type' = PrimType primType++instance IsType Int32 where+ type' = PrimType primType++instance IsType Int64 where+ type' = PrimType primType++instance IsType Word where+ type' = PrimType primType++instance IsType Word8 where+ type' = PrimType primType++instance IsType Word16 where+ type' = PrimType primType++instance IsType Word32 where+ type' = PrimType primType++instance IsType Word64 where+ type' = PrimType primType++instance IsType CShort where+ type' = PrimType primType++instance IsType CUShort where+ type' = PrimType primType++instance IsType CInt where+ type' = PrimType primType++instance IsType CUInt where+ type' = PrimType primType++instance IsType CLong where+ type' = PrimType primType++instance IsType CULong where+ type' = PrimType primType++instance IsType CLLong where+ type' = PrimType primType++instance IsType CULLong where+ type' = PrimType primType++instance IsType Float where+ type' = PrimType primType++instance IsType Double where+ type' = PrimType primType++instance IsType CFloat where+ type' = PrimType primType++instance IsType CDouble where+ type' = PrimType primType++instance IsType Bool where+ type' = PrimType primType++instance IsType Char where+ type' = PrimType primType++instance IsType CChar where+ type' = PrimType primType++instance IsType CSChar where+ type' = PrimType primType++instance IsType CUChar where+ type' = PrimType primType++instance IsType (Ptr Int) where+ type' = PrimType primType++instance IsType (Ptr Int8) where+ type' = PrimType primType++instance IsType (Ptr Int16) where+ type' = PrimType primType++instance IsType (Ptr Int32) where+ type' = PrimType primType++instance IsType (Ptr Int64) where+ type' = PrimType primType++instance IsType (Ptr Word) where+ type' = PrimType primType++instance IsType (Ptr Word8) where+ type' = PrimType primType++instance IsType (Ptr Word16) where+ type' = PrimType primType++instance IsType (Ptr Word32) where+ type' = PrimType primType++instance IsType (Ptr Word64) where+ type' = PrimType primType++instance IsType (Ptr CShort) where+ type' = PrimType primType++instance IsType (Ptr CUShort) where+ type' = PrimType primType++instance IsType (Ptr CInt) where+ type' = PrimType primType++instance IsType (Ptr CUInt) where+ type' = PrimType primType++instance IsType (Ptr CLong) where+ type' = PrimType primType++instance IsType (Ptr CULong) where+ type' = PrimType primType++instance IsType (Ptr CLLong) where+ type' = PrimType primType++instance IsType (Ptr CULLong) where+ type' = PrimType primType++instance IsType (Ptr Float) where+ type' = PrimType primType++instance IsType (Ptr Double) where+ type' = PrimType primType++instance IsType (Ptr CFloat) where+ type' = PrimType primType++instance IsType (Ptr CDouble) where+ type' = PrimType primType++instance IsType (Ptr Bool) where+ type' = PrimType primType++instance IsType (Ptr Char) where+ type' = PrimType primType++instance IsType (Ptr CChar) where+ type' = PrimType primType++instance IsType (Ptr CSChar) where+ type' = PrimType primType++instance IsType (Ptr CUChar) where+ type' = PrimType primType+++-- | All primitive types+--++class IsPrim a where+ primType :: PrimType a++instance IsPrim Int where+ primType = ScalarPrimType scalarType++instance IsPrim Int8 where+ primType = ScalarPrimType scalarType++instance IsPrim Int16 where+ primType = ScalarPrimType scalarType++instance IsPrim Int32 where+ primType = ScalarPrimType scalarType++instance IsPrim Int64 where+ primType = ScalarPrimType scalarType++instance IsPrim Word where+ primType = ScalarPrimType scalarType++instance IsPrim Word8 where+ primType = ScalarPrimType scalarType++instance IsPrim Word16 where+ primType = ScalarPrimType scalarType++instance IsPrim Word32 where+ primType = ScalarPrimType scalarType++instance IsPrim Word64 where+ primType = ScalarPrimType scalarType++instance IsPrim CShort where+ primType = ScalarPrimType scalarType++instance IsPrim CUShort where+ primType = ScalarPrimType scalarType++instance IsPrim CInt where+ primType = ScalarPrimType scalarType++instance IsPrim CUInt where+ primType = ScalarPrimType scalarType++instance IsPrim CLong where+ primType = ScalarPrimType scalarType++instance IsPrim CULong where+ primType = ScalarPrimType scalarType++instance IsPrim CLLong where+ primType = ScalarPrimType scalarType++instance IsPrim CULLong where+ primType = ScalarPrimType scalarType++instance IsPrim Float where+ primType = ScalarPrimType scalarType++instance IsPrim Double where+ primType = ScalarPrimType scalarType++instance IsPrim CFloat where+ primType = ScalarPrimType scalarType++instance IsPrim CDouble where+ primType = ScalarPrimType scalarType++instance IsPrim Bool where+ primType = ScalarPrimType scalarType++instance IsPrim Char where+ primType = ScalarPrimType scalarType++instance IsPrim CChar where+ primType = ScalarPrimType scalarType++instance IsPrim CSChar where+ primType = ScalarPrimType scalarType++instance IsPrim CUChar where+ primType = ScalarPrimType scalarType++instance IsPrim (Ptr Int) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Int8) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Int16) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Int32) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Int64) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Word) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Word8) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Word16) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Word32) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Word64) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CShort) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CUShort) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CInt) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CUInt) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CLong) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CULong) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CLLong) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CULLong) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Float) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Double) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CFloat) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CDouble) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Bool) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr Char) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CChar) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CSChar) where+ primType = PtrPrimType primType defaultAddrSpace++instance IsPrim (Ptr CUChar) where+ primType = PtrPrimType primType defaultAddrSpace+++instance Show (Type a) where+ show VoidType = "()"+ show (PrimType t) = show t++instance Show (PrimType a) where+ show (ScalarPrimType t) = show t+ show (TupleType t) = show t+ show (ArrayType n t) = printf "[%d x %s]" n (show t)+ show (PtrPrimType t (AddrSpace n)) = printf "Ptr%s %s" a p+ where+ p = show t+ a | n == 0 = ""+ | otherwise = printf "[addrspace %d]" n+ -- p | PtrPrimType{} <- t = printf "(%s)" (show t)+ -- | otherwise = show t+
+ LLVM/AST/Type/Terminator.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Terminator+-- Copyright : [2015..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Terminator+ where++import LLVM.AST.Type.Constant+import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+++-- | <http://llvm.org/docs/LangRef.html#terminators>+--+-- TLM: well, I don't think the types of these terminators make any sense. When+-- we branch, we are not propagating a particular value, just moving the+-- program counter, and anything we have declared already is available for+-- later computations. Maybe, we can make some of this explicit in the+-- @phi@ node?+--+data Terminator a where+ -- <http://llvm.org/docs/LangRef.html#ret-instruction>+ --+ Ret :: Terminator ()++ -- <http://llvm.org/docs/LangRef.html#ret-instruction>+ --+ RetVal :: Operand a+ -> Terminator a+ -- <http://llvm.org/docs/LangRef.html#br-instruction>+ --+ Br :: Label+ -> Terminator ()++ -- <http://llvm.org/docs/LangRef.html#br-instruction>+ --+ CondBr :: Operand Bool+ -> Label+ -> Label+ -> Terminator ()++ -- <http://llvm.org/docs/LangRef.html#switch-instruction>+ --+ Switch :: Operand a+ -> Label+ -> [(Constant a, Label)]+ -> Terminator ()+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ accelerate-llvm.cabal view
@@ -0,0 +1,160 @@+name: accelerate-llvm+version: 1.0.0.0+cabal-version: >= 1.10+tested-with: GHC == 7.8.*+build-type: Simple++synopsis: Accelerate backend generating LLVM+description:+ This library implements direct LLVM IR generation for the /Accelerate/+ language. For further information, refer to the main /Accelerate/ package:+ <http://hackage.haskell.org/package/accelerate>++license: BSD3+license-file: LICENSE+author: Trevor L. McDonell+maintainer: Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+bug-reports: https://github.com/AccelerateHS/accelerate/issues+category: Compilers/Interpreters, Concurrency, Data, Parallelism+++-- Configuration flags+-- -------------------++Flag debug+ Default: True+ Description:+ Enable debug tracing message flags. Note that 'debug' must be enabled in the+ base 'accelerate' package as well. See the 'accelerate' package for usage+ and available options.++Flag bounds-checks+ Default: True+ Description: Enable bounds checking++Flag unsafe-checks+ Default: True+ Description: Enable bounds checking in unsafe operations++Flag internal-checks+ Default: True+ Description: Enable internal consistency checks++Flag chase-lev+ Default: True+ Description: Use a Chase-Lev deque for work stealing+++-- Build configuration+-- -------------------++Library+ exposed-modules:+ -- Accelerate-LLVM middle-end+ Data.Array.Accelerate.LLVM.Analysis.Match+ Data.Array.Accelerate.LLVM.Array.Data+ Data.Array.Accelerate.LLVM.CodeGen+ Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+ Data.Array.Accelerate.LLVM.CodeGen.Array+ Data.Array.Accelerate.LLVM.CodeGen.Base+ Data.Array.Accelerate.LLVM.CodeGen.Constant+ Data.Array.Accelerate.LLVM.CodeGen.Downcast+ Data.Array.Accelerate.LLVM.CodeGen.Environment+ Data.Array.Accelerate.LLVM.CodeGen.Exp+ Data.Array.Accelerate.LLVM.CodeGen.IR+ Data.Array.Accelerate.LLVM.CodeGen.Intrinsic+ Data.Array.Accelerate.LLVM.CodeGen.Loop+ Data.Array.Accelerate.LLVM.CodeGen.Module+ Data.Array.Accelerate.LLVM.CodeGen.Monad+ Data.Array.Accelerate.LLVM.CodeGen.Permute+ Data.Array.Accelerate.LLVM.CodeGen.Ptr+ Data.Array.Accelerate.LLVM.CodeGen.Skeleton+ Data.Array.Accelerate.LLVM.CodeGen.Stencil+ Data.Array.Accelerate.LLVM.CodeGen.Sugar+ Data.Array.Accelerate.LLVM.CodeGen.Type+ Data.Array.Accelerate.LLVM.Compile+ Data.Array.Accelerate.LLVM.Execute+ Data.Array.Accelerate.LLVM.Execute.Async+ Data.Array.Accelerate.LLVM.Execute.Environment+ Data.Array.Accelerate.LLVM.Execute.Marshal+ Data.Array.Accelerate.LLVM.Foreign+ Data.Array.Accelerate.LLVM.State+ Data.Array.Accelerate.LLVM.Target+ Data.Array.Accelerate.LLVM.Util++ -- LLVM code generation+ LLVM.AST.Type.AddrSpace+ LLVM.AST.Type.Constant+ LLVM.AST.Type.Flags+ LLVM.AST.Type.Global+ LLVM.AST.Type.Instruction+ LLVM.AST.Type.Instruction.Atomic+ LLVM.AST.Type.Instruction.Compare+ LLVM.AST.Type.Instruction.RMW+ LLVM.AST.Type.Instruction.Volatile+ LLVM.AST.Type.Metadata+ LLVM.AST.Type.Name+ LLVM.AST.Type.Operand+ LLVM.AST.Type.Representation+ LLVM.AST.Type.Terminator++ -- Scheduler+ Control.Parallel.Meta+ Control.Parallel.Meta.Worker+ Control.Parallel.Meta.Resource.Backoff+ Control.Parallel.Meta.Resource.Single+ Control.Parallel.Meta.Resource.SMP+ Control.Parallel.Meta.Trans.LBS+ Data.Range.Range++ build-depends:+ base >= 4.7 && < 4.10+ , abstract-deque >= 0.3+ , accelerate == 1.0.*+ , containers >= 0.5 && < 0.6+ , data-default-class >= 0.0.1+ , dlist >= 0.6+ , exceptions >= 0.6+ , fclabels >= 2.0+ , llvm-hs >= 3.9+ , llvm-hs-pure >= 3.9+ , mtl >= 2.0+ , mwc-random >= 0.13+ , unordered-containers >= 0.2+ , vector >= 0.10++ default-language:+ Haskell2010++ ghc-options: -O2 -Wall -fwarn-tabs++ if impl(ghc >= 8.0)+ ghc-options: -Wmissed-specialisations++ if flag(chase-lev)+ cpp-options: -DCHASELEV_DEQUE+ build-depends: chaselev-deque >= 0.5++ if flag(debug)+ cpp-options: -DACCELERATE_DEBUG++ if flag(bounds-checks)+ cpp-options: -DACCELERATE_BOUNDS_CHECKS++ if flag(unsafe-checks)+ cpp-options: -DACCELERATE_UNSAFE_CHECKS++ if flag(internal-checks)+ cpp-options: -DACCELERATE_INTERNAL_CHECKS+++source-repository head+ type: git+ location: https://github.com/AccelerateHS/accelerate-llvm.git++source-repository this+ type: git+ tag: 1.0.0.0+ location: https://github.com/AccelerateHS/accelerate-llvm.git++-- vim: nospell