3a4f72a · streamly · git.iko.soy

3049unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a

3050unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x

3051

3052+-- decode is split into two separate cases to avoid branching instructions.

3053+-- From the higher level flow we already know which case we are in so we can

3054+-- call the appropriate decode function.

3055+--

3056+-- When the state is 0

3057+{-# INLINE decode0 #-}

3058+decode0 :: Ptr Word8 -> Word8 -> Tuple' DecoderState CodePoint

3059+decode0 table byte =

3060+ let !t = table `unsafePeekElemOff` fromIntegral byte

3061+ !codep' = (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte

3062+ !state' = table `unsafePeekElemOff` (256 + fromIntegral t)

3063+ in (Tuple' state' codep')

3064+

3065+-- When the state is not 0

3052−{-# INLINE decode #-}

3066+{-# INLINE decode1 #-}

3053−decode

3067+decode1

3054 :: Ptr Word8

3068 :: Ptr Word8

3055 -> DecoderState

3069 -> DecoderState

3056 -> CodePoint

3070 -> CodePoint

3057 -> Word8

3071 -> Word8

3058 -> Tuple' DecoderState CodePoint

3072 -> Tuple' DecoderState CodePoint

3059−decode table state codep byte =

3073+decode1 table state codep byte =

3060 -- Remember codep is Int type!

3074 -- Remember codep is Int type!

3061 -- Can it be unsafe to convert the resulting to Char?

3075 -- Can it be unsafe to convert the resulting to Char?

3062 let !t = table `unsafePeekElemOff` fromIntegral byte

3076 let !t = table `unsafePeekElemOff` fromIntegral byte

3063− !codep' =

3064− if state /= 0

3065− then (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)

3077+ !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)

3066− else (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte

3067 !state' = table `unsafePeekElemOff`

3078 !state' = table `unsafePeekElemOff`

3068 (256 + fromIntegral state + fromIntegral t)

3079 (256 + fromIntegral state + fromIntegral t)

3069 in (Tuple' state' codep')

3080 in (Tuple' state' codep')

3070

3081

3082+

3071data FreshPoint s

3083data FreshPoint s

3072− = FreshPoint !CodePoint !DecoderState s

3084+ = FreshPointDecodeInit s

3085+ | FreshPointDecodeFirst s Word8

3086+ | FreshPointDecoding s !DecoderState !CodePoint

3073 | YieldAndContinue !Char (FreshPoint s)

3087 | YieldAndContinue !Char (FreshPoint s)

3074 | Done

3088 | Done

3075

3089

3079decodeUtf8With cfm (Stream step state) =

3093decodeUtf8With cfm (Stream step state) =

3080 let Array p _ _ = utf8d

3094 let Array p _ _ = utf8d

3081 !ptr = (unsafeForeignPtrToPtr p)

3095 !ptr = (unsafeForeignPtrToPtr p)

3082− in Stream (step' ptr) (FreshPoint 0 0 state)

3096+ in Stream (step' ptr) (FreshPointDecodeInit state)

3083 where

3097 where

3084 {-# INLINE transliterateOrError #-}

3098 {-# INLINE transliterateOrError #-}

3085 transliterateOrError e s =

3099 transliterateOrError e s =

3093 error "Streamly.Streams.StreamD.decodeUtf8With: Input Underflow"

3107 error "Streamly.Streams.StreamD.decodeUtf8With: Input Underflow"

3094 TransliterateCodingFailure -> YieldAndContinue replacementChar Done

3108 TransliterateCodingFailure -> YieldAndContinue replacementChar Done

3095 {-# INLINE_LATE step' #-}

3109 {-# INLINE_LATE step' #-}

3096− step' table gst (FreshPoint codepointPtr statePtr st) = do

3110+ step' _ gst (FreshPointDecodeInit st) = do

3097 r <- step (adaptState gst) st

3111 r <- step (adaptState gst) st

3098− return $

3099− case r of

3112+ case r of

3100− Yield x s ->

3113+ Yield x s ->

3101− if statePtr == 0 && x <= 0x7f

3114+ -- Note: It is important to use a ">" instead of a "<=" test

3102− then

3115+ -- here for GHC to generate code layout for default branch

3103− Skip $

3116+ -- prediction for the common case. This is fragile and might

3117+ -- change with the compiler versions, we need a more reliable

3118+ -- "likely" primitive to control branch predication.

3119+ case x > 0x7f of

3120+ False ->

3104− YieldAndContinue

3121+ return $ Skip $ YieldAndContinue

3105 (unsafeChr (fromIntegral x))

3122 (unsafeChr (fromIntegral x))

3106− (FreshPoint 0 0 s)

3123+ (FreshPointDecodeInit s)

3107− else

3124+ -- Using a separate state here generates a jump to a

3108− let (Tuple' sv cp) =

3125+ -- separate code block in the core which seems to perform

3109− decode table statePtr codepointPtr x

3126+ -- slightly better for the non-ascii case.

3110− in case sv of

3127+ True -> return $ Skip $ FreshPointDecodeFirst s x

3128+ Skip s -> return $ Skip (FreshPointDecodeInit s)

3129+ Stop -> return $ Skip Done

3130+

3131+ step' table _ (FreshPointDecodeFirst st x) = do

3132+ let (Tuple' sv cp) = decode0 table x

3133+ return $

3134+ case sv of

3111− 12 ->

3135+ 12 ->

3112− Skip $

3136+ Skip $

3113− transliterateOrError

3137+ transliterateOrError

3114− "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"

3138+ "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"

3115− (FreshPoint 0 0 s)

3139+ (FreshPointDecodeInit st)

3116− 0 ->

3140+ 0 -> error "unreachable state"

3117− Skip $

3141+ _ -> Skip (FreshPointDecoding st sv cp)

3142+

3143+ step' table gst (FreshPointDecoding st statePtr codepointPtr) = do

3144+ r <- step (adaptState gst) st

3145+ case r of

3146+ Yield x s -> do

3147+ let (Tuple' sv cp) = decode1 table statePtr codepointPtr x

3148+ return $

3149+ case sv of

3118− YieldAndContinue

3150+ 0 -> Skip $ YieldAndContinue (unsafeChr cp)

3119− (unsafeChr cp)

3151+ (FreshPointDecodeInit s)

3120− (FreshPoint cp sv s)

3152+ 12 ->

3121− _ -> Skip (FreshPoint cp sv s)

3153+ Skip $

3122− Skip s -> Skip (FreshPoint codepointPtr statePtr s)

3154+ transliterateOrError

3123− Stop ->

3155+ "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"

3124− if statePtr /= 0

3156+ (FreshPointDecodeInit s)

3157+ _ -> Skip (FreshPointDecoding s sv cp)

3158+ Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)

3125− then Skip inputUnderflow

3159+ Stop -> return $ Skip inputUnderflow

3126− else Skip Done

3160+

3127 step' _ _ (YieldAndContinue c s) = return $ Yield c s

3161 step' _ _ (YieldAndContinue c s) = return $ Yield c s

3128 step' _ _ Done = return Stop

3162 step' _ _ Done = return Stop

3129

3163

3136decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure

3170decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure

3137

3171

3138data FlattenState s a

3172data FlattenState s a

3139− = OuterLoop s !CodePoint !DecoderState

3173+ = OuterLoop s !(Maybe (DecoderState, CodePoint))

3140− | InnerLoop s (ForeignPtr a) !CodePoint !DecoderState !(Ptr a) !(Ptr a)

3174+ | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)

3175+ | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8

3176+ | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)

3177+ !DecoderState !CodePoint

3141 | YAndC !Char (FlattenState s a) -- These constructors can be

3178 | YAndC !Char (FlattenState s a) -- These constructors can be

3142 -- encoded in the FreshPoint

3179 -- encoded in the FreshPoint

3143 -- type, I prefer to keep these

3180 -- type, I prefer to keep these

3159decodeUtf8ArraysWith cfm (Stream step state) =

3196decodeUtf8ArraysWith cfm (Stream step state) =

3160 let Array p _ _ = utf8d

3197 let Array p _ _ = utf8d

3161 !ptr = (unsafeForeignPtrToPtr p)

3198 !ptr = (unsafeForeignPtrToPtr p)

3162− in Stream (step' ptr) (OuterLoop state 0 0)

3199+ in Stream (step' ptr) (OuterLoop state Nothing)

3163 where

3200 where

3164 {-# INLINE transliterateOrError #-}

3201 {-# INLINE transliterateOrError #-}

3165 transliterateOrError e s =

3202 transliterateOrError e s =

3174 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Input Underflow"

3211 "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Input Underflow"

3175 TransliterateCodingFailure -> YAndC replacementChar D

3212 TransliterateCodingFailure -> YAndC replacementChar D

3176 {-# INLINE_LATE step' #-}

3213 {-# INLINE_LATE step' #-}

3177− step' _ gst (OuterLoop st cp ds) = do

3214+ step' _ gst (OuterLoop st Nothing) = do

3178 r <- step (adaptState gst) st

3215 r <- step (adaptState gst) st

3179 return $

3216 return $

3180 case r of

3217 case r of

3181 Yield A.Array {..} s ->

3218 Yield A.Array {..} s ->

3182 let p = unsafeForeignPtrToPtr aStart

3219 let p = unsafeForeignPtrToPtr aStart

3183− in Skip (InnerLoop s aStart cp ds p aEnd)

3220+ in Skip (InnerLoopDecodeInit s aStart p aEnd)

3184− Skip s -> Skip (OuterLoop s cp ds)

3221+ Skip s -> Skip (OuterLoop s Nothing)

3185− Stop ->

3222+ Stop -> Skip D

3186− if ds /= 0

3223+ step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do

3187− then Skip inputUnderflow

3224+ r <- step (adaptState gst) st

3188− else Skip D

3225+ return $

3226+ case r of

3227+ Yield A.Array {..} s ->

3228+ let p = unsafeForeignPtrToPtr aStart

3229+ in Skip (InnerLoopDecoding s aStart p aEnd ds cp)

3230+ Skip s -> Skip (OuterLoop s dst)

3231+ Stop -> Skip inputUnderflow

3232+ step' _ _ (InnerLoopDecodeInit st startf p end)

3233+ | p == end = do

3234+ liftIO $ touchForeignPtr startf

3235+ return $ Skip $ OuterLoop st Nothing

3236+ step' _ _ (InnerLoopDecodeInit st startf p end) = do

3237+ x <- liftIO $ peek p

3238+ -- Note: It is important to use a ">" instead of a "<=" test here for

3239+ -- GHC to generate code layout for default branch prediction for the

3240+ -- common case. This is fragile and might change with the compiler

3241+ -- versions, we need a more reliable "likely" primitive to control

3242+ -- branch predication.

3243+ case x > 0x7f of

3244+ False ->

3245+ return $ Skip $ YAndC

3246+ (unsafeChr (fromIntegral x))

3247+ (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

3248+ -- Using a separate state here generates a jump to a separate code

3249+ -- block in the core which seems to perform slightly better for the

3250+ -- non-ascii case.

3251+ True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x

3252+

3253+ step' table _ (InnerLoopDecodeFirst st startf p end x) = do

3254+ let (Tuple' sv cp) = decode0 table x

3255+ return $

3256+ case sv of

3257+ 12 ->

3258+ Skip $

3259+ transliterateOrError

3260+ "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"

3261+ (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

3262+ 0 -> error "unreachable state"

3263+ _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)

3189− step' _ _ (InnerLoop st startf cp ds p end)

3264+ step' _ _ (InnerLoopDecoding st startf p end sv cp)

3190 | p == end = do

3265 | p == end = do

3191 liftIO $ touchForeignPtr startf

3266 liftIO $ touchForeignPtr startf

3192− return $ Skip $ OuterLoop st cp ds

3267+ return $ Skip $ OuterLoop st (Just (sv, cp))

3193− step' table _ (InnerLoop st startf codepointPtr statePtr p end) = do

3268+ step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do

3194 x <- liftIO $ peek p

3269 x <- liftIO $ peek p

3195− if statePtr == 0 && x <= 0x7f

3196− then

3197− return $ Skip $ YAndC

3198− (unsafeChr (fromIntegral x))

3199− (InnerLoop st startf 0 0 (p `plusPtr` 1) end)

3200− else do

3201− let (Tuple' sv cp) = decode table statePtr codepointPtr x

3270+ let (Tuple' sv cp) = decode1 table statePtr codepointPtr x

3202− return $

3271+ return $

3203− case sv of

3272+ case sv of

3273+ 0 ->

3274+ Skip $

3275+ YAndC

3276+ (unsafeChr cp)

3277+ (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

3204− 12 ->

3278+ 12 ->

3205− Skip $

3279+ Skip $

3206− transliterateOrError

3280+ transliterateOrError

3207− "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"

3281+ "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"

3208− (InnerLoop st startf 0 0 (p `plusPtr` 1) end)

3209− 0 ->

3210− Skip $

3211− YAndC

3212− (unsafeChr cp)

3213− (InnerLoop st startf 0 0 (p `plusPtr` 1) end)

3282+ (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

3214− _ -> Skip (InnerLoop st startf cp sv (p `plusPtr` 1) end)

3283+ _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)

3215 step' _ _ (YAndC c s) = return $ Yield c s

3284 step' _ _ (YAndC c s) = return $ Yield c s

3216 step' _ _ D = return Stop

3285 step' _ _ D = return Stop

3217

3286