gistfile1.txt

ghci> :main
== TRAINING ====================================================================
[ 393.004] phase sharing-recovery: 16.188 ms (wall), 47.554 ms (cpu)
[ 393.004] phase array-split-lets: 16.546 ms (wall), 47.909 ms (cpu)
[ 393.033] phase array-fusion: 44.864 ms (wall), 98.606 ms (cpu)
[ 393.039] phase compile: 6.072 ms (wall), 23.276 ms (cpu)
[ 393.046] phase link: 7.600 ms (wall), 7.539 ms (cpu)
[ 393.054] phase execute: 7.376 ms (wall), 22.408 ms (cpu), 3.04 x speedup
[ 393.065] phase sharing-recovery: 10.908 ms (wall), 10.928 ms (cpu)
[ 393.066] phase array-split-lets: 11.320 ms (wall), 11.338 ms (cpu)
[ 393.101] phase array-fusion: 46.969 ms (wall), 88.680 ms (cpu)
[ 393.111] phase compile: 10.218 ms (wall), 35.216 ms (cpu)
[ 393.114] phase link: 2.153 ms (wall), 2.166 ms (cpu)
[ 393.122] phase execute: 7.785 ms (wall), 23.900 ms (cpu), 3.07 x speedup
[ 393.132] phase sharing-recovery: 9.822 ms (wall), 9.837 ms (cpu)
[ 393.132] phase array-split-lets: 10.200 ms (wall), 10.208 ms (cpu)
[ 393.164] phase array-fusion: 42.286 ms (wall), 89.289 ms (cpu)
[ 393.170] phase compile: 5.922 ms (wall), 5.964 ms (cpu)
[ 393.173] phase link: 2.529 ms (wall), 2.535 ms (cpu)
[ 393.183] phase execute: 10.009 ms (wall), 28.794 ms (cpu), 2.88 x speedup
[ 393.190] phase sharing-recovery: 6.681 ms (wall), 21.786 ms (cpu)
[ 393.190] phase array-split-lets: 6.966 ms (wall), 22.070 ms (cpu)
[ 393.221] phase array-fusion: 38.346 ms (wall), 70.688 ms (cpu)
[ 393.230] phase compile: 9.045 ms (wall), 41.898 ms (cpu)
[ 393.232] phase link: 1.039 ms (wall), 997.000 µs (cpu)
[ 393.238] phase execute: 6.522 ms (wall), 19.605 ms (cpu), 3.01 x speedup
[ 393.238] phase sharing-recovery: 250.895 ms (wall), 563.669 ms (cpu)
[ 393.238] phase array-split-lets: 250.956 ms (wall), 563.732 ms (cpu)
[ 393.239] phase array-fusion: 251.393 ms (wall), 564.166 ms (cpu)
[ 393.239] phase compile: 254.198 µs (wall), 254.000 µs (cpu)
[ 393.239] phase link: 23.674 µs (wall), 23.000 µs (cpu)
== PREDICTION ==================================================================
[ 393.241] phase execute: 404.601 µs (wall), 1.241 ms (cpu), 3.07 x speedup
Vector (Z :. 1) [0.9670508392662981]
[ 393.241] phase execute: 357.248 µs (wall), 1.121 ms (cpu), 3.14 x speedup
Vector (Z :. 1) [0.9670508392662981]
[ 393.242] phase execute: 561.401 µs (wall), 1.563 ms (cpu), 2.78 x speedup
Vector (Z :. 1) [0.9769150244301588]
[ 393.243] phase execute: 412.332 µs (wall), 1.237 ms (cpu), 3.00 x speedup
Vector (Z :. 1) [0.9792864724102792]
[ 393.243] phase execute: 401.407 µs (wall), 1.050 ms (cpu), 2.62 x speedup
Vector (Z :. 1) [0.9786041642692948]

Network.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts    #-}

import Data.Array.Accelerate                       as A hiding ((!!), length)
import Data.Array.Accelerate.Debug                 as A
import Data.Array.Accelerate.Numeric.LinearAlgebra as A

import Data.Array.Accelerate.LLVM.Native           as CPU

import Control.DeepSeq
import Text.Printf
import Prelude                                     as P


