766b6f8 · vty · git.iko.soy

git.iko.soy/vty

micro opt: use pokeArray instead of a foldM

Ignore-this: 7b2e6da4dcfd6df7e3f24dcde7b92274 darcs-hash:20091120052917-f0a0d-fc0a1dd6f996343a5dc5a3d633bd0dede336ccb4.gz

commit766b6f8c7e763a160b1163678e14c591a56b285a authorcoreyoconnor <coreyoconnor@gmail.com> dateThu 19 Nov 2009, 21:29 (17 years ago) parent16d01cb

4 files changed+195−61

compare with master

unifiedsplit

src/Data/Marshalling.hs+6−4 src/Data/Terminfo/Eval.hs+82−16 src/Data/Terminfo/Parse.hs+106−40 vty.cabal+1−1

src/Data/Marshalling.hs+6−4

@@ -1,13 +1,14 @@

1+{-# LANGUAGE BangPatterns #-}

23module Data.Marshalling ( module Data.Marshalling

34 , module Data.Word

45 , module Foreign.Ptr

56 , module Foreign.ForeignPtr

67 , module Foreign.Marshal

8+ , module Foreign.Storable

79 )

810 where

911

10−import Control.Monad ( foldM )

1112import Control.Monad.Trans

1213

1314import Data.Word

@@ -15,6 +16,7 @@ import Data.Word

1516import Foreign.Ptr

1617import Foreign.ForeignPtr

1718import Foreign.Marshal

19+import Foreign.Marshal.Array

1820import Foreign.Storable

1921

2022type OutputBuffer = Ptr Word8

@@ -23,7 +25,7 @@ string_to_bytes :: String -> [Word8]

2325string_to_bytes str = map (toEnum . fromEnum) str

2426

2527serialize_bytes :: MonadIO m => [Word8] -> OutputBuffer -> m OutputBuffer

26−serialize_bytes bytes out_ptr = foldM ( \ptr b -> liftIO (poke ptr b) >> return ( ptr `plusPtr` 1 ) )

27− out_ptr

28− bytes

28+serialize_bytes bytes !out_ptr = do

29+ liftIO $! pokeArray out_ptr bytes

30+ return $! out_ptr `plusPtr` ( length bytes )

2931

src/Data/Terminfo/Eval.hs+82−16

@@ -1,7 +1,11 @@

1+{-# LANGUAGE MagicHash #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE RecordWildCards #-}

25{-# LANGUAGE FlexibleContexts #-}

36{-# LANGUAGE NoMonomorphismRestriction #-}

47{-# LANGUAGE NamedFieldPuns #-}

8+{-# OPTIONS_GHC -funbox-strict-fields -O #-}

59{- Evaluates the paramaterized terminfo string capability with the given parameters.

610 -

711 - todo: This can be greatly simplified.

@@ -21,9 +25,11 @@ import Control.Monad.State.Strict

2125import Control.Monad.Trans

2226

2327import Data.Array.Unboxed

24−import Data.Bits ( (.|.) )

28+import Data.Bits ( (.|.), (.&.), xor )

2529import Data.List

26−import Data.Word

30+

31+import GHC.Prim

32+import GHC.Word

2733

2834type EvalT m a = ReaderT (CapExpression,[CapParam]) (StateT [CapParam] m) a

2935type Eval a = EvalT Identity a

@@ -37,11 +43,11 @@ pop = do

3743read_param :: MonadReader (CapExpression, [CapParam]) m => Word -> m CapParam

3844read_param pn = do

3945 (_,params) <- ask

40− return $ genericIndex params pn

46+ return $! genericIndex params pn

4147

4248push :: MonadState [CapParam] m => CapParam -> m ()

43−push v = do

44− stack <-get

49+push !v = do

50+ stack <- get

4551 put (v : stack)

4652

4753apply_param_ops :: CapExpression -> [CapParam] -> [CapParam]

@@ -53,8 +59,8 @@ apply_param_op params IncFirstTwo = map (+ 1) params

5359-- | range is 0-based offset into cap_bytes and count

5460--

5561-- todo: The returned list is not assured to have a length st. length == count

56−bytes_for_range :: CapExpression -> (Word8, Word8) -> [Word8]

57−bytes_for_range cap (offset, count)

62+bytes_for_range :: CapExpression -> Word8 -> Word8 -> [Word8]

63+bytes_for_range cap !offset !count

5864 = take (fromEnum count)

5965 $ drop (fromEnum offset)

6066 $ elems

@@ -71,13 +77,19 @@ cap_ops_required_bytes ops = do

7177 return $ sum counts

7278

7379cap_op_required_bytes :: CapOp -> Eval Word

74−cap_op_required_bytes (Bytes (_, c)) = return $ toEnum $ fromEnum c

80+cap_op_required_bytes (Bytes _ c) = return $ toEnum $ fromEnum c

7581cap_op_required_bytes DecOut = do

7682 p <- pop

7783 return $ toEnum $ length $ show p

84+cap_op_required_bytes CharOut = do

85+ pop

86+ return 1

7887cap_op_required_bytes (PushParam pn) = do

7988 read_param pn >>= push

8089 return 0

90+cap_op_required_bytes (PushValue v) = do

91+ push v

92+ return 0

8193cap_op_required_bytes (Conditional expr parts) = do

8294 c_expr <- cap_ops_required_bytes expr

8395 c_parts <- foldM cond_parts_required_bytes 0 parts

@@ -98,13 +110,36 @@ cap_op_required_bytes BitwiseOr = do

98110 v_1 <- pop

99111 push $ v_0 .|. v_1

100112 return 0

113+cap_op_required_bytes BitwiseAnd = do

114+ v_0 <- pop

115+ v_1 <- pop

116+ push $ v_0 .&. v_1

117+ return 0

118+cap_op_required_bytes BitwiseXOr = do

119+ v_0 <- pop

120+ v_1 <- pop

121+ push $ v_0 `xor` v_1

122+ return 0

123+cap_op_required_bytes ArithPlus = do

124+ v_0 <- pop

125+ v_1 <- pop

126+ push $ v_0 + v_1

127+ return 0

101128cap_op_required_bytes CompareEq = do

102129 v_0 <- pop

103130 v_1 <- pop

104131 push $ if v_0 == v_1 then 1 else 0

105132 return 0

106−cap_op_required_bytes (LiteralInt i) = do

107− return $ toEnum $ length $ show i

133+cap_op_required_bytes CompareLt = do

134+ v_0 <- pop

135+ v_1 <- pop

136+ push $ if v_0 < v_1 then 1 else 0

137+ return 0

138+cap_op_required_bytes CompareGt = do

139+ v_0 <- pop

140+ v_1 <- pop

141+ push $ if v_0 > v_1 then 1 else 0

142+ return 0

108143

109144serialize_cap_expression :: MonadIO m => CapExpression -> [CapParam] -> OutputBuffer -> m OutputBuffer

110145serialize_cap_expression cap params out_ptr = do

@@ -116,18 +151,28 @@ serialize_cap_ops :: MonadIO m => OutputBuffer -> CapOps -> EvalT m OutputBuffer

116151serialize_cap_ops out_ptr ops = foldM serialize_cap_op out_ptr ops

117152

118153serialize_cap_op :: MonadIO m => OutputBuffer -> CapOp -> EvalT m OutputBuffer

119−serialize_cap_op out_ptr (Bytes (offset, c)) = do

154+serialize_cap_op out_ptr (Bytes offset c) = do

120155 (cap, _) <- ask

121− let out_bytes = bytes_for_range cap (offset, c)

156+ let out_bytes = bytes_for_range cap offset c

122157 serialize_bytes out_bytes out_ptr

123158serialize_cap_op out_ptr DecOut = do

124159 p <- pop

125160 let out_str = show p

126161 out_bytes = string_to_bytes out_str

127162 serialize_bytes out_bytes out_ptr

163+serialize_cap_op out_ptr CharOut = do

164+ W# p <- pop

165+ -- todo? Truncate the character value to a single byte?

166+ let !out_byte = W8# (and# p 0xFF##)

167+ !out_ptr' = out_ptr `plusPtr` 1

168+ liftIO $ poke out_ptr out_byte

169+ return out_ptr'

128170serialize_cap_op out_ptr (PushParam pn) = do

129171 read_param pn >>= push

130172 return out_ptr

173+serialize_cap_op out_ptr (PushValue v) = do

174+ push v

175+ return out_ptr

131176serialize_cap_op out_ptr (Conditional expr parts) = do

132177 out_ptr' <- serialize_cap_ops out_ptr expr

133178 out_ptr'' <- foldM serialize_cond_parts out_ptr' parts

@@ -148,13 +193,34 @@ serialize_cap_op out_ptr BitwiseOr = do

148193 v_1 <- pop

149194 push $ v_0 .|. v_1

150195 return out_ptr

196+serialize_cap_op out_ptr BitwiseAnd = do

197+ v_0 <- pop

198+ v_1 <- pop

199+ push $ v_0 .&. v_1

200+ return out_ptr

201+serialize_cap_op out_ptr BitwiseXOr = do

202+ v_0 <- pop

203+ v_1 <- pop

204+ push $ v_0 `xor` v_1

205+ return out_ptr

206+serialize_cap_op out_ptr ArithPlus = do

207+ v_0 <- pop

208+ v_1 <- pop

209+ push $ v_0 + v_1

210+ return out_ptr

151211serialize_cap_op out_ptr CompareEq = do

152212 v_0 <- pop

153213 v_1 <- pop

154214 push $ if v_0 == v_1 then 1 else 0

155215 return out_ptr

156−serialize_cap_op out_ptr (LiteralInt i) = do

157− let out_str = show i

158− out_bytes = string_to_bytes out_str

159− serialize_bytes out_bytes out_ptr

216+serialize_cap_op out_ptr CompareLt = do

217+ v_0 <- pop

218+ v_1 <- pop

219+ push $ if v_0 < v_1 then 1 else 0

220+ return out_ptr

221+serialize_cap_op out_ptr CompareGt = do

222+ v_0 <- pop

223+ v_1 <- pop

224+ push $ if v_0 > v_1 then 1 else 0

225+ return out_ptr

160226

src/Data/Terminfo/Parse.hs+106−40

@@ -1,13 +1,16 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE BangPatterns #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE NoMonomorphismRestriction #-}

45{-# LANGUAGE NamedFieldPuns #-}

6+{-# OPTIONS_GHC -funbox-strict-fields -O #-}

57module Data.Terminfo.Parse ( module Data.Terminfo.Parse

68 , Text.ParserCombinators.Parsec.ParseError

79 )

810 where

911

1012import Control.Monad ( liftM )

13+import Control.Parallel.Strategies

1114

1215import Data.Array.Unboxed

1316import Data.Monoid

@@ -20,33 +23,44 @@ type BytesOffset = Word8

2023type CapBytes = UArray Word8 Word8

2124

2225data CapExpression = CapExpression

23− { cap_ops :: CapOps

24− , cap_bytes :: CapBytes

25− , source_string :: String

26− , param_count :: Word

27− , param_ops :: ParamOps

26+ { cap_ops :: !CapOps

27+ , cap_bytes :: !CapBytes

28+ , source_string :: !String

29+ , param_count :: !Word

30+ , param_ops :: !ParamOps

2831 }

2932

33+instance NFData CapExpression where

34+ rnf (CapExpression ops !_bytes !_str !_c !_p_ops)

35+ = rnf ops

36+

3037type CapParam = Word

3138

3239type CapOps = [CapOp]

3340data CapOp =

34− Bytes (BytesOffset, BytesLength)

35− | DecOut

41+ Bytes !BytesOffset !BytesLength

42+ | DecOut | CharOut

3643 -- This stores a 0-based index to the parameter. However the operation that implies this op is

3744 -- 1-based

38− | PushParam !Word

45+ | PushParam !Word | PushValue !Word

3946 -- The conditional parts are the sequence of (%t expression, %e expression) pairs.

4047 -- The %e expression may be NOP

4148 | Conditional

42− { conditional_expr :: CapOps

43− , conditional_parts :: [(CapOps, CapOps)]

49+ { conditional_expr :: !CapOps

50+ , conditional_parts :: ![(CapOps, CapOps)]

4451 }

45− | BitwiseOr

46− | CompareEq

47− | LiteralInt Int

52+ | BitwiseOr | BitwiseXOr | BitwiseAnd

53+ | ArithPlus

54+ | CompareEq | CompareLt | CompareGt

4855 deriving ( Show )

4956

57+instance NFData CapOp where

58+ rnf (Bytes offset c) = rnf offset >| rnf c

59+ rnf (PushParam !_pn) = ()

60+ rnf (PushValue !_v) = ()

61+ rnf (Conditional c_expr c_parts) = rnf c_expr >| rnf c_parts

62+ rnf _ = ()

63+

5064type ParamOps = [ParamOp]

5165data ParamOp =

5266 IncFirstTwo

@@ -61,16 +75,18 @@ parse_cap_expression cap_string =

6175 in case v of

6276 Left e -> Left e

6377 Right build_results ->

64− Right $ CapExpression

65− { cap_ops = out_cap_ops build_results

66− -- The cap bytes are the lower 8 bits of the input string's characters.

67− -- \todo Verify the input string actually contains an 8bit byte per character.

68− , cap_bytes = listArray (0, toEnum $ length cap_string - 1)

69− $ map (toEnum . fromEnum) cap_string

70− , source_string = cap_string

71− , param_count = out_param_count build_results

72− , param_ops = out_param_ops build_results

73− }

78+ Right $! ( CapExpression

79+ { cap_ops = out_cap_ops build_results

80+ -- The cap bytes are the lower 8 bits of the input string's characters.

81+ -- \todo Verify the input string actually contains an 8bit byte per character.

82+ , cap_bytes = listArray (0, toEnum $ length cap_string - 1)

83+ $ map (toEnum . fromEnum) cap_string

84+ , source_string = cap_string

85+ , param_count = out_param_count build_results

86+ , param_ops = out_param_ops build_results

87+ }

88+ `using` rnf

89+ )

7490

7591type CapParser a = GenParser Char BuildState a

7692

@@ -90,17 +106,20 @@ literal_percent_parser = do

90106 char '%'

91107 start_offset <- getState >>= return . next_offset

92108 inc_offset 1

93− return $ BuildResults 0 [Bytes (start_offset, 1)] []

109+ return $ BuildResults 0 [Bytes start_offset 1] []

94110

95111param_op_parser :: CapParser BuildResults

96112param_op_parser

97113 = increment_op_parser

98114 <|> push_op_parser

99115 <|> dec_out_parser

116+ <|> char_out_parser

100117 <|> conditional_op_parser

101118 <|> bitwise_op_parser

119+ <|> arith_op_parser

102120 <|> literal_int_op_parser

103121 <|> compare_op_parser

122+ <|> char_const_parser

104123

105124increment_op_parser :: CapParser BuildResults

106125increment_op_parser = do

@@ -121,6 +140,12 @@ dec_out_parser = do

121140 inc_offset 1

122141 return $ BuildResults 0 [ DecOut ] []

123142

143+char_out_parser :: CapParser BuildResults

144+char_out_parser = do

145+ char 'c'

146+ inc_offset 1

147+ return $ BuildResults 0 [ CharOut ] []

148+

124149conditional_op_parser :: CapParser BuildResults

125150conditional_op_parser = do

126151 char '?'

@@ -156,11 +181,11 @@ conditional_op_parser = do

156181 return $ BuildResults n'' [ Conditional cond cond_parts ] p_ops

157182

158183 where

159− many_p p end = choice

184+ many_p !p !end = choice

160185 [ try end >> return []

161− , do v <- p

162− vs <- many_p p end

163− return $ v : vs

186+ , do !v <- p

187+ !vs <- many_p p end

188+ return $! v : vs

164189 ]

165190 many_expr end = liftM mconcat $ many_p ( param_escape_parser <|> bytes_op_parser ) end

166191

@@ -180,8 +205,10 @@ conditional_end_parser = do

180205 inc_offset 2

181206

182207bitwise_op_parser :: CapParser BuildResults

183−bitwise_op_parser = do

184− bitwise_or_parser

208+bitwise_op_parser

209+ = bitwise_or_parser

210+ <|> bitwise_and_parser

211+ <|> bitwise_xor_parser

185212

186213bitwise_or_parser :: CapParser BuildResults

187214bitwise_or_parser = do

@@ -189,22 +216,53 @@ bitwise_or_parser = do

189216 inc_offset 1

190217 return $ BuildResults 0 [ BitwiseOr ] [ ]

191218

219+bitwise_and_parser :: CapParser BuildResults

220+bitwise_and_parser = do

221+ char '&'

222+ inc_offset 1

223+ return $ BuildResults 0 [ BitwiseAnd ] [ ]

224+

225+bitwise_xor_parser :: CapParser BuildResults

226+bitwise_xor_parser = do

227+ char '^'

228+ inc_offset 1

229+ return $ BuildResults 0 [ BitwiseXOr ] [ ]

230+

231+arith_op_parser :: CapParser BuildResults

232+arith_op_parser = do

233+ char '+'

234+ inc_offset 1

235+ return $ BuildResults 0 [ ArithPlus ] [ ]

236+

192237literal_int_op_parser :: CapParser BuildResults

193238literal_int_op_parser = do

194239 char '{'

195240 inc_offset 1

196241 n_str <- many1 digit

197242 inc_offset $ toEnum $ length n_str

198− let n = read n_str

243+ let n :: Word = read n_str

199244 char '}'

200245 inc_offset 1

201− return $ BuildResults 0 [ LiteralInt n ] [ ]

246+ return $ BuildResults 0 [ PushValue n ] [ ]

202247

203248compare_op_parser :: CapParser BuildResults

204−compare_op_parser = do

205− char '='

206− inc_offset 1

207− return $ BuildResults 0 [ CompareEq ] [ ]

249+compare_op_parser

250+ = compare_eq_op

251+ <|> compare_lt_op

252+ <|> compare_gt_op

253+ where

254+ compare_eq_op = do

255+ char '='

256+ inc_offset 1

257+ return $ BuildResults 0 [ CompareEq ] [ ]

258+ compare_lt_op = do

259+ char '<'

260+ inc_offset 1

261+ return $ BuildResults 0 [ CompareLt ] [ ]

262+ compare_gt_op = do

263+ char '>'

264+ inc_offset 1

265+ return $ BuildResults 0 [ CompareGt ] [ ]

208266

209267bytes_op_parser :: CapParser BuildResults

210268bytes_op_parser = do

@@ -214,7 +272,15 @@ bytes_op_parser = do

214272 !s <- getState

215273 let s' = s { next_offset = start_offset + c }

216274 setState s'

217− return $ BuildResults 0 [Bytes (start_offset, c)] []

275+ return $ BuildResults 0 [Bytes start_offset c] []

276+

277+char_const_parser :: CapParser BuildResults

278+char_const_parser = do

279+ char '\''

280+ char_value <- liftM (toEnum . fromEnum) anyChar

281+ char '\''

282+ inc_offset 3

283+ return $ BuildResults 0 [ PushValue char_value ] [ ]

218284

219285data BuildState = BuildState

220286 { next_offset :: Word8

@@ -230,9 +296,9 @@ initial_build_state :: BuildState

230296initial_build_state = BuildState 0

231297

232298data BuildResults = BuildResults

233− { out_param_count :: Word

234− , out_cap_ops :: CapOps

235− , out_param_ops :: ParamOps

299+ { out_param_count :: !Word

300+ , out_cap_ops :: !CapOps

301+ , out_param_ops :: !ParamOps

236302 }

237303

238304instance Monoid BuildResults where

vty.cabal+1−1

@@ -27,7 +27,7 @@ Build-Depends: base >= 4 && < 5, bytestring, containers, unix, uvector

2727Build-Depends: terminfo >= 0.2 && < 0.3

2828Build-Depends: utf8-string >= 0.3 && < 0.4

2929Build-Depends: mtl >= 1.1.0.0 && < 1.2

30−Build-Depends: ghc-prim

30+Build-Depends: ghc-prim, parallel

3131Build-Depends: array

3232Build-Depends: parsec >= 2 && < 4

3333Build-Depends: vector-space >= 0.5 && < 0.6