{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE NoStrict #-}
{-# LANGUAGE TupleSections #-}

module Data.IP.Builder
    ( -- * 'P.BoundedPrim' 'B.Builder's for general, IPv4 and IPv6 addresses.
      ipBuilder
    , ipv4Builder
    , ipv6Builder
    ) where

import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Prim as P
import           Data.ByteString.Builder.Prim ((>$<), (>*<))
import           GHC.Exts
import           GHC.Word (Word8(..), Word16(..), Word32(..))

import           Data.IP.Addr

------------ IP builders

{-# INLINE ipBuilder #-}
-- | 'P.BoundedPrim' bytestring 'B.Builder' for general 'IP' addresses.
ipBuilder :: IP -> B.Builder
ipBuilder :: IP -> Builder
ipBuilder (IPv4 IPv4
addr) = IPv4 -> Builder
ipv4Builder IPv4
addr
ipBuilder (IPv6 IPv6
addr) = IPv6 -> Builder
ipv6Builder IPv6
addr

{-# INLINE ipv4Builder #-}
-- | 'P.BoundedPrim' bytestring 'B.Builder' for 'IPv4' addresses.
ipv4Builder :: IPv4 -> B.Builder
ipv4Builder :: IPv4 -> Builder
ipv4Builder IPv4
addr = BoundedPrim Word32 -> Word32 -> Builder
forall a. BoundedPrim a -> a -> Builder
P.primBounded BoundedPrim Word32
ipv4Bounded (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$! IPv4 -> Word32
fromIPv4w IPv4
addr

{-# INLINE ipv6Builder #-}
-- | 'P.BoundedPrim' bytestring 'B.Builder' for 'IPv6' addresses.
ipv6Builder :: IPv6 -> B.Builder
ipv6Builder :: IPv6 -> Builder
ipv6Builder IPv6
addr = BoundedPrim (Word32, Word32, Word32, Word32)
-> (Word32, Word32, Word32, Word32) -> Builder
forall a. BoundedPrim a -> a -> Builder
P.primBounded BoundedPrim (Word32, Word32, Word32, Word32)
ipv6Bounded ((Word32, Word32, Word32, Word32) -> Builder)
-> (Word32, Word32, Word32, Word32) -> Builder
forall a b. (a -> b) -> a -> b
$! IPv6 -> (Word32, Word32, Word32, Word32)
fromIPv6w IPv6
addr

------------ Builder utilities

-- Convert fixed to bounded for fusion
toB :: P.FixedPrim a -> P.BoundedPrim a
toB :: FixedPrim a -> BoundedPrim a
toB = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
P.liftFixedToBounded
{-# INLINE toB #-}

ipv4Bounded :: P.BoundedPrim Word32
ipv4Bounded :: BoundedPrim Word32
ipv4Bounded =
    Word32 -> (((Word8, ()), (Word8, ())), ((Word8, ()), Word8))
quads (Word32 -> (((Word8, ()), (Word8, ())), ((Word8, ()), Word8)))
-> BoundedPrim (((Word8, ()), (Word8, ())), ((Word8, ()), Word8))
-> BoundedPrim Word32
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< ((BoundedPrim Word8
P.word8Dec BoundedPrim Word8 -> BoundedPrim () -> BoundedPrim (Word8, ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall b. BoundedPrim b
dotsep) BoundedPrim (Word8, ())
-> BoundedPrim (Word8, ())
-> BoundedPrim ((Word8, ()), (Word8, ()))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< (BoundedPrim Word8
P.word8Dec BoundedPrim Word8 -> BoundedPrim () -> BoundedPrim (Word8, ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall b. BoundedPrim b
dotsep))
          BoundedPrim ((Word8, ()), (Word8, ()))
-> BoundedPrim ((Word8, ()), Word8)
-> BoundedPrim (((Word8, ()), (Word8, ())), ((Word8, ()), Word8))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< ((BoundedPrim Word8
P.word8Dec BoundedPrim Word8 -> BoundedPrim () -> BoundedPrim (Word8, ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall b. BoundedPrim b
dotsep) BoundedPrim (Word8, ())
-> BoundedPrim Word8 -> BoundedPrim ((Word8, ()), Word8)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word8
P.word8Dec)
  where
    quads :: Word32 -> (((Word8, ()), (Word8, ())), ((Word8, ()), Word8))
quads Word32
a = ((Int# -> Word32 -> (Word8, ())
qdot Int#
0o30# Word32
a, Int# -> Word32 -> (Word8, ())
qdot Int#
0o20# Word32
a), (Int# -> Word32 -> (Word8, ())
qdot Int#
0o10# Word32
a, Word32 -> Word8
qfin Word32
a))
    {-# INLINE quads #-}
    qdot :: Int# -> Word32 -> (Word8, ())
qdot Int#
s (W32# Word#
a) = (Word# -> Word8
W8# ((Word#
a Word# -> Int# -> Word#
`uncheckedShiftRL#` Int#
s) Word# -> Word# -> Word#
`and#` Word#
0xff##), ())
    {-# INLINE qdot #-}
    qfin :: Word32 -> Word8
qfin (W32# Word#
a) = Word# -> Word8
W8# (Word#
a Word# -> Word# -> Word#
`and#` Word#
0xff##)
    {-# INLINE qfin #-}
    dotsep :: BoundedPrim b
dotsep = Word8 -> b -> Word8
forall a b. a -> b -> a
const Word8
0x2e (b -> Word8) -> BoundedPrim Word8 -> BoundedPrim b
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< FixedPrim Word8 -> BoundedPrim Word8
forall a. FixedPrim a -> BoundedPrim a
toB FixedPrim Word8
P.word8

-- | For each 32-bit chunk of an IPv6 address, encode its display format in the
-- presentation form of the address, based on its location relative to the
-- "best gap", i.e. the left-most longest run of zeros. The "hi" (H) and/or
-- "lo" (L) 16 bits may be accompanied by colons (C) on the left and/or right.
--
data FF = CHL Word32  -- ^ :<h>:<l>
        | HL  Word32  -- ^  <h>:<l>
        | NOP         -- ^  nop
        | COL         -- ^ :
        | CC          -- ^ :   :
        | CLO Word32  -- ^     :<l>
        | CHC Word32  -- ^ :<h>:
        | HC  Word32  -- ^  <h>:

-- Build an IPv6 address in conformance with
-- [RFC5952](http://tools.ietf.org/html/rfc5952 RFC 5952).
--
ipv6Bounded :: P.BoundedPrim (Word32, Word32, Word32, Word32)
ipv6Bounded :: BoundedPrim (Word32, Word32, Word32, Word32)
ipv6Bounded =
    ((Word32, Word32, Word32, Word32) -> Bool)
-> BoundedPrim (Word32, Word32, Word32, Word32)
-> BoundedPrim (Word32, Word32, Word32, Word32)
-> BoundedPrim (Word32, Word32, Word32, Word32)
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (Word32, Word32, Word32, Word32) -> Bool
generalCase
      ( (Word32, Word32, Word32, Word32) -> ((FF, FF), (FF, FF))
genFields ((Word32, Word32, Word32, Word32) -> ((FF, FF), (FF, FF)))
-> BoundedPrim ((FF, FF), (FF, FF))
-> BoundedPrim (Word32, Word32, Word32, Word32)
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ((FF, FF), (FF, FF))
output128 )
      ( ((Word32, Word32, Word32, Word32) -> Bool)
-> BoundedPrim (Word32, Word32, Word32, Word32)
-> BoundedPrim (Word32, Word32, Word32, Word32)
-> BoundedPrim (Word32, Word32, Word32, Word32)
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (Word32, Word32, Word32, Word32) -> Bool
v4mapped
          ( (Word32, Word32, Word32, Word32)
-> ((Word32, Word32), (Word32, Word32))
forall a b a b. (a, b, a, b) -> ((a, b), (a, b))
pairPair ((Word32, Word32, Word32, Word32)
 -> ((Word32, Word32), (Word32, Word32)))
-> BoundedPrim ((Word32, Word32), (Word32, Word32))
-> BoundedPrim (Word32, Word32, Word32, Word32)
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Word32
forall b. BoundedPrim b
colsep BoundedPrim Word32
-> BoundedPrim Word32 -> BoundedPrim (Word32, Word32)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word32
forall b. BoundedPrim b
colsep)
                     BoundedPrim (Word32, Word32)
-> BoundedPrim (Word32, Word32)
-> BoundedPrim ((Word32, Word32), (Word32, Word32))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< (BoundedPrim Word32
forall b. BoundedPrim b
ffff BoundedPrim Word32
-> BoundedPrim Word32 -> BoundedPrim (Word32, Word32)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< (Word32 -> ((), Word32)
forall a. a -> ((), a)
fstUnit (Word32 -> ((), Word32))
-> BoundedPrim ((), Word32) -> BoundedPrim Word32
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ()
forall b. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim Word32 -> BoundedPrim ((), Word32)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word32
ipv4Bounded)) )
          ( (Word32, Word32, Word32, Word32)
-> ((Word32, Word32), (Word32, Word32))
forall a b a b. (a, b, a, b) -> ((a, b), (a, b))
pairPair ((Word32, Word32, Word32, Word32)
 -> ((Word32, Word32), (Word32, Word32)))
-> BoundedPrim ((Word32, Word32), (Word32, Word32))
-> BoundedPrim (Word32, Word32, Word32, Word32)
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Word32
forall b. BoundedPrim b
P.emptyB BoundedPrim Word32
-> BoundedPrim Word32 -> BoundedPrim (Word32, Word32)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word32
forall b. BoundedPrim b
colsep) BoundedPrim (Word32, Word32)
-> BoundedPrim (Word32, Word32)
-> BoundedPrim ((Word32, Word32), (Word32, Word32))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< (BoundedPrim Word32
forall b. BoundedPrim b
colsep BoundedPrim Word32
-> BoundedPrim Word32 -> BoundedPrim (Word32, Word32)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word32
ipv4Bounded) ) )
  where
    -- The boundedPrim switches and predicates need to be inlined for best
    -- performance, gaining a factor of ~2 in throughput in tests.
    --
    {-# INLINE output128 #-}
    {-# INLINE output64 #-}
    {-# INLINE generalCase #-}
    {-# INLINE v4mapped #-}
    {-# INLINE output32 #-}

    generalCase :: (Word32, Word32, Word32, Word32) -> Bool
    generalCase :: (Word32, Word32, Word32, Word32) -> Bool
generalCase (Word32
w0, Word32
w1, Word32
w2, Word32
w3) =
        Word32
w0 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 Bool -> Bool -> Bool
|| Word32
w1 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 Bool -> Bool -> Bool
|| (Word32
w2 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0xffff Bool -> Bool -> Bool
&& (Word32
w2 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 Bool -> Bool -> Bool
|| Word32
w3 Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word32
0xffff))
    --
    v4mapped :: (Word32, Word32, Word32, Word32) -> Bool
    v4mapped :: (Word32, Word32, Word32, Word32) -> Bool
v4mapped (Word32
w0, Word32
w1, Word32
w2, Word32
_) =
        Word32
w0 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 Bool -> Bool -> Bool
&& Word32
w1 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 Bool -> Bool -> Bool
&& Word32
w2 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xffff

    -- BoundedPrim for the full 128-bit IPv6 address given as
    -- a pair of pairs of FF values, which encode the
    -- output format of each of the 32-bit chunks.
    --
    output128 :: P.BoundedPrim ((FF, FF), (FF, FF))
    output128 :: BoundedPrim ((FF, FF), (FF, FF))
output128 = BoundedPrim (FF, FF)
output64 BoundedPrim (FF, FF)
-> BoundedPrim (FF, FF) -> BoundedPrim ((FF, FF), (FF, FF))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim (FF, FF)
output64
    output64 :: BoundedPrim (FF, FF)
output64 = (BoundedPrim FF
output32 BoundedPrim FF -> BoundedPrim FF -> BoundedPrim (FF, FF)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim FF
output32)
    --
    -- And finally the per-word case-work.
    --
    output32 :: P.BoundedPrim FF
    output32 :: BoundedPrim FF
output32 =
        (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case { CHL Word32
_ -> Bool
True; FF
_ -> Bool
False }) BoundedPrim FF
build_CHL (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ -- :hi:lo
        (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case { HL Word32
_  -> Bool
True; FF
_ -> Bool
False }) BoundedPrim FF
build_HL  (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ --  hi:lo
        (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case { FF
NOP   -> Bool
True; FF
_ -> Bool
False }) BoundedPrim FF
forall b. BoundedPrim b
build_NOP (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ --
        (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case { FF
COL   -> Bool
True; FF
_ -> Bool
False }) BoundedPrim FF
forall b. BoundedPrim b
build_COL (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ -- :
        (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case { FF
CC    -> Bool
True; FF
_ -> Bool
False }) BoundedPrim FF
forall b. BoundedPrim b
build_CC  (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ -- :  :
        (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case { CLO Word32
_ -> Bool
True; FF
_ -> Bool
False }) BoundedPrim FF
build_CLO (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ --    :lo
        (FF -> Bool) -> BoundedPrim FF -> BoundedPrim FF -> BoundedPrim FF
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
P.condB (\case { CHC Word32
_ -> Bool
True; FF
_ -> Bool
False }) BoundedPrim FF
build_CHC (BoundedPrim FF -> BoundedPrim FF)
-> BoundedPrim FF -> BoundedPrim FF
forall a b. (a -> b) -> a -> b
$ -- :hi:
                                                      BoundedPrim FF
build_HC    --  hi:

    -- encoders for the eight field format (FF) cases.
    --
    build_CHL :: BoundedPrim FF
build_CHL = (\ (CHL Word32
w) -> ( Word16 -> ((), Word16)
forall a. a -> ((), a)
fstUnit (Word32 -> Word16
hi16 Word32
w), Word16 -> ((), Word16)
forall a. a -> ((), a)
fstUnit (Word32 -> Word16
lo16 Word32
w) ) )
                (FF -> (((), Word16), ((), Word16)))
-> BoundedPrim (((), Word16), ((), Word16)) -> BoundedPrim FF
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim ()
forall b. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim Word16 -> BoundedPrim ((), Word16)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word16
P.word16Hex)
                BoundedPrim ((), Word16)
-> BoundedPrim ((), Word16)
-> BoundedPrim (((), Word16), ((), Word16))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< (BoundedPrim ()
forall b. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim Word16 -> BoundedPrim ((), Word16)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word16
P.word16Hex)
    --
    build_HL :: BoundedPrim FF
build_HL  = (\ (HL  Word32
w) -> ( Word32 -> Word16
hi16 Word32
w, Word16 -> ((), Word16)
forall a. a -> ((), a)
fstUnit (Word32 -> Word16
lo16 Word32
w) ) )
                (FF -> (Word16, ((), Word16)))
-> BoundedPrim (Word16, ((), Word16)) -> BoundedPrim FF
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim Word16
P.word16Hex BoundedPrim Word16
-> BoundedPrim ((), Word16) -> BoundedPrim (Word16, ((), Word16))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall b. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim Word16 -> BoundedPrim ((), Word16)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word16
P.word16Hex
    --
    build_NOP :: BoundedPrim a
build_NOP  = BoundedPrim a
forall b. BoundedPrim b
P.emptyB
    --
    build_COL :: BoundedPrim b
build_COL  = () -> b -> ()
forall a b. a -> b -> a
const () (b -> ()) -> BoundedPrim () -> BoundedPrim b
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ()
forall b. BoundedPrim b
colsep
    --
    build_CC :: BoundedPrim b
build_CC   = ((), ()) -> b -> ((), ())
forall a b. a -> b -> a
const ((), ()) (b -> ((), ())) -> BoundedPrim ((), ()) -> BoundedPrim b
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ()
forall b. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim () -> BoundedPrim ((), ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall b. BoundedPrim b
colsep
    --
    build_CLO :: BoundedPrim FF
build_CLO = (\ (CLO Word32
w) -> Word16 -> ((), Word16)
forall a. a -> ((), a)
fstUnit (Word32 -> Word16
lo16 Word32
w) )
                (FF -> ((), Word16)) -> BoundedPrim ((), Word16) -> BoundedPrim FF
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ()
forall b. BoundedPrim b
colsep BoundedPrim () -> BoundedPrim Word16 -> BoundedPrim ((), Word16)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word16
P.word16Hex
    --
    build_CHC :: BoundedPrim FF
build_CHC = (\ (CHC Word32
w) -> (Word16, ()) -> ((), (Word16, ()))
forall a. a -> ((), a)
fstUnit (Word16 -> (Word16, ())
forall a. a -> (a, ())
sndUnit (Word32 -> Word16
hi16 Word32
w)) )
                (FF -> ((), (Word16, ())))
-> BoundedPrim ((), (Word16, ())) -> BoundedPrim FF
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim ()
forall b. BoundedPrim b
colsep BoundedPrim ()
-> BoundedPrim (Word16, ()) -> BoundedPrim ((), (Word16, ()))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Word16
P.word16Hex BoundedPrim Word16 -> BoundedPrim () -> BoundedPrim (Word16, ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall b. BoundedPrim b
colsep
    --
    build_HC :: BoundedPrim FF
build_HC  = (\ (HC  Word32
w) -> Word16 -> (Word16, ())
forall a. a -> (a, ())
sndUnit (Word32 -> Word16
hi16 Word32
w))
                (FF -> (Word16, ())) -> BoundedPrim (Word16, ()) -> BoundedPrim FF
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim Word16
P.word16Hex BoundedPrim Word16 -> BoundedPrim () -> BoundedPrim (Word16, ())
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim ()
forall b. BoundedPrim b
colsep

    -- static encoders
    --
    colsep :: P.BoundedPrim a
    colsep :: BoundedPrim a
colsep = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
toB (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ Word8 -> a -> Word8
forall a b. a -> b -> a
const Word8
0x3a (a -> Word8) -> FixedPrim Word8 -> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< FixedPrim Word8
P.word8
    --
    ffff :: P.BoundedPrim a
    ffff :: BoundedPrim a
ffff = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
toB (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ Word16 -> a -> Word16
forall a b. a -> b -> a
const Word16
0xffff (a -> Word16) -> FixedPrim Word16 -> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< FixedPrim Word16
P.word16HexFixed

    -- | Helpers
    hi16, lo16 :: Word32 -> Word16
    hi16 :: Word32 -> Word16
hi16 !(W32# Word#
w) = Word# -> Word16
W16# (Word#
w Word# -> Int# -> Word#
`uncheckedShiftRL#` Int#
16#)
    lo16 :: Word32 -> Word16
lo16 !(W32# Word#
w) = Word# -> Word16
W16# (Word#
w Word# -> Word# -> Word#
`and#` Word#
0xffff##)
    --
    fstUnit :: a -> ((), a)
    fstUnit :: a -> ((), a)
fstUnit = ((), )
    --
    sndUnit :: a -> (a, ())
    sndUnit :: a -> (a, ())
sndUnit = (, ())
    --
    pairPair :: (a, b, a, b) -> ((a, b), (a, b))
pairPair (a
a, b
b, a
c, b
d) = ((a
a, b
b), (a
c, b
d))

    -- Construct fields decorated with output format details
    genFields :: (Word32, Word32, Word32, Word32) -> ((FF, FF), (FF, FF))
genFields (Word32
w0, Word32
w1, Word32
w2, Word32
w3) =
        let !(!Int
gapStart, !Int
gapEnd) = Word32 -> Word32 -> Word32 -> Word32 -> (Int, Int)
bestgap Word32
w0 Word32
w1 Word32
w2 Word32
w3
            !f0 :: FF
f0 = Int -> Int -> Word32 -> FF
makeF0 Int
gapStart Int
gapEnd Word32
w0
            !f1 :: FF
f1 = Int -> Int -> Int# -> Int# -> Word32 -> FF
makeF12 Int
gapStart Int
gapEnd Int#
2# Int#
3# Word32
w1
            !f2 :: FF
f2 = Int -> Int -> Int# -> Int# -> Word32 -> FF
makeF12 Int
gapStart Int
gapEnd Int#
4# Int#
5# Word32
w2
            !f3 :: FF
f3 = Int -> Int -> Word32 -> FF
makeF3 Int
gapStart Int
gapEnd Word32
w3
         in ((FF
f0, FF
f1), (FF
f2, FF
f3))

    makeF0 :: Int -> Int -> Word32 -> FF
makeF0 (I# Int#
gapStart) (I# Int#
gapEnd) !Word32
w =
        case (Int#
gapEnd Int# -> Int# -> Int#
==# Int#
0#) Int# -> Int# -> Int#
`orI#` (Int#
gapStart Int# -> Int# -> Int#
># Int#
1#) of
        Int#
1#                               -> Word32 -> FF
HL  Word32
w
        Int#
_  -> case Int#
gapStart Int# -> Int# -> Int#
==# Int#
0# of
              Int#
1#                         -> FF
COL
              Int#
_                          -> Word32 -> FF
HC  Word32
w
    {-# INLINE makeF0 #-}

    makeF12 :: Int -> Int -> Int# -> Int# -> Word32 -> FF
makeF12 (I# Int#
gapStart) (I# Int#
gapEnd) Int#
il Int#
ir !Word32
w =
        case (Int#
gapEnd Int# -> Int# -> Int#
<=# Int#
il) Int# -> Int# -> Int#
`orI#` (Int#
gapStart Int# -> Int# -> Int#
># Int#
ir) of
        Int#
1#                               -> Word32 -> FF
CHL Word32
w
        Int#
_ -> case Int#
gapStart Int# -> Int# -> Int#
>=# Int#
il of
             Int#
1# -> case Int#
gapStart Int# -> Int# -> Int#
==# Int#
il of
                   Int#
1#                    -> FF
COL
                   Int#
_                     -> Word32 -> FF
CHC Word32
w
             Int#
_  -> case Int#
gapEnd Int# -> Int# -> Int#
==# Int#
ir of
                   Int#
0#                    -> FF
NOP
                   Int#
_                     -> Word32 -> FF
CLO Word32
w
    {-# INLINE makeF12 #-}

    makeF3 :: Int -> Int -> Word32 -> FF
makeF3 (I# Int#
gapStart) (I# Int#
gapEnd) !Word32
w =
        case Int#
gapEnd Int# -> Int# -> Int#
<=# Int#
6# of
        Int#
1#                               -> Word32 -> FF
CHL Word32
w
        Int#
_ -> case Int#
gapStart Int# -> Int# -> Int#
==# Int#
6# of
             Int#
0# -> case Int#
gapEnd Int# -> Int# -> Int#
==# Int#
8# of
                   Int#
1#                    -> FF
COL
                   Int#
_                     -> Word32 -> FF
CLO Word32
w
             Int#
_                           -> FF
CC
    {-# INLINE makeF3 #-}

-- | Unrolled and inlined calculation of the first longest
-- run (gap) of 16-bit aligned zeros in the input address.
--
bestgap :: Word32 -> Word32 -> Word32 -> Word32 -> (Int, Int)
bestgap :: Word32 -> Word32 -> Word32 -> Word32 -> (Int, Int)
bestgap !(W32# Word#
a0) !(W32# Word#
a1) !(W32# Word#
a2) !(W32# Word#
a3) =
    Int# -> (Int, Int)
finalGap
        (Word# -> Int# -> Int#
updateGap (Word#
0xffff##     Word# -> Word# -> Word#
`and#` Word#
a3)
        (Word# -> Int# -> Int#
updateGap (Word#
0xffff0000## Word# -> Word# -> Word#
`and#` Word#
a3)
        (Word# -> Int# -> Int#
updateGap (Word#
0xffff##     Word# -> Word# -> Word#
`and#` Word#
a2)
        (Word# -> Int# -> Int#
updateGap (Word#
0xffff0000## Word# -> Word# -> Word#
`and#` Word#
a2)
        (Word# -> Int# -> Int#
updateGap (Word#
0xffff##     Word# -> Word# -> Word#
`and#` Word#
a1)
        (Word# -> Int# -> Int#
updateGap (Word#
0xffff0000## Word# -> Word# -> Word#
`and#` Word#
a1)
        (Word# -> Int# -> Int#
updateGap (Word#
0xffff##     Word# -> Word# -> Word#
`and#` Word#
a0)
        (Word# -> Int#
initGap   (Word#
0xffff0000## Word# -> Word# -> Word#
`and#` Word#
a0)))))))))
  where

    -- The state after the first input word is always i' = 7,
    -- but if the input word is zero, then also g=z=1 and e'=7.
    initGap :: Word# -> Int#
    initGap :: Word# -> Int#
initGap Word#
w = case Word#
w of { Word#
0## -> Int#
0x1717#; Word#
_ -> Int#
0x0707# }

    -- Update the nibbles of g|e'|z|i' based on the next input
    -- word.  We always decrement i', reset z on non-zero input,
    -- otherwise increment z and check for a new best gap, if so
    -- we replace g|e' with z|i'.
    updateGap :: Word# -> Int# -> Int#
    updateGap :: Word# -> Int# -> Int#
updateGap Word#
w Int#
g = case Word#
w Word# -> Word# -> Int#
`neWord#` Word#
0## of
        Int#
1# -> (Int#
g Int# -> Int# -> Int#
+# Int#
0xffff#) Int# -> Int# -> Int#
`andI#` Int#
0xff0f#  -- g, e, 0, --i
        Int#
_  -> let old :: Int#
old = Int#
g Int# -> Int# -> Int#
+# Int#
0xf#             -- ++z, --i
                  zi :: Int#
zi  = Int#
old Int# -> Int# -> Int#
`andI#` Int#
0xff#
                  new :: Int#
new = (Int#
zi Int# -> Int# -> Int#
`uncheckedIShiftL#` Int#
8#) Int# -> Int# -> Int#
`orI#` Int#
zi
               in case Int#
new Int# -> Int# -> Int#
># Int#
old of
                  Int#
1# -> Int#
new            -- z, i, z, i
                  Int#
_  -> Int#
old            -- g, e, z, i

    -- Extract gap start and end from the nibbles of g|e'|z|i'
    -- where g is the gap width and e' is 8 minus its end.
    finalGap :: Int# -> (Int, Int)
    finalGap :: Int# -> (Int, Int)
finalGap Int#
i =
        let g :: Int#
g = Int#
i Int# -> Int# -> Int#
`uncheckedIShiftRL#` Int#
12#
         in case Int#
g Int# -> Int# -> Int#
<# Int#
2# of
            Int#
1# -> (Int
0, Int
0)
            Int#
_  -> let e :: Int#
e = Int#
8# Int# -> Int# -> Int#
-# ((Int#
i Int# -> Int# -> Int#
`uncheckedIShiftRL#` Int#
8#) Int# -> Int# -> Int#
`andI#` Int#
0xf#)
                      s :: Int#
s = Int#
e Int# -> Int# -> Int#
-# Int#
g
                   in (Int# -> Int
I# Int#
s, Int# -> Int
I# Int#
e)
{-# INLINE bestgap #-}