b090b5f · grenade · git.iko.soy

git.iko.soy/grenade

on master help sign in

Make things faster

b090b5fHuw Campbell10 years ago

grenade.cabal+1

compare with master

unifiedsplit

@@ -40,6 +40,7 @@ library

40 Grenade.Core.Shape

41 Grenade.Layers.Crop

42 Grenade.Layers.Convolution

43+ Grenade.Layers.Convolution.Internal

43 Grenade.Layers.Dropout

44 Grenade.Layers.Dropout

44 Grenade.Layers.FullyConnected

45 Grenade.Layers.FullyConnected

45 Grenade.Layers.Flatten

46 Grenade.Layers.Flatten

src/Grenade/Core/Network.hs+1−1

@@ -51,7 +51,7 @@ class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where

51 -- layer gave from the input and the back propagated derivatives from

52 -- the layer above.

53 -- Returns the gradient layer and the derivatives to push back further.

54− runBackards :: x -> S' i -> S' o -> (Gradient x, S' i)

54+ runBackwards :: x -> S' i -> S' o -> (Gradient x, S' i)

56-- | Type of a network.

57-- The [*] type specifies the types of the layers. This is needed for parallel

src/Grenade/Core/Runner.hs+2−2

@@ -32,7 +32,7 @@ backPropagate network input target =

32 -- recursively run the rest of the network, and get the gradients from above.

33 (n', dWs') = go y n

34 -- calculate the gradient for this layer to pass down,

35− (layer', dWs) = runBackards layer x dWs'

35+ (layer', dWs) = runBackwards layer x dWs'

37 in (layer' :/> n', dWs)

@@ -40,7 +40,7 @@ backPropagate network input target =

40 go !x (O layer)

41 = let y = runForwards layer x

42 -- the gradient (how much y affects the error)

43− (layer', dWs) = runBackards layer x (y - target)

43+ (layer', dWs) = runBackwards layer x (y - target)

45 in (OG layer', dWs)

src/Grenade/Layers/Convolution.hs+23−80

@@ -16,26 +16,22 @@ module Grenade.Layers.Convolution (

16 Convolution (..)

17 , Convolution' (..)

18 , randomConvolution

19− , im2col

20− , vid2col

21− , col2im

22− , col2vid

23− , fittingStarts

24 ) where

19 ) where

26−import Control.Monad.Random hiding (fromList)

21+import Control.Monad.Random hiding ( fromList )

27import Data.Maybe

22import Data.Maybe

28import Data.Proxy

23import Data.Proxy

29import Data.Singletons.TypeLits

24import Data.Singletons.TypeLits

30import GHC.TypeLits

25import GHC.TypeLits

32−import Numeric.LinearAlgebra hiding (uniformSample, konst)

27+import Numeric.LinearAlgebra hiding ( uniformSample, konst )

33import qualified Numeric.LinearAlgebra as LA

28import qualified Numeric.LinearAlgebra as LA

34import Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)

29import Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)

36import Grenade.Core.Network

31import Grenade.Core.Network

37import Grenade.Core.Shape

32import Grenade.Core.Shape

38import Grenade.Core.Vector

33import Grenade.Core.Vector

34+import Grenade.Layers.Convolution.Internal

40-- | A convolution layer for a neural network.

36-- | A convolution layer for a neural network.

41-- This uses the im2col convolution trick popularised by Caffe, which essentially turns the

37-- This uses the im2col convolution trick popularised by Caffe, which essentially turns the

@@ -153,18 +149,21 @@ instance ( KnownNat kernelRows

153 runForwards (Convolution kernel _) (S2D' input) =

149 runForwards (Convolution kernel _) (S2D' input) =

154 let ex = extract input

150 let ex = extract input

155 ek = extract kernel

151 ek = extract kernel

152+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

153+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

156 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

154 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

157 ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

155 ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

158 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

156 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

159 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

157 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

160 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

158 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

161 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

159 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

162− c = im2col kx ky sx sy ex

160+ c = im2colUnsafe kx ky sx sy ix iy ex

163 mt = c LA.<> ek

161 mt = c LA.<> ek

164− r = col2vid 1 1 1 1 ox oy mt

162+ r = col2vidUnsafe 1 1 1 1 ox oy mt

165 rs = fmap (fromJust . create) r

163 rs = fmap (fromJust . create) r

166 in S3D' $ mkVector rs

164 in S3D' $ mkVector rs

165+

167− runBackards (Convolution kernel _) (S2D' input) (S3D' dEdy) =

166+ runBackwards (Convolution kernel _) (S2D' input) (S3D' dEdy) =

168 let ex = extract input

167 let ex = extract input

169 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

168 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

170 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

169 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

@@ -174,17 +173,19 @@ instance ( KnownNat kernelRows

174 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

173 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

175 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

174 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

176 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

175 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

176+ fl = fromIntegral $ natVal (Proxy :: Proxy filters)

177+

177− c = im2col kx ky sx sy ex

178+ c = im2colUnsafe kx ky sx sy ix iy ex

178

179

179 eo = vecToList $ fmap extract dEdy

180 eo = vecToList $ fmap extract dEdy

180 ek = extract kernel

181 ek = extract kernel

181

182

182− vs = vid2col 1 1 1 1 ox oy eo

183+ vs = vid2colUnsafe fl 1 1 1 1 ox oy eo

183

184

184 kN = fromJust . create $ tr c LA.<> vs

185 kN = fromJust . create $ tr c LA.<> vs

185 dW = vs LA.<> tr ek

186 dW = vs LA.<> tr ek

186

187

187− xW = col2im kx ky sx sy ix iy dW

188+ xW = col2imUnsafe kx ky sx sy ix iy dW

188 in (Convolution' kN, S2D' . fromJust . create $ xW)

189 in (Convolution' kN, S2D' . fromJust . create $ xW)

189

190

191

@@ -215,12 +216,13 @@ instance ( KnownNat kernelRows

215 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

216 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

216 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

217 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

217 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

218 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

219+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)

218− c = vid2col kx ky sx sy ix iy ex

220+ c = vid2colUnsafe ch kx ky sx sy ix iy ex

219 mt = c LA.<> ek

221 mt = c LA.<> ek

220− r = col2vid 1 1 1 1 ox oy mt

222+ r = col2vidUnsafe 1 1 1 1 ox oy mt

221 rs = fmap (fromJust . create) r

223 rs = fmap (fromJust . create) r

222 in S3D' $ mkVector rs

224 in S3D' $ mkVector rs

223− runBackards (Convolution kernel _) (S3D' input) (S3D' dEdy) =

225+ runBackwards (Convolution kernel _) (S3D' input) (S3D' dEdy) =

224 let ex = vecToList $ fmap extract input

226 let ex = vecToList $ fmap extract input

225 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

227 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

226 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

228 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

@@ -230,77 +232,18 @@ instance ( KnownNat kernelRows

230 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

232 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

231 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

233 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

232 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

234 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

235+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)

236+ fl = fromIntegral $ natVal (Proxy :: Proxy filters)

233− c = vid2col kx ky sx sy ix iy ex

237+ c = vid2colUnsafe ch kx ky sx sy ix iy ex

234

238

235 eo = vecToList $ fmap extract dEdy

239 eo = vecToList $ fmap extract dEdy

236 ek = extract kernel

240 ek = extract kernel

237

241

238− vs = vid2col 1 1 1 1 ox oy eo

242+ vs = vid2colUnsafe fl 1 1 1 1 ox oy eo

239

243

240 kN = fromJust . create $ tr c LA.<> vs

244 kN = fromJust . create $ tr c LA.<> vs

241

245

242 dW = vs LA.<> tr ek

246 dW = vs LA.<> tr ek

243

247

244− xW = col2vid kx ky sx sy ix iy dW

248+ xW = col2vidUnsafe kx ky sx sy ix iy dW

245 in (Convolution' kN, S3D' . mkVector . fmap (fromJust . create) $ xW)

249 in (Convolution' kN, S3D' . mkVector . fmap (fromJust . create) $ xW)

246−

247−im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

248−im2col nrows ncols srows scols m =

249− let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols

250− in im2colFit starts nrows ncols m

251−

252−im2colFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double

253−im2colFit starts nrows ncols m =

254− let imRows = fmap (\start -> flatten $ subMatrix start (nrows, ncols) m) starts

255− in fromRows imRows

256−

257−vid2col :: Int -> Int -> Int -> Int -> Int -> Int -> [Matrix Double] -> Matrix Double

258−vid2col nrows ncols srows scols inputrows inputcols ms =

259− let starts = fittingStarts inputrows nrows srows inputcols ncols scols

260− subs = fmap (im2colFit starts nrows ncols) ms

261− in foldl1 (|||) subs

262−

263−col2vid :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> [Matrix Double]

264−col2vid nrows ncols srows scols drows dcols m =

265− let starts = fittingStart (cols m) (nrows * ncols) (nrows * ncols)

266− r = rows m

267− mats = fmap (\s -> subMatrix (0,s) (r, nrows * ncols) m) starts

268− colSts = fittingStarts drows nrows srows dcols ncols scols

269− in fmap (col2imfit colSts nrows ncols drows dcols) mats

270−

271−col2im :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

272−col2im krows kcols srows scols drows dcols m =

273− let starts = fittingStarts drows krows srows dcols kcols scols

274− in col2imfit starts krows kcols drows dcols m

275−

276−col2imfit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

277−col2imfit starts krows kcols drows dcols m =

278− let indicies = fmap (\[a,b] -> (a,b)) $ sequence [[0..(krows-1)], [0..(kcols-1)]]

279− convs = fmap (zip indicies . toList) . toRows $ m

280− pairs = zip convs starts

281− accums = concat $ fmap (\(conv',(stx',sty')) -> fmap (\((ix,iy), val) -> ((ix + stx', iy + sty'), val)) conv') pairs

282− in accum (LA.konst 0 (drows, dcols)) (+) accums

283−

284−

285−-- | These functions are not even remotely safe, but it's only called from the statically typed

286−-- commands, so we should be good ?!?!?

287−-- Returns the starting sub matrix locations which fit inside the larger matrix for the

288−-- convolution. Takes into account the stride and kernel size.

289−fittingStarts :: Int -> Int -> Int -> Int -> Int -> Int -> [(Int,Int)]

290−fittingStarts nrows kernelrows steprows ncols kernelcols stepcolsh =

291− let rs = fittingStart nrows kernelrows steprows

292− cs = fittingStart ncols kernelcols stepcolsh

293− ls = sequence [rs, cs]

294− in fmap (\[a,b] -> (a,b)) ls

295−

296−-- | Returns the starting sub vector which fit inside the larger vector for the

297−-- convolution. Takes into account the stride and kernel size.

298−fittingStart :: Int -> Int -> Int -> [Int]

299−fittingStart width kernel steps =

300− let go left | left + kernel < width

301− = left : go (left + steps)

302− | left + kernel == width

303− = left : []

304− | otherwise

305− = error "Kernel and step do not fit in matrix."

306− in go 0

src/Grenade/Layers/Convolution/Internal.hsnew file+238

@@ -0,0 +1,238 @@

1+module Grenade.Layers.Convolution.Internal (

2+ im2col

3+-- , im2colUnsafe

4+ , vid2col

5+ , col2im

6+ , col2imFit

7+ , col2vid

9+ , col2vidUnsafe

10+ , col2imUnsafe

11+ , im2colUnsafe

12+ , vid2colUnsafe

13+ , fittingStarts

14+ ) where

15+

16+import Control.Monad.ST

17+import Control.Parallel.Strategies ( parMap, rseq )

18+

19+import Data.STRef

20+import Data.Foldable ( forM_ )

21+

22+import Numeric.LinearAlgebra hiding ( uniformSample, konst )

23+import qualified Numeric.LinearAlgebra as LA

24+import qualified Numeric.LinearAlgebra.Devel as U

25+

26+im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

27+im2col nrows ncols srows scols m =

28+ let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols

29+ in im2colFit starts nrows ncols m

30+

31+im2colFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double

32+im2colFit starts nrows ncols m =

33+ let imRows = fmap (\start -> flatten $ subMatrix start (nrows, ncols) m) starts

34+ in fromRows imRows

35+

36+vid2col :: Int -> Int -> Int -> Int -> Int -> Int -> [Matrix Double] -> Matrix Double

37+vid2col nrows ncols srows scols inputrows inputcols ms =

38+ let starts = fittingStarts inputrows nrows srows inputcols ncols scols

39+ subs = parMap rseq (im2colFit starts nrows ncols) ms

40+ in foldl1 (|||) subs

41+

42+col2vid :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> [Matrix Double]

43+col2vid krows kcols srows scols drows dcols m =

44+ let starts = fittingStart (cols m) (krows * kcols) (krows * kcols)

45+ r = rows m

46+ mats = fmap (\s -> subMatrix (0,s) (r, krows * kcols) m) starts

47+ colSts = fittingStarts drows krows srows dcols kcols scols

48+ in parMap rseq (col2imFit colSts krows kcols drows dcols) mats

49+

50+col2im :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

51+col2im krows kcols srows scols drows dcols m =

52+ let starts = fittingStarts drows krows srows dcols kcols scols

53+ in col2imFit starts krows kcols drows dcols m

54+

55+-- | These functions are not even remotely safe, but it's only called from the statically typed

56+-- commands, so we should be good ?!?!?

57+-- Returns the starting sub matrix locations which fit inside the larger matrix for the

58+-- convolution. Takes into account the stride and kernel size.

59+fittingStarts :: Int -> Int -> Int -> Int -> Int -> Int -> [(Int,Int)]

60+fittingStarts nrows kernelrows steprows ncols kernelcols stepcolsh =

61+ let rs = fittingStart nrows kernelrows steprows

62+ cs = fittingStart ncols kernelcols stepcolsh

63+ ls = sequence [rs, cs]

64+ in fmap (\[a,b] -> (a,b)) ls

65+

66+-- | Returns the starting sub vector which fit inside the larger vector for the

67+-- convolution. Takes into account the stride and kernel size.

68+fittingStart :: Int -> Int -> Int -> [Int]

69+fittingStart width kernel steps =

70+ let go left | left + kernel < width

71+ = left : go (left + steps)

72+ | left + kernel == width

73+ = [left]

74+ | otherwise

75+ = error "Kernel and step do not fit in matrix."

76+ in go 0

77+

78+col2imFit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

79+col2imFit starts krows kcols drows dcols m =

80+ let indicies = (\[a,b] -> (a,b)) <$> sequence [[0..(krows-1)], [0..(kcols-1)]]

81+ convs = fmap (zip indicies . toList) . toRows $ m

82+ pairs = zip convs starts

83+ accums = concatMap (\(conv',(stx',sty')) -> fmap (\((ix,iy), val) -> ((ix + stx', iy + sty'), val)) conv') pairs

84+ in accum (LA.konst 0 (drows, dcols)) (+) accums

85+

86+-- void col2im_cpu(const Dtype* data_col, const int channels,

87+-- const int height, const int width, const int kernel_h, const int kernel_w,

88+-- const int pad_h, const int pad_w,

89+-- const int stride_h, const int stride_w,

90+-- const int dilation_h, const int dilation_w,

91+-- Dtype* data_im) {

92+-- caffe_set(height * width * channels, Dtype(0), data_im);

93+-- const int output_h = (height + 2 * pad_h -

94+-- (dilation_h * (kernel_h - 1) + 1)) / stride_h + 1;

95+-- const int output_w = (width + 2 * pad_w -

96+-- (dilation_w * (kernel_w - 1) + 1)) / stride_w + 1;

97+-- const int channel_size = height * width;

98+-- for (int channel = channels; channel--; data_im += channel_size) {

99+-- for (int kernel_row = 0; kernel_row < kernel_h; kernel_row++) {

100+-- for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {

101+-- int input_row = -pad_h + kernel_row * dilation_h;

102+-- for (int output_rows = output_h; output_rows; output_rows--) {

103+-- if (!is_a_ge_zero_and_a_lt_b(input_row, height)) {

104+-- data_col += output_w;

105+-- } else {

106+-- int input_col = -pad_w + kernel_col * dilation_w;

107+-- for (int output_col = output_w; output_col; output_col--) {

108+-- if (is_a_ge_zero_and_a_lt_b(input_col, width)) {

109+-- data_im[input_row * width + input_col] += *data_col;

110+-- }

111+-- data_col++;

112+-- input_col += stride_w;

113+-- }

114+-- }

115+-- input_row += stride_h;

116+-- }

117+-- }

118+-- }

119+-- }

120+-- }

121+

122+

123+-- let starts = fittingStart (cols m) (krows * kcols) (krows * kcols)

124+-- r = rows m

125+-- mats = fmap (\s -> subMatrix (0,s) (r, krows * kcols) m) starts

126+-- in parMap rseq (col2imUnsafe krows kcols srows scols drows dcols) mats

127+

128+col2imUnsafe :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

129+col2imUnsafe kernelRows kernelColumns strideRows strideColumns destinationRows destinationCols columnMatrix = U.runSTMatrix $ do

130+ let columnMatrixRows = rows columnMatrix

131+

132+ dataIm <- U.newMatrix 0 destinationRows destinationCols

133+

134+ offsetR <- newSTRef 0

135+ offsetC <- newSTRef 0

136+

137+ forM_ [0 .. columnMatrixRows - 1] $ \ir -> do

138+ inputColumn <- newSTRef 0

139+ forM_ [0 .. kernelRows -1] $ \kr ->

140+ forM_ [0 .. kernelColumns -1] $ \kc -> do

141+ ic <- readSTRef inputColumn

142+ offsetR' <- readSTRef offsetR

143+ offsetC' <- readSTRef offsetC

144+ U.modifyMatrix dataIm (kr + offsetR') (kc + offsetC') (+ atIndex columnMatrix (ir,ic))

145+ modifySTRef inputColumn (+1)

146+

147+ offsetC' <- readSTRef offsetC

148+ if offsetC' + kernelColumns < destinationCols

149+ then modifySTRef offsetC (+ strideColumns)

150+ else writeSTRef offsetC 0 >> modifySTRef offsetR (+ strideRows)

151+

152+ return dataIm

153+

154+col2vidUnsafe :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> [Matrix Double]

155+col2vidUnsafe kernelRows kernelColumns strideRows strideColumns destinationRows destinationCols columnMatrix = runST $ do

156+ let columnMatrixRows = rows columnMatrix

157+ let filters = cols columnMatrix `div` (kernelRows * kernelColumns)

158+

159+ dataIms <- traverse (\_ -> U.newMatrix 0 destinationRows destinationCols) [0 .. filters-1]

160+

161+ offsetR <- newSTRef 0

162+ offsetC <- newSTRef 0

163+ offsetM <- newSTRef 0

164+

165+ forM_ dataIms $ \dataIm -> do

166+ offsetM' <- readSTRef offsetM

167+ forM_ [0 .. columnMatrixRows - 1] $ \ir -> do

168+ inputColumn <- newSTRef 0

169+ forM_ [0 .. kernelRows -1] $ \kr ->

170+ forM_ [0 .. kernelColumns -1] $ \kc -> do

171+ ic <- readSTRef inputColumn

172+ offsetR' <- readSTRef offsetR

173+ offsetC' <- readSTRef offsetC

174+ U.modifyMatrix dataIm (kr + offsetR') (kc + offsetC') (+ atIndex columnMatrix (ir, ic + offsetM'))

175+ modifySTRef inputColumn (+1)

176+

177+ offsetC' <- readSTRef offsetC

178+ if offsetC' + kernelColumns < destinationCols

179+ then modifySTRef offsetC (+ strideColumns)

180+ else writeSTRef offsetC 0 >> modifySTRef offsetR (+ strideRows)

181+

182+ writeSTRef offsetR 0

183+ writeSTRef offsetC 0

184+ modifySTRef offsetM (+ (kernelRows * kernelColumns))

185+

186+ traverse U.freezeMatrix dataIms

187+

188+vid2colUnsafe :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> [Matrix Double] -> Matrix Double

189+vid2colUnsafe channels kernelRows kernelColumns striderows stridecols vidrows vidcols dataVid = U.runSTMatrix $ do

190+ let starts = fittingStarts vidrows kernelRows striderows vidcols kernelColumns stridecols

191+ matWidth = kernelRows * kernelColumns

192+ destinationRows = 1 + (vidrows - kernelRows) `div` striderows

193+ destinationCols = 1 + (vidcols - kernelColumns) `div` stridecols

194+ destinationSize = destinationRows * destinationCols

195+

196+ dataCol <- U.newMatrix 0 destinationSize (channels * matWidth)

197+

198+ offsetC <- newSTRef 0

199+

200+ forM_ dataVid $ \dataIm -> do

201+ inputRow <- newSTRef 0

202+ offsetC' <- readSTRef offsetC

203+ forM_ starts $ \(startRow, startCol) -> do

204+ inputColumn <- newSTRef 0

205+ inputRow' <- readSTRef inputRow

206+ forM_ [0 .. kernelRows -1] $ \kr ->

207+ forM_ [0 .. kernelColumns -1] $ \kc -> do

208+ inputColumn' <- readSTRef inputColumn

209+ U.modifyMatrix dataCol inputRow' (inputColumn' + offsetC') (+ atIndex dataIm (kr + startRow, kc + startCol))

210+ modifySTRef inputColumn (+1)

211+ modifySTRef inputRow (+1)

212+

213+ modifySTRef offsetC (+ matWidth)

214+

215+ return dataCol

216+

217+im2colUnsafe :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

218+im2colUnsafe kernelRows kernelColumns striderows stridecols vidrows vidcols dataIm = U.runSTMatrix $ do

219+ let starts = fittingStarts vidrows kernelRows striderows vidcols kernelColumns stridecols

220+ matWidth = kernelRows * kernelColumns

221+ destinationRows = 1 + (vidrows - kernelRows) `div` striderows

222+ destinationCols = 1 + (vidcols - kernelColumns) `div` stridecols

223+ destinationSize = destinationRows * destinationCols

224+

225+ dataCol <- U.newMatrix 0 destinationSize matWidth

226+

227+ inputRow <- newSTRef 0

228+ forM_ starts $ \(startRow, startCol) -> do

229+ inputColumn <- newSTRef 0

230+ inputRow' <- readSTRef inputRow

231+ forM_ [0 .. kernelRows -1] $ \kr ->

232+ forM_ [0 .. kernelColumns -1] $ \kc -> do

233+ inputColumn' <- readSTRef inputColumn

234+ U.modifyMatrix dataCol inputRow' inputColumn' (+ atIndex dataIm (kr + startRow, kc + startCol))

235+ modifySTRef inputColumn (+1)

236+ modifySTRef inputRow (+1)

237+

238+ return dataCol

src/Grenade/Layers/Crop.hs+1−1

@@ -58,7 +58,7 @@ instance ( KnownNat cropLeft

58 m = extract input

59 r = subMatrix (cropt, cropl) (nrows, ncols) m

60 in S2D' . fromJust . create $ r

61− runBackards _ _ (S2D' dEdy) =

61+ runBackwards _ _ (S2D' dEdy) =

62 let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)

63 cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)

64 cropr = fromIntegral $ natVal (Proxy :: Proxy cropRight)

src/Grenade/Layers/Dropout.hs+2−2

@@ -47,5 +47,5 @@ randomDropout rate = do

47instance (KnownNat i) => Layer (Dropout i) ('D1 i) ('D1 i) where

48 runForwards (Dropout drops) (S1D' x) = S1D' $ x * drops

49 runForwards (Pass rate) (S1D' x)= S1D' $ dvmap (* (1 - rate)) x

50− runBackards (Dropout drops) _ (S1D' x) = ((), S1D' $ x * drops)

50+ runBackwards (Dropout drops) _ (S1D' x) = ((), S1D' $ x * drops)

51− runBackards (Pass rate) _ (S1D' x) = ((), S1D' $ dvmap (* (1 - rate)) x)

51+ runBackwards (Pass rate) _ (S1D' x) = ((), S1D' $ dvmap (* (1 - rate)) x)

src/Grenade/Layers/Flatten.hs+2−2

@@ -33,11 +33,11 @@ instance UpdateLayer FlattenLayer where

34instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer FlattenLayer ('D2 x y) ('D1 a) where

35 runForwards _ (S2D' y) = S1D' . fromList . toList . flatten . extract $ y

36− runBackards _ _ (S1D' y) = ((), S2D' . fromList . toList . unwrap $ y)

36+ runBackwards _ _ (S1D' y) = ((), S2D' . fromList . toList . unwrap $ y)

38instance (KnownNat a, KnownNat x, KnownNat y, KnownNat z, a ~ (x * y * z)) => Layer FlattenLayer ('D3 x y z) ('D1 a) where

39 runForwards _ (S3D' y) = S1D' . raiseShapeError . create . vjoin . vecToList . fmap (flatten . extract) $ y

40− runBackards _ _ (S1D' o) =

40+ runBackwards _ _ (S1D' o) =

41 let x' = fromIntegral $ natVal (Proxy :: Proxy x)

42 y' = fromIntegral $ natVal (Proxy :: Proxy y)

43 z' = fromIntegral $ natVal (Proxy :: Proxy z)

src/Grenade/Layers/FullyConnected.hs+1−1

@@ -52,7 +52,7 @@ instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o)

52 runForwards (FullyConnected wB _ wN _) (S1D' v) = S1D' (wB + wN #> v)

54 -- Run a backpropogation step for a full connected layer.

55− runBackards (FullyConnected _ _ wN _) (S1D' x) (S1D' dEdy) =

55+ runBackwards (FullyConnected _ _ wN _) (S1D' x) (S1D' dEdy) =

56 let wB' = dEdy

57 mm' = dEdy `outer` x

58 -- calcluate derivatives for next step

src/Grenade/Layers/Fuse.hs+3−3

@@ -45,8 +45,8 @@ instance (Layer x i h, Layer y h o) => Layer (Fuse x y i h o) i o where

45 let yInput :: S' h = runForwards x input

46 in runForwards y yInput

48− runBackards (x :$$ y) input backGradient =

48+ runBackwards (x :$$ y) input backGradient =

49 let yInput :: S' h = runForwards x input

50− (y', yGrad) = runBackards y yInput backGradient

50+ (y', yGrad) = runBackwards y yInput backGradient

51− (x', xGrad) = runBackards x input yGrad

51+ (x', xGrad) = runBackwards x input yGrad

52 in ((x', y'), xGrad)

src/Grenade/Layers/Logit.hs+3−3

@@ -29,15 +29,15 @@ instance UpdateLayer Logit where

30instance (KnownNat i) => Layer Logit ('D1 i) ('D1 i) where

31 runForwards _ (S1D' y) = S1D' (logistic y)

32− runBackards _ (S1D' y) (S1D' dEdy) = ((), S1D' (logistic' y * dEdy))

32+ runBackwards _ (S1D' y) (S1D' dEdy) = ((), S1D' (logistic' y * dEdy))

34instance (KnownNat i, KnownNat j) => Layer Logit ('D2 i j) ('D2 i j) where

35 runForwards _ (S2D' y) = S2D' (logistic y)

36− runBackards _ (S2D' y) (S2D' dEdy) = ((), S2D' (logistic' y * dEdy))

36+ runBackwards _ (S2D' y) (S2D' dEdy) = ((), S2D' (logistic' y * dEdy))

38instance (KnownNat i, KnownNat j, KnownNat k) => Layer Logit ('D3 i j k) ('D3 i j k) where

39 runForwards _ (S3D' y) = S3D' (fmap logistic y)

40− runBackards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> logistic' y' * dEdy') y dEdy))

40+ runBackwards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> logistic' y' * dEdy') y dEdy))

43logistic :: Floating a => a -> a

src/Grenade/Layers/Pad.hs+1−1

@@ -58,7 +58,7 @@ instance ( KnownNat padLeft

58 m = extract input

59 r = diagBlock [konst 0 (padt,padl), m, konst 0 (padb,padr)]

60 in S2D' . fromJust . create $ r

61− runBackards Pad _ (S2D' dEdy) =

61+ runBackwards Pad _ (S2D' dEdy) =

62 let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)

63 padt = fromIntegral $ natVal (Proxy :: Proxy padTop)

64 nrows = fromIntegral $ natVal (Proxy :: Proxy inputRows)

src/Grenade/Layers/Pooling.hs+3−3

@@ -24,7 +24,7 @@ import GHC.TypeLits

24import Grenade.Core.Network

25import Grenade.Core.Shape

26import Grenade.Core.Vector

27−import Grenade.Layers.Convolution

27+import Grenade.Layers.Convolution.Internal

29import Numeric.LinearAlgebra hiding (uniformSample)

30import qualified Numeric.LinearAlgebra as LA

@@ -75,7 +75,7 @@ instance ( KnownNat kernelRows

75 r = poolForward kx ky sx sy ox oy $ ex

76 rs = fromJust . create $ r

77 in S2D' $ rs

78− runBackards Pooling (S2D' input) (S2D' dEdy) =

78+ runBackwards Pooling (S2D' input) (S2D' dEdy) =

79 let kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

80 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)

81 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

@@ -111,7 +111,7 @@ instance ( KnownNat kernelRows

111 r = poolForwardList kx ky sx sy ix iy ox oy ex

112 rs = fmap (fromJust . create) r

113 in S3D' rs

114− runBackards Pooling (S3D' input) (S3D' dEdy) =

114+ runBackwards Pooling (S3D' input) (S3D' dEdy) =

115 let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

116 iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

117 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

src/Grenade/Layers/Relu.hs+3−3

@@ -31,7 +31,7 @@ instance ( KnownNat i) => Layer Relu ('D1 i) ('D1 i) where

31 runForwards _ (S1D' y) = S1D' (relu y)

32 where

33 relu = LAS.dvmap (\a -> if a <= 0 then 0 else a)

34− runBackards _ (S1D' y) (S1D' dEdy) = ((), S1D' (relu' y * dEdy))

34+ runBackwards _ (S1D' y) (S1D' dEdy) = ((), S1D' (relu' y * dEdy))

35 where

36 relu' = LAS.dvmap (\a -> if a <= 0 then 0 else 1)

@@ -39,7 +39,7 @@ instance (KnownNat i, KnownNat j) => Layer Relu ('D2 i j) ('D2 i j) where

39 runForwards _ (S2D' y) = S2D' (relu y)

40 where

41 relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)

42− runBackards _ (S2D' y) (S2D' dEdy) = ((), S2D' (relu' y * dEdy))

42+ runBackwards _ (S2D' y) (S2D' dEdy) = ((), S2D' (relu' y * dEdy))

43 where

44 relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)

@@ -47,6 +47,6 @@ instance (KnownNat i, KnownNat j, KnownNat k) => Layer Relu ('D3 i j k) ('D3 i j

47 runForwards _ (S3D' y) = S3D' (fmap relu y)

48 where

49 relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)

50− runBackards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> relu' y' * dEdy') y dEdy))

50+ runBackwards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> relu' y' * dEdy') y dEdy))

51 where

52 relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)

src/Grenade/Layers/Tanh.hs+3−3

@@ -26,15 +26,15 @@ instance UpdateLayer Tanh where

27instance KnownNat i => Layer Tanh ('D1 i) ('D1 i) where

28 runForwards _ (S1D' y) = S1D' (tanh y)

29− runBackards _ (S1D' y) (S1D' dEdy) = ((), S1D' (tanh' y * dEdy))

29+ runBackwards _ (S1D' y) (S1D' dEdy) = ((), S1D' (tanh' y * dEdy))

31instance (KnownNat i, KnownNat j) => Layer Tanh ('D2 i j) ('D2 i j) where

32 runForwards _ (S2D' y) = S2D' (tanh y)

33− runBackards _ (S2D' y) (S2D' dEdy) = ((), S2D' (tanh' y * dEdy))

33+ runBackwards _ (S2D' y) (S2D' dEdy) = ((), S2D' (tanh' y * dEdy))

35instance (KnownNat i, KnownNat j, KnownNat k) => Layer Tanh ('D3 i j k) ('D3 i j k) where

36 runForwards _ (S3D' y) = S3D' (fmap tanh y)

37− runBackards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> tanh' y' * dEdy') y dEdy))

37+ runBackwards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> tanh' y' * dEdy') y dEdy))

39tanh' :: (Floating a) => a -> a

40tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

test/Test/Grenade/Layers/Convolution.hs+27−2

@@ -8,6 +8,7 @@ import Grenade.Core.Shape

8import Grenade.Core.Vector as Grenade

9import Grenade.Core.Network

10import Grenade.Layers.Convolution

11+import Grenade.Layers.Convolution.Internal

12import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

13import qualified Numeric.LinearAlgebra.Static as HStatic

14import qualified Numeric.LinearAlgebra.Static as HStatic

@@ -63,6 +64,17 @@ prop_im2col_sym_on_same_stride = once $

63 out = col2im 3 2 3 2 3 4 . im2col 3 2 3 2 $ input

64 out = col2im 3 2 3 2 3 4 . im2col 3 2 3 2 $ input

64 in input === out

65 in input === out

67+-- If there's no overlap (stride is the same size as the kernel)

68+-- then col2im . im2col should be symmetric.

69+prop_im2colunsafe_sym_on_same_stride = once $

70+ let input = (3><4)

71+ [ 1.0, 2.0, 3.0, 4.0

72+ , 5.0, 6.0, 7.0, 8.0

73+ , 9.0, 10.0, 11.0, 12.0 ]

74+ out = col2imUnsafe 3 2 3 2 3 4 . im2colUnsafe 3 2 3 2 3 4 $ input

75+ in input === out

76+

77+

66-- If there is an overlap, then the gradient passed back should be

78-- If there is an overlap, then the gradient passed back should be

67-- the sum of the gradients across the filters.

79-- the sum of the gradients across the filters.

68prop_im2col_col2im_additive = once $

80prop_im2col_col2im_additive = once $

@@ -127,7 +139,7 @@ prop_simple_conv_forwards = once $

127 expectBack = (HStatic.matrix

139 expectBack = (HStatic.matrix

128 [ 1.0, 0.0, 0.0

140 [ 1.0, 0.0, 0.0

129 , 0.0, -2.0,-1.0] :: HStatic.L 2 3)

141 , 0.0, -2.0,-1.0] :: HStatic.L 2 3)

130− (nc, inX) = runBackards convLayer input grad

142+ (nc, inX) = runBackwards convLayer input grad

131

143

132 in case (out, inX, nc) of

144 in case (out, inX, nc) of

133 (S3D' out' , S2D' inX', Convolution' backGrad)

145 (S3D' out' , S2D' inX', Convolution' backGrad)

@@ -187,6 +199,19 @@ prop_vid2col_invert = once $

187 out = col2vid 3 2 3 2 3 4 . vid2col 3 2 3 2 3 4 $ input

199 out = col2vid 3 2 3 2 3 4 . vid2col 3 2 3 2 3 4 $ input

188 in input === out

200 in input === out

189

201

202+prop_vid2col_invert_unsafe = once $

203+ let input = [(3><4)

204+ [ 1.0, 2.0, 3.0, 4.0

205+ , 5.0, 6.0, 7.0, 8.0

206+ , 9.0, 10.0, 11.0, 12.0 ]

207+ , (3><4)

208+ [ 21.0, 22.0, 23.0, 24.0

209+ , 25.0, 26.0, 27.0, 28.0

210+ , 29.0, 30.0, 31.0, 32.0 ] ]

211+ out = col2vidUnsafe 3 2 3 2 3 4 . vid2colUnsafe 2 3 2 3 2 3 4 $ input

212+ in input === out

213+

214+

190-- This test show that 2D convs act the same

215-- This test show that 2D convs act the same

191-- 3D convs with one layer

216-- 3D convs with one layer

192prop_single_conv_forwards = once $

217prop_single_conv_forwards = once $

@@ -239,7 +264,7 @@ prop_single_conv_forwards = once $

239 expectBack = (HStatic.matrix

264 expectBack = (HStatic.matrix

240 [ 1.0, 0.0, 0.0

265 [ 1.0, 0.0, 0.0

241 , 0.0, -2.0,-1.0] :: HStatic.L 2 3)

266 , 0.0, -2.0,-1.0] :: HStatic.L 2 3)

242− (nc, inX) = runBackards convLayer input grad

267+ (nc, inX) = runBackwards convLayer input grad

243

268

244 in case (out, inX, nc) of

269 in case (out, inX, nc) of

245 (S3D' out' , S3D' inX', Convolution' backGrad)

270 (S3D' out' , S3D' inX', Convolution' backGrad)