lookup_in_sorted_vector.hs

{-# OPTIONS_GHC -O2 -fforce-recomp -ddump-simpl -dsuppress-all -dsuppress-coercions #-}
{-# LANGUAGE BangPatterns #-}                                                      
{-# LANGUAGE MultiWayIf #-}                                                        
                                                                                   
import Data.Bits                                                                   
import qualified Data.Vector.Unboxed as UV                                         
                                                                                   
main :: IO ()                                                                      
main = do                                                                          
  v <- readLn                                                                      
  bs <- readLn                                                                     
  print (lookupUnboxedWord v 55)                                                   
  print (lookupUnboxedDouble bs 5.25)                                              
                                                                                   
{-# NOINLINE lookupUnboxedWord #-}                                                 
lookupUnboxedWord :: UV.Vector Word -> Word -> Maybe Int                           
lookupUnboxedWord v w = lookupSorted (UV.unsafeIndex v) (UV.length v) w            
                                                                                   
{-# NOINLINE lookupUnboxedDouble #-}                                               
lookupUnboxedDouble :: UV.Vector Double -> Double -> Maybe Int                     
lookupUnboxedDouble v w = lookupSorted (UV.unsafeIndex v) (UV.length v) w          
                                                                                   
-- | This lookup is O(log n).                                                      
lookupSorted :: Ord a => (Int -> a) -> Int -> a -> Maybe Int                       
lookupSorted lookupIx len needle =                                                 
  let !r = go 0 (len - 1)                                                          
   in if r < 0 then Nothing else Just r                                            
  where                                                                            
  go :: Int -> Int -> Int                                                          
  go !lo !hi = if lo <= hi                                                         
    then                                                                           
      let !mid = lo + (unsafeShiftR (hi - lo) 1)                                   
          !val = lookupIx mid                                                      
       in case compare val needle of                                               
            EQ -> mid                                                              
            LT -> go (mid + 1) hi                                                  
            GT -> go lo (mid - 1)                                                  
    else (-1)                                                                      

the_core.txt

[1 of 1] Compiling Main             ( core_test.hs, core_test.o )

==================== Tidy Core ====================
Result size of Tidy Core = {terms: 557, types: 349, coercions: 53}

-- RHS size: {terms: 2, types: 0, coercions: 0}
$trModule1
$trModule1 = TrNameS "Main"#

-- RHS size: {terms: 2, types: 0, coercions: 0}
$trModule2
$trModule2 = TrNameS "main"#

-- RHS size: {terms: 3, types: 0, coercions: 0}
$trModule
$trModule = Module $trModule2 $trModule1

-- RHS size: {terms: 6, types: 7, coercions: 6}
$slength5_rcCp
$slength5_rcCp =
  \ x_X8Hw ->
    case x_X8Hw `cast` ...
    of _ { Vector ipv_sbpk ipv1_sbpl ipv2_sbpm ->
    (I# ipv1_sbpl) `cast` ...
    }

-- RHS size: {terms: 1, types: 0, coercions: 5}
$slength
$slength = $slength5_rcCp `cast` ...

-- RHS size: {terms: 198, types: 62, coercions: 3}
lookupUnboxedDouble
lookupUnboxedDouble =
  \ v_a5L0 w_a5L1 ->
    case $slength v_a5L0 of _ { I# x_a8AF ->
    let {
      ww_sbB7
      ww_sbB7 = -# x_a8AF 1# } in
    case tagToEnum# (<=# 0# ww_sbB7) of _ {
      False -> Nothing;
      True ->
        case v_a5L0 `cast` ... of _ { Vector dt_a94p dt1_a94q dt2_a94r ->
        case w_a5L1 of _ { D# y_a95M ->
        let {
          ipv_s8B6
          ipv_s8B6 = uncheckedIShiftRA# ww_sbB7 1# } in
        case indexDoubleArray# dt2_a94r (+# dt_a94p ipv_s8B6)
        of wild4_a94B { __DEFAULT ->
        case tagToEnum# (<## wild4_a94B y_a95M) of _ {
          False ->
            case tagToEnum# (==## wild4_a94B y_a95M) of _ {
              False ->
                letrec {
                  $wgo_sbBc
                  $wgo_sbBc =
                    \ ww1_XbCz ww2_XbCE ->
                      case tagToEnum# (<=# ww1_XbCz ww2_XbCE) of _ {
                        False -> -1#;
                        True ->
                          let {
                            ipv1_X8CJ
                            ipv1_X8CJ =
                              +# ww1_XbCz (uncheckedIShiftRA# (-# ww2_XbCE ww1_XbCz) 1#) } in
                          case indexDoubleArray# dt2_a94r (+# dt_a94p ipv1_X8CJ)
                          of wild8_X96g { __DEFAULT ->
                          case tagToEnum# (<## wild8_X96g y_a95M) of _ {
                            False ->
                              case tagToEnum# (==## wild8_X96g y_a95M) of _ {
                                False -> $wgo_sbBc ww1_XbCz (-# ipv1_X8CJ 1#);
                                True -> ipv1_X8CJ
                              };
                            True -> $wgo_sbBc (+# ipv1_X8CJ 1#) ww2_XbCE
                          }
                          }
                      }; } in
                case $wgo_sbBc 0# (-# ipv_s8B6 1#) of ww1_sbBb { __DEFAULT ->
                case tagToEnum# (<# ww1_sbBb 0#) of _ {
                  False -> Just (I# ww1_sbBb);
                  True -> Nothing
                }
                };
              True ->
                case tagToEnum# (<# ipv_s8B6 0#) of _ {
                  False -> Just (I# ipv_s8B6);
                  True -> Nothing
                }
            };
          True ->
            letrec {
              $wgo_sbBc
              $wgo_sbBc =
                \ ww1_XbCx ww2_XbCC ->
                  case tagToEnum# (<=# ww1_XbCx ww2_XbCC) of _ {
                    False -> -1#;
                    True ->
                      let {
                        ipv1_X8CH
                        ipv1_X8CH =
                          +# ww1_XbCx (uncheckedIShiftRA# (-# ww2_XbCC ww1_XbCx) 1#) } in
                      case indexDoubleArray# dt2_a94r (+# dt_a94p ipv1_X8CH)
                      of wild7_X96e { __DEFAULT ->
                      case tagToEnum# (<## wild7_X96e y_a95M) of _ {
                        False ->
                          case tagToEnum# (==## wild7_X96e y_a95M) of _ {
                            False -> $wgo_sbBc ww1_XbCx (-# ipv1_X8CH 1#);
                            True -> ipv1_X8CH
                          };
                        True -> $wgo_sbBc (+# ipv1_X8CH 1#) ww2_XbCC
                      }
                      }
                  }; } in
            case $wgo_sbBc (+# ipv_s8B6 1#) ww_sbB7 of ww1_sbBb { __DEFAULT ->
            case tagToEnum# (<# ww1_sbBb 0#) of _ {
              False -> Just (I# ww1_sbBb);
              True -> Nothing
            }
            }
        }
        }
        }
        }
    }
    }

-- RHS size: {terms: 6, types: 7, coercions: 6}
$slength6_rcCq
$slength6_rcCq =
  \ x_a8FN ->
    case x_a8FN `cast` ...
    of _ { Vector ipv_sbpB ipv1_sbpC ipv2_sbpD ->
    (I# ipv1_sbpC) `cast` ...
    }

-- RHS size: {terms: 1, types: 0, coercions: 5}
$slength1
$slength1 = $slength6_rcCq `cast` ...

-- RHS size: {terms: 198, types: 62, coercions: 3}
lookupUnboxedWord
lookupUnboxedWord =
  \ v_a5KY w_a5KZ ->
    case $slength1 v_a5KY of _ { I# x_a8AF ->
    let {
      ww_sbBl
      ww_sbBl = -# x_a8AF 1# } in
    case tagToEnum# (<=# 0# ww_sbBl) of _ {
      False -> Nothing;
      True ->
        case v_a5KY `cast` ... of _ { Vector dt_a92d dt1_a92e dt2_a92f ->
        case w_a5KZ of _ { W# y#_a96l ->
        let {
          ipv_s8B6
          ipv_s8B6 = uncheckedIShiftRA# ww_sbBl 1# } in
        case indexWordArray# dt2_a92f (+# dt_a92d ipv_s8B6)
        of wild4_a92x { __DEFAULT ->
        case tagToEnum# (ltWord# wild4_a92x y#_a96l) of _ {
          False ->
            case tagToEnum# (eqWord# wild4_a92x y#_a96l) of _ {
              False ->
                letrec {
                  $wgo_sbBq
                  $wgo_sbBq =
                    \ ww1_XbCQ ww2_XbCV ->
                      case tagToEnum# (<=# ww1_XbCQ ww2_XbCV) of _ {
                        False -> -1#;
                        True ->
                          let {
                            ipv1_X8CM
                            ipv1_X8CM =
                              +# ww1_XbCQ (uncheckedIShiftRA# (-# ww2_XbCV ww1_XbCQ) 1#) } in
                          case indexWordArray# dt2_a92f (+# dt_a92d ipv1_X8CM)
                          of wild8_X94f { __DEFAULT ->
                          case tagToEnum# (ltWord# wild8_X94f y#_a96l) of _ {
                            False ->
                              case tagToEnum# (eqWord# wild8_X94f y#_a96l) of _ {
                                False -> $wgo_sbBq ww1_XbCQ (-# ipv1_X8CM 1#);
                                True -> ipv1_X8CM
                              };
                            True -> $wgo_sbBq (+# ipv1_X8CM 1#) ww2_XbCV
                          }
                          }
                      }; } in
                case $wgo_sbBq 0# (-# ipv_s8B6 1#) of ww1_sbBp { __DEFAULT ->
                case tagToEnum# (<# ww1_sbBp 0#) of _ {
                  False -> Just (I# ww1_sbBp);
                  True -> Nothing
                }
                };
              True ->
                case tagToEnum# (<# ipv_s8B6 0#) of _ {
                  False -> Just (I# ipv_s8B6);
                  True -> Nothing
                }
            };
          True ->
            letrec {
              $wgo_sbBq
              $wgo_sbBq =
                \ ww1_XbCO ww2_XbCT ->
                  case tagToEnum# (<=# ww1_XbCO ww2_XbCT) of _ {
                    False -> -1#;
                    True ->
                      let {
                        ipv1_X8CK
                        ipv1_X8CK =
                          +# ww1_XbCO (uncheckedIShiftRA# (-# ww2_XbCT ww1_XbCO) 1#) } in
                      case indexWordArray# dt2_a92f (+# dt_a92d ipv1_X8CK)
                      of wild7_X94d { __DEFAULT ->
                      case tagToEnum# (ltWord# wild7_X94d y#_a96l) of _ {
                        False ->
                          case tagToEnum# (eqWord# wild7_X94d y#_a96l) of _ {
                            False -> $wgo_sbBq ww1_XbCO (-# ipv1_X8CK 1#);
                            True -> ipv1_X8CK
                          };
                        True -> $wgo_sbBq (+# ipv1_X8CK 1#) ww2_XbCT
                      }
                      }
                  }; } in
            case $wgo_sbBq (+# ipv_s8B6 1#) ww_sbBl of ww1_sbBp { __DEFAULT ->
            case tagToEnum# (<# ww1_sbBp 0#) of _ {
              False -> Just (I# ww1_sbBp);
              True -> Nothing
            }
            }
        }
        }
        }
        }
    }
    }

-- RHS size: {terms: 2, types: 0, coercions: 0}
main2
main2 = D# 5.25##

-- RHS size: {terms: 2, types: 0, coercions: 0}
main3
main3 = W# 55##

-- RHS size: {terms: 5, types: 5, coercions: 3}
main4
main4 =
  (($fReadVector2 $fReadDouble $fUnboxDouble minPrec) `cast` ...)
    $fApplicativeP_$cpure

-- RHS size: {terms: 5, types: 5, coercions: 3}
main5
main5 =
  (($fReadVector2 $fReadWord $fUnboxWord minPrec) `cast` ...)
    $fApplicativeP_$cpure

-- RHS size: {terms: 105, types: 145, coercions: 10}
main1
main1 =
  \ s_a9Pt ->
    case wantReadableHandle_1
           hGetLine4 stdin (hGetLine2 `cast` ...) s_a9Pt
    of _ { (# ipv_a9lK, ipv1_a9lL #) ->
    case readIO8 (run main5 ipv1_a9lL) of _ {
      [] -> case raiseIO# readIO5 ipv_a9lK of wild1_00 { };
      : x_a9JD ds_a9JE ->
        case ds_a9JE of _ {
          [] ->
            case wantReadableHandle_1
                   hGetLine4 stdin (hGetLine2 `cast` ...) ipv_a9lK
            of _ { (# ipv2_X9nz, ipv3_X9nB #) ->
            case readIO8 (run main4 ipv3_X9nB) of _ {
              [] -> case raiseIO# readIO5 ipv2_X9nz of wild3_00 { };
              : x1_X9Lw ds3_X9Ly ->
                case ds3_X9Ly of _ {
                  [] ->
                    case hPutStr2
                           stdout
                           (case lookupUnboxedWord x_a9JD main3 of _ {
                              Nothing -> $fShowMaybe3;
                              Just b1_a8R2 ->
                                ++
                                  $fShowMaybe1
                                  (case b1_a8R2 of _ { I# ww3_a8Tp ->
                                   case $wshowSignedInt 11# ww3_a8Tp []
                                   of _ { (# ww5_a8Tt, ww6_a8Tu #) ->
                                   : ww5_a8Tt ww6_a8Tu
                                   }
                                   })
                            })
                           True
                           ipv2_X9nz
                    of _ { (# ipv4_a9Pj, ipv5_a9Pk #) ->
                    hPutStr2
                      stdout
                      (case lookupUnboxedDouble x1_X9Lw main2 of _ {
                         Nothing -> $fShowMaybe3;
                         Just b1_a8R2 ->
                           ++
                             $fShowMaybe1
                             (case b1_a8R2 of _ { I# ww3_a8Tp ->
                              case $wshowSignedInt 11# ww3_a8Tp []
                              of _ { (# ww5_a8Tt, ww6_a8Tu #) ->
                              : ww5_a8Tt ww6_a8Tu
                              }
                              })
                       })
                      True
                      ipv4_a9Pj
                    };
                  : ipv4_a9JL ipv5_a9JM ->
                    case raiseIO# readIO2 ipv2_X9nz of wild4_00 { }
                }
            }
            };
          : ipv2_a9JL ipv3_a9JM ->
            case raiseIO# readIO2 ipv_a9lK of wild2_00 { }
        }
    }
    }

-- RHS size: {terms: 1, types: 0, coercions: 3}
main
main = main1 `cast` ...

-- RHS size: {terms: 2, types: 1, coercions: 3}
main6
main6 = runMainIO1 (main1 `cast` ...)

-- RHS size: {terms: 1, types: 0, coercions: 3}
main
main = main6 `cast` ...


------ Local rules for imported ids --------
"SPEC/Main length @ Vector @ Double" [ALWAYS]
    forall $dVector_X8J6. length $dVector_X8J6 = $slength
"SPEC/Main length @ Vector @ Word" [ALWAYS]
    forall $dVector_X8J8. length $dVector_X8J8 = $slength1


Linking core_test ...