Skip to content

Increased heap performance for Encoding. #3

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
Cipherwraith wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Increased heap performance for Encoding. #3

Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
a144bb0
Improved heap performance
Cipherwraith Dec 11, 2017
71ff374
improved heap performance
Cipherwraith Dec 11, 2017
8f4402a
Update Encode.hs
Cipherwraith Dec 11, 2017
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
146 changes: 90 additions & 56 deletions Data/Text/Punycode/Encode.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -12,75 +12,109 @@ import Data.Word

import Data.Text.Punycode.Shared

data PunycodeState = PunycodeState { n :: Int
, delta :: Int
, bias :: Int
, h :: Int
}
data PunycodeState = PunycodeState
{ n :: {-# UNPACK #-} !Int
, delta :: {-# UNPACK #-} !Int
, bias :: {-# UNPACK #-} !Int
, h :: {-# UNPACK #-} !Int
}

-- | Encode a string into its ascii form
{-# INLINE encode #-}
encode :: T.Text -> BS.ByteString
encode = execWriter . initialWriter

{-# INLINE initialWriter #-}
initialWriter :: MonadWriter BS.ByteString m => T.Text -> m ()
initialWriter input = do
tell basics
when (b > 0) $ tell $ BS.singleton $ fromIntegral $ ord '-'
evalStateT (inner3 (map ord $ T.unpack input) b) $ PunycodeState { n = initial_n
, delta = 0
, bias = initial_bias
, h = b
}
where basics = TE.encodeUtf8 $ T.filter isBasic input
b = BS.length basics
initialWriter !input = do
!_ <- tell basics
!_ <- when (b > 0) . tell . BS.singleton . fromIntegral $! ord '-'
!_ <- void . evalStateT (inner3 (map ord . T.unpack $! input) b) $!
PunycodeState { n = initial_n
, delta = 0
, bias = initial_bias
, h = b
}
return ()
where
basics :: BS.ByteString
basics = TE.encodeUtf8 . T.filter isBasic $! input
b :: Int
b = BS.length basics

{-# INLINE inner3 #-}
inner3 :: (MonadState PunycodeState m, MonadWriter BS.ByteString m) => [Int] -> Int -> m ()
inner3 input b = do
state <- get
helper state
where helper state
| h' < length input = do
put $ state {n = m, delta = delta'}
mapM_ (inner2 b) input
state' <- get
put $ state' {delta = (delta state') + 1, n = (n state') + 1}
inner3 input b
| otherwise = return ()
where m = minimum $ filter (>= n') input
n' = n state
h' = h state
delta' = (delta state) + (m - n') * (h' + 1)
inner3 !input !b = do
!state <- get
void $! helper state
where
helper !state
| h' < length input = do
!_ <- put $! state {n = m, delta = delta'}
!_ <- void . flip mapM_ input $! inner2 b
!state' <- get
!_ <- void . put $! state' {delta = (delta state') + 1, n = (n state') + 1}
!_ <- void $! inner3 input b
return ()
| otherwise = return ()
where
m :: Int
m = minimum . filter (>= n') $! input

n' :: Int
n' = n state

h' :: Int
h' = h state

delta' :: Int
delta' = (delta state) + (m - n') * (h' + 1)

{-# INLINE inner2 #-}
inner2 :: (MonadState PunycodeState m, MonadWriter BS.ByteString m) => Int -> Int -> m ()
inner2 b c = do
state <- get
helper state
where helper state
| c == n' = do
q <- inner delta' base bias'
tell $ BS.singleton $ baseToAscii q
put $ state {bias = adapt delta' (h' + 1) (h' == b), delta = 0, h = (h state) + 1}
| otherwise = put $ state {delta = delta'}
where delta' = (delta state) + d
where d
| c < n' = 1
| otherwise = 0
n' = n state
bias' = bias state
h' = h state
inner2 !b !c = do
!state <- get
void $! helper state
where
helper !state
| c == n' =
do
!q <- inner delta' base bias'
!_ <- void . tell . BS.singleton . baseToAscii $! q
!_ <- void . put $! state {bias = adapt delta' (h' + 1) (h' == b), delta = 0, h = (h state) + 1}
return ()
| otherwise = do
!_ <- void . put $! state {delta = delta'}
return ()
where
delta'
| c < n' = 1 + delta state
| otherwise = delta state

n' :: Int
n' = n state
bias' :: Int
bias' = bias state
h' :: Int
h' = h state

{-# INLINE inner #-}
inner :: (MonadWriter BS.ByteString m) => Int -> Int -> Int -> m Int
inner q k bias'
inner !q !k !bias'
| q < t = return q
| otherwise = do
tell $ BS.singleton $ baseToAscii $ t + ((q - t) `mod` (base - t))
inner ((q - t) `div` (base - t)) (k + base) bias'
where t
| k <= bias' + tmin = tmin
| k >= bias' + tmax = tmax
| otherwise = k - bias'
void . tell . BS.singleton . baseToAscii $! t + ((q - t) `mod` (base - t))
!out <- inner ((q - t) `div` (base - t)) (k + base) bias'
return out
where
t :: Int
t
| k <= bias' + tmin = tmin
| k >= bias' + tmax = tmax
| otherwise = k - bias'

{-# INLINE baseToAscii #-}
baseToAscii :: Int -> Word8
baseToAscii i
| i < 26 = fromIntegral $ i + (ord 'a')
| otherwise = fromIntegral $ (i - 26) + (ord '0')
baseToAscii !i
| i < 26 = fromIntegral $! i + (ord 'a')
| otherwise = fromIntegral $! (i - 26) + (ord '0')