-- Utilities

(^+^) :: (Shape sh, P.Num (Exp c), Elt c) => Acc (Array sh c) -> Acc (Array sh c) -> Acc (Array sh c)
u ^+^ v = A.zipWith (+) u v

(^-^) :: (Shape sh, P.Num (Exp c), Elt c) => Acc (Array sh c) -> Acc (Array sh c) -> Acc (Array sh c)
u ^-^ v = A.zipWith (-) u v

(^*^) :: (Shape sh, P.Num (Exp c), Elt c) => Acc (Array sh c) -> Acc (Array sh c) -> Acc (Array sh c)
u ^*^ v = A.zipWith (*) u v

(*^) :: forall sh a. (Shape sh, Elt a, P.Num (Exp a)) => Exp a -> Acc (Array sh a) -> Acc (Array sh a)
s *^ v = A.map (\x -> x * s) v

type Activation = Exp Double -> Exp Double

sigmoid :: Activation
sigmoid = \z -> 1.0 / (1.0 + exp (-z))

sigmoid' :: Exp Double -> Exp Double
sigmoid' = \z -> sigmoid z * (1 - sigmoid z)

data BasicNetwork = BasicNetwork [Acc (Matrix Double)] [Acc (Vector Double)]
  deriving Show

create :: [Int] -> BasicNetwork
create xs = BasicNetwork weights biases
  where
    weights :: [Acc (Matrix Double)]
    weights = do
      idx <- [1..(length xs - 1)]
      pure $ use $ (fromList ( Z :. xs!!idx :. xs!!(idx - 1) ) [1..] :: Matrix Double)

    biases :: [Acc (Vector Double)]
    biases = do
      idx <- [1..(length xs - 1)]
      pure $ use $ (fromList (Z :. xs!!idx) [1..] :: Vector Double)


feedforward :: BasicNetwork -> Acc (Vector Double) -> Acc (Vector Double)
feedforward (BasicNetwork ws bs) input = res
  where
    res = feedforward' ws bs input
    feedforward' :: [ Acc (Matrix Double) ] -> [ Acc (Vector Double) ] -> Acc (Vector Double) -> Acc (Vector Double)
    feedforward' [] [] a = a
    feedforward' (w:ws) (b:bs) a = feedforward' ws bs $ A.map sigmoid $ (w #> a) ^+^ b

type TrainingData = [ (Acc (Vector Double), Acc (Vector Double)) ]

train :: BasicNetwork -> Int -> TrainingData -> Int -> Double -> BasicNetwork
train net _ _ 0 _         = net
train net n td epochs eta = train net' n td (epochs - 1) eta
  where
    BasicNetwork weights biases = net
    net' = BasicNetwork weights' biases'

    nablaB :: [ Acc (Vector Double) ]
    nablaW :: [ Acc (Matrix Double) ]
    (nablaB, nablaW) = descend td

    --         training data     biases                 weights               for each layer
    descend :: TrainingData -> ([Acc (Vector Double)], [Acc (Matrix Double)])
    descend [(x, y)]     = backprop x y net
    descend ((x, y):td') = (nablaB', nablaW')
      where
        (nablaB, nablaW) = descend td'
        (deltaNablaB, deltaNablaW) = backprop x y net
        nablaB' = [ nb ^+^ dnb | (nb, dnb) <- P.zip nablaB deltaNablaB ]
        nablaW' = [ nw ^+^ dnw | (nw, dnw) <- P.zip nablaW deltaNablaW ]

    velocity = lift (eta / P.fromIntegral n)
    weights' = [w ^-^ (velocity *^ wb) | (w, wb) <- P.zip weights nablaW]
    biases'  = [b ^-^ (velocity *^ nb) | (b, nb) <- P.zip biases  nablaB]


backprop :: Acc (Vector Double) -> Acc (Vector Double) -> BasicNetwork -> ([Acc (Vector Double)], [Acc (Matrix Double)])
backprop actual expected (BasicNetwork ws bs) = (b, w)
  where
    (b, w) = backprop' (P.tail ws) activations zs
    backprop' :: [Acc (Matrix Double)]
              -> [Acc (Vector Double)]
              -> [Acc (Vector Double)]
              -> ([Acc (Vector Double)], [Acc (Matrix Double)])
    backprop' [] [a', a] [z] = ([delta], [nw])
      where
        delta = (cost' a expected) ^*^ (A.map sigmoid' z)
        nw = delta >< a'
    backprop' (w:ws) (a:a':as) (z:zs) = (delta':delta:xs, y:ys)
      where
        sp             = A.map sigmoid' z
        delta'         = ((transpose w) #> delta) ^*^ sp
        y              = delta' >< a
        (delta:xs, ys) = backprop' ws (a':as) zs

    (activations, zs) = calcActivations actual ws bs

    calcActivations x' [] [] = ([x'], [])
    calcActivations x' (w:ws) (b:bs) = (x':as, z:zs)
      where
        (as, zs) = calcActivations x'' ws bs
        z        = (w #> x') ^+^ b
        x''      = A.map sigmoid z

cost' :: Acc (Vector Double) -> Acc (Vector Double) -> Acc (Vector Double)
cost' actual expected = actual ^-^ expected

--------------------------------------------------------------
-- Main.hs
--------------------------------------------------------------

main :: IO ()
main = do
  let
      input    = [[1, 0], [0, 1], [1, 1], [0, 0]]
      expected = [[1],    [1],    [0],    [0]   ]
      xorData  = [ (use $ (A.fromList (Z :. 2) x :: A.Vector Double), use $ (A.fromList (Z :. 1) y :: A.Vector Double)) |
                    (x, y) <- P.zip input expected ]
      net      = create [2, 2, 1]
      net'     = train net 4 xorData 2 2

      net'' = let BasicNetwork ws bs = net'
               in BasicNetwork (P.map (use . CPU.run) ws) (P.map (use . CPU.run) bs)

      feedforward' = CPU.runN (feedforward net'')

      test     = feedforward' (A.fromList (Z:.100) (cycle [0,0,1,0,1,1,0,1]))

      r1       = feedforward' ((A.fromList (Z :. 2) [0, 0] :: A.Vector Double))
      r2       = feedforward' ((A.fromList (Z :. 2) [1, 0] :: A.Vector Double))
      r3       = feedforward' ((A.fromList (Z :. 2) [1, 1] :: A.Vector Double))
      r4       = feedforward' ((A.fromList (Z :. 2) [0, 1] :: A.Vector Double))

  setFlag dump_phases

  putStrLn "== TRAINING ===================================================================="
  feedforward' `seq` return ()

  putStrLn "== PREDICTION =================================================================="
  print $!! test
  print $!! r1
  print $!! r2
  print $!! r3
  print $!! r4


{--
main :: IO ()
main = do
  let input    = [[1, 0], [0, 1], [1, 1], [0, 0]]
  let expected = [[1],    [1],    [0],    [0]   ]
  let xorData = [ (use $ (A.fromList (Z :. 2) x :: A.Vector Double), use $ (A.fromList (Z :. 1) y :: A.Vector Double)) |
                  (x, y) <- Prelude.zip input expected ]
  let net  = AccNet.create [2, 2, 1]
  putStrLn "Begin"
  start <- getCPUTime
  let net' = AccNet.train net 4 xorData 2 2
  putStrLn $ show $ CPU.run $ AccNet.feedforward net' (use $ (A.fromList (Z :. 2) [0, 0] :: A.Vector Double))
  putStrLn $ show $ CPU.run $ AccNet.feedforward net' (use $ (A.fromList (Z :. 2) [1, 0] :: A.Vector Double))
  putStrLn $ show $ CPU.run $ AccNet.feedforward net' (use $ (A.fromList (Z :. 2) [1, 1] :: A.Vector Double))
  putStrLn $ show $ CPU.run $ AccNet.feedforward net' (use $ (A.fromList (Z :. 2) [0, 1] :: A.Vector Double))
  end   <- getCPUTime
  putStrLn "End"
  let diff = (Prelude.fromIntegral (end - start)) / (10 Prelude.^ 12)
  printf "Accelerate: Computation time: %0.3f sec\n" (diff :: Double)
--}