diff --git a/Data/Time/Zones.hs b/Data/Time/Zones.hs --- a/Data/Time/Zones.hs +++ b/Data/Time/Zones.hs @@ -31,13 +31,13 @@ ) where import Data.Bits (shiftR) -import Data.Fixed (divMod') import Data.Int (Int64) import Data.Time import qualified Data.Vector as VB import qualified Data.Vector.Unboxed as VU import Data.Time.Zones.Types import Data.Time.Zones.Read +import Data.Time.Zones.Internal -- | Returns the time difference (in seconds) for TZ at the given -- POSIX time. @@ -62,8 +62,7 @@ -- | Returns the `TimeZone` for the `TZ` at the given `UTCTime`. timeZoneForUTCTime :: TZ -> UTCTime -> TimeZone {-# INLINABLE timeZoneForUTCTime #-} -timeZoneForUTCTime tz (UTCTime day tid) - = timeZoneForPOSIX tz $ dayTimeToInt64 day tid +timeZoneForUTCTime tz ut = timeZoneForPOSIX tz $ utcTimeToInt64 ut -- | Returns the `LocalTime` corresponding to the given `UTCTime` in `TZ`. -- @@ -71,14 +70,10 @@ -- (`timeZoneForPOSIX` tz ut) ut@ except when the time difference is not -- an integral number of minutes utcToLocalTimeTZ :: TZ -> UTCTime -> LocalTime -utcToLocalTimeTZ tz (UTCTime day dtime) = LocalTime day' tod +utcToLocalTimeTZ tz utcT = int64PairToLocalTime ut' ps where - diff = diffForPOSIX tz $ dayTimeToInt64 day dtime - (m', s) = (dtime + fromIntegral diff) `divMod'` 60 - (h', m) = m' `divMod` 60 - (d', h) = h' `divMod` 24 - day' = fromIntegral d' `addDays` day - tod = TimeOfDay h m (realToFrac s) + (ut, ps) = utcTimeToInt64Pair utcT + ut' = ut + fromIntegral (diffForPOSIX tz ut) -- | The `TZ` definition for UTC. utcTZ :: TZ @@ -198,23 +193,15 @@ , _ltuSecondZone :: TimeZone } deriving (Eq, Show) --- TODO(klao): measure the improvement -dayTimeToInt64 :: RealFrac a => Day -> a -> Int64 -{-# INLINE dayTimeToInt64 #-} -dayTimeToInt64 (ModifiedJulianDay d) t = 86400 * (fromIntegral d - unixEpochDay) + floor t - where - unixEpochDay = 40587 - -- TODO(klao): better name localTimeToUTCFull :: TZ -> LocalTime -> LocalToUTCResult -localTimeToUTCFull tz@(TZ _ diffs _) (LocalTime day tod) = res +localTimeToUTCFull tz@(TZ _ diffs _) localT = res where - tid = timeOfDayToTime tod - t = dayTimeToInt64 day tid - addDiff i = UTCTime (addDays d day) tid' + (t,ps) = localTimeToInt64Pair localT + addDiff i = int64PairToUTCTime t' ps where diff = VU.unsafeIndex diffs i - (d, tid') = (tid - fromIntegral diff) `divMod'` 86400 + t' = t - fromIntegral diff res = case localToPOSIX tz t of FLGap i _ -> LTUNone (addDiff i) (timeZoneForIx tz i) FLUnique i _ -> LTUUnique (addDiff i) (timeZoneForIx tz i) diff --git a/Data/Time/Zones/Internal.hs b/Data/Time/Zones/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Zones/Internal.hs @@ -0,0 +1,103 @@ +{- | +Module : Data.Time.Zones.Internal +Copyright : (C) 2014 Mihaly Barasz +License : Apache-2.0, see LICENSE +Maintainer : Mihaly Barasz +Stability : experimental +-} + +{-# LANGUAGE TemplateHaskell #-} + +module Data.Time.Zones.Internal ( + -- * Time conversion to/from @Int64@ + utcTimeToInt64, + utcTimeToInt64Pair, + localTimeToInt64Pair, + int64PairToUTCTime, + int64PairToLocalTime, + -- * Low-level \"coercions\" + picoToInteger, + integerToPico, + diffTimeToPico, + picoToDiffTime, + diffTimeToInteger, + integerToDiffTime, + ) where + +import Data.Fixed +import Data.Int +import Data.Time +import Data.Time.Zones.Internal.CoerceTH + +utcTimeToInt64Pair :: UTCTime -> (Int64, Int64) +utcTimeToInt64Pair (UTCTime (ModifiedJulianDay d) t) + = (86400 * (fromIntegral d - unixEpochDay) + s, ps) + where + (s, ps) = fromIntegral (diffTimeToInteger t) `divMod` 1000000000000 + unixEpochDay = 40587 +{-# INLINE utcTimeToInt64Pair #-} + +int64PairToLocalTime :: Int64 -> Int64 -> LocalTime +int64PairToLocalTime t ps = LocalTime (ModifiedJulianDay day) (TimeOfDay h m s) + where + (day64, tid64) = t `divMod` 86400 + day = fromIntegral $ day64 + 40587 + (h, ms) = fromIntegral tid64 `quotRem` 3600 + (m, s0) = ms `quotRem` 60 + s = integerToPico $ fromIntegral $ ps + 1000000000000 * fromIntegral s0 +{-# INLINE int64PairToLocalTime #-} + +localTimeToInt64Pair :: LocalTime -> (Int64, Int64) +localTimeToInt64Pair (LocalTime (ModifiedJulianDay day) (TimeOfDay h m s)) + = (86400 * (fromIntegral day - unixEpochDay) + tid, ps) + where + (s64, ps) = fromIntegral (picoToInteger s) `divMod` 1000000000000 + tid = s64 + fromIntegral (h * 3600 + m * 60) + unixEpochDay = 40587 +{-# INLINE localTimeToInt64Pair #-} + +int64PairToUTCTime :: Int64 -> Int64 -> UTCTime +int64PairToUTCTime t ps = UTCTime (ModifiedJulianDay day) tid + where + (day64, tid64) = t `divMod` 86400 + day = fromIntegral $ day64 + 40587 + tid = integerToDiffTime $ fromIntegral $ ps + tid64 * 1000000000000 +{-# INLINE int64PairToUTCTime #-} + +utcTimeToInt64 :: UTCTime -> Int64 +utcTimeToInt64 (UTCTime (ModifiedJulianDay d) t) + = 86400 * (fromIntegral d - unixEpochDay) + + fromIntegral (diffTimeToInteger t) `div` 1000000000000 + where + unixEpochDay = 40587 +{-# INLINE utcTimeToInt64 #-} + +-------------------------------------------------------------------------------- +-- Low-level zero-overhead conversions. +-- Basically we could have used 'coerce' if the constructors were exported. + +-- TODO(klao): Is it better to inline them saturated or unsaturated? + +picoToInteger :: Pico -> Integer +picoToInteger p = $(destructNewType ''Fixed) p +{-# INLINE picoToInteger #-} + +integerToPico :: Integer -> Pico +integerToPico i = $(constructNewType ''Fixed) i +{-# INLINE integerToPico #-} + +diffTimeToPico :: DiffTime -> Pico +diffTimeToPico dt = $(destructNewType ''DiffTime) dt +{-# INLINE diffTimeToPico #-} + +picoToDiffTime :: Pico -> DiffTime +picoToDiffTime p = $(constructNewType ''DiffTime) p +{-# INLINE picoToDiffTime #-} + +diffTimeToInteger :: DiffTime -> Integer +diffTimeToInteger dt = picoToInteger (diffTimeToPico dt) +{-# INLINE diffTimeToInteger #-} + +integerToDiffTime :: Integer -> DiffTime +integerToDiffTime i = picoToDiffTime (integerToPico i) +{-# INLINE integerToDiffTime #-} diff --git a/Data/Time/Zones/Internal/CoerceTH.hs b/Data/Time/Zones/Internal/CoerceTH.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Zones/Internal/CoerceTH.hs @@ -0,0 +1,37 @@ +{- | +Module : Data.Time.Zones.Internal.CoerceTH +Copyright : (C) 2014 Mihaly Barasz +License : Apache-2.0, see LICENSE +Maintainer : Mihaly Barasz +Stability : experimental +-} + +{-# LANGUAGE TemplateHaskell #-} + +module Data.Time.Zones.Internal.CoerceTH ( + getNewTypeCon, + constructNewType, + destructNewType, + ) where + +import Language.Haskell.TH + +getNewTypeCon :: Name -> Q Name +getNewTypeCon newTy = do + info <- reify newTy + case info of + TyConI (NewtypeD _ _ _ (NormalC name _) _) -> return name + _ -> fail "Not a newtype" + +constructNewType :: Name -> Q Exp +constructNewType newTy = ConE `fmap` getNewTypeCon newTy + +destructNewType :: Name -> Q Exp +destructNewType newTy = do + con <- getNewTypeCon newTy + lamV <- newName "x" + patV <- newName "v" + return $ + LamE [VarP lamV] + (CaseE (VarE lamV) [ + Match (ConP con [VarP patV]) (NormalB (VarE patV)) []]) diff --git a/benchmarks/benchConv.hs b/benchmarks/benchConv.hs new file mode 100644 --- /dev/null +++ b/benchmarks/benchConv.hs @@ -0,0 +1,76 @@ +module Main (main) where + +import Criterion.Main +import Data.Int +import Data.Time +import Data.Time.Clock.POSIX +import Data.Time.Zones.Internal + +utc2int64Naive :: UTCTime -> Int64 +utc2int64Naive ut = floor $ utcTimeToPOSIXSeconds ut + +utc2int64Floor :: UTCTime -> Int64 +utc2int64Floor (UTCTime (ModifiedJulianDay d) t) + = 86400 * (fromIntegral d - unixEpochDay) + floor t + where + unixEpochDay = 40587 + +utc2int64Full :: UTCTime -> Int64 +utc2int64Full (UTCTime (ModifiedJulianDay d) t) + = 86400 * (fromIntegral d - unixEpochDay) + + fromIntegral (diffTimeToInteger t) `div` 1000000000000 + where + unixEpochDay = 40587 + + +local2utcNaive :: LocalTime -> UTCTime +local2utcNaive (LocalTime day tod) = UTCTime day (timeOfDayToTime tod) + +local2utcNaive2 :: LocalTime -> UTCTime +local2utcNaive2 = localTimeToUTC utc + +local2utcFull :: LocalTime -> UTCTime +local2utcFull (LocalTime day (TimeOfDay h m s)) = UTCTime day tid + where + ps :: Int64 + ps = fromIntegral (picoToInteger s) + tid = integerToDiffTime (fromIntegral tid64) + tid64 = ps + fromIntegral h * 3600000000000000 + fromIntegral m * 60000000000000 + + +utc2localNaive :: UTCTime -> LocalTime +utc2localNaive = utcToLocalTime utc + +utc2localFull :: UTCTime -> LocalTime +utc2localFull (UTCTime day tid) = LocalTime day tod + where + tid64 :: Int64 + tid64 = fromIntegral (diffTimeToInteger tid) + (hm, ps) = tid64 `divMod` 60000000000000 + (h, m) = fromIntegral hm `divMod` 60 + tod = TimeOfDay h m (integerToPico $ fromIntegral ps) + + +benchmarks :: [Benchmark] +benchmarks = [ + bgroup "UTCTimeToInt64" [ + bench "naive" $ whnf utc2int64Naive t, + bench "floor" $ whnf utc2int64Floor t, + bench "full" $ whnf utc2int64Full t + ], + bgroup "LocalToUTC" [ + bench "naive" $ nf local2utcNaive l, + bench "naive2" $ nf local2utcNaive2 l, + bench "full" $ nf local2utcFull l + ], + bgroup "UTCToLocal" [ + bench "naive" $ nf utc2localNaive t, + bench "full" $ nf utc2localFull t + ] + ] + where + t = UTCTime (fromGregorian 2014 07 23) 7268.123456789555 + l = LocalTime (fromGregorian 2014 07 23) (TimeOfDay 22 48 53.123456789888) + +main :: IO () +main = defaultMain benchmarks diff --git a/benchmarks/benchGreg.hs b/benchmarks/benchGreg.hs --- a/benchmarks/benchGreg.hs +++ b/benchmarks/benchGreg.hs @@ -14,7 +14,7 @@ data YD = YD { _ydYear :: {-# UNPACK #-} !Int, _ydDay :: {-# UNPACK #-} !Int - } deriving (Show) + } deriving (Eq, Show) makeLenses ''YD @@ -58,6 +58,37 @@ year = quadcent * 400 + cent * 100 + quad * 4 + y + 1 -------------------------------------------------------------------------------- +-- Brief description of the toOrdinal computation. +-- +-- The length of the years in Gregorian calendar is periodic with +-- period of 400 years. There are 100 - 4 + 1 = 97 leap years in a +-- period, so the average length of a year is 365 + 97/400 = +-- 146097/400 days. +-- +-- Now, if you consider these -- let's call them nominal -- years, +-- then for any point in time, for any linear day number we can +-- determine which nominal year does it fall into by a single +-- division. Moreover, if we align the start of the calendar year 1 +-- with the start of the nominal year 1, then the calendar years and +-- nominal years never get too much out of sync. Specifically: +-- +-- * start of the first day of a calendar year might fall into the +-- preceding nominal year, but never more than by 1.5 days (591/400 +-- days, to be precise) +-- * the start of the last day of a calendar year always falls into +-- its nominal year (even for the leap years). +-- +-- So, to find out the calendar year for a given day, we calculate +-- which nominal year does its start fall. And, if we are not too +-- close to the end of year, we have the right calendar +-- year. Othewise, we just check whether it falls within the next +-- calendar year. +-- +-- Notes: to make the reasoning simpler and more efficient ('quot' is +-- faster than 'div') we do the computation directly only for positive +-- years (days after 1-1-1). For earlier dates we "transate" by an +-- integral number of 400 year periods, do the computation and +-- translate back. isLeapYearI :: Int -> Bool {-# INLINABLE isLeapYearI #-} @@ -71,33 +102,32 @@ where cs = ys `quot` 100 -toOrdinalB0 :: Int -> YD -{-# INLINE toOrdinalB0 #-} -toOrdinalB0 b0 = res - where - (y, r) = (400 * b0) `quotRem` 146097 - ls = countLeapYears y - res = if r < 146097 - 400 - then YD y (b0 - 365*y - ls) - else let y' = if isLeapYearI (y+1) then y else y+1 - in YD y' (b0 - 365*y' - ls) - -toOrdinalPr :: Int -> YD -{-# INLINABLE toOrdinalPr #-} -toOrdinalPr !mjd | b0 >= 0 = toOrdinalB0 b0 - | otherwise = toOrdinalB0 m & ydYear +~ d * 400 +toOrdinalImproved :: Int -> YD +{-# INLINABLE toOrdinalImproved #-} +toOrdinalImproved !mjd + | b0 <= 0 = toOrdinalB0 m & ydYear +~ d * 400 + | otherwise = toOrdinalB0 b0 where b0 = mjd + 678575 (d,m) = b0 `divMod` 146097 -test :: Integer -> Int -> Int -> IO () -test y m md = do - let d = fromIntegral $ toModifiedJulianDay $ fromGregorian y m md - print $ d + 678575 - print $ toOrdinalDate' d - let YD y' yd = toOrdinalPr d - print $ YD (y'+1) (yd+1) +toOrdinalB0 :: Int -> YD +{-# INLINE toOrdinalB0 #-} +toOrdinalB0 dayB0 = res + where + (y0, r) = (400 * dayB0) `quotRem` 146097 + dayInYear y = dayB0 - 365 * y - countLeapYears y + 1 + d0 = dayInYear y0 + d1 = dayInYear (y0 + 1) + res = if r >= 146097 - 591 && d1 > 0 + then YD (y0 + 2) d1 + else YD (y0 + 1) d0 +checkToOrdinalImproved :: [(Int, (YD, YD))] +checkToOrdinalImproved = filter (uncurry (/=) . snd) l + where + l = [ (d, (toOrdinalDate' d', toOrdinalImproved d')) + | d <- [0 .. 400 * 366], let d' = d - 678575 ] benchmarks :: [Benchmark] benchmarks = [ @@ -111,7 +141,7 @@ bgroup "optim" [ bench "directCopy" $ whnf toOrdinalDateI d1i, bench "divModQuotRem" $ whnf toOrdinalDateDivMod d1i, - bench "divModPr" $ whnf toOrdinalPr d1i + bench "Improved" $ whnf toOrdinalImproved d1i ] ] where diff --git a/tz.cabal b/tz.cabal --- a/tz.cabal +++ b/tz.cabal @@ -1,5 +1,5 @@ Name: tz -Version: 0.0.0.6 +Version: 0.0.0.7 License: Apache-2.0 License-File: LICENSE Author: Mihaly Barasz, Gergely Risko @@ -38,7 +38,9 @@ Data.Time.Zones.Types, Data.Time.Zones.Read, Data.Time.Zones.All, - Data.Time.Zones.TH + Data.Time.Zones.TH, + Data.Time.Zones.Internal, + Data.Time.Zones.Internal.CoerceTH Other-Modules: Paths_tz Default-Language: Haskell2010 GHC-Options: -Wall @@ -142,4 +144,16 @@ criterion >= 0.8 && < 0.9, lens, thyme, + time + +Benchmark bench_conv + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + HS-Source-Dirs: benchmarks + Main-Is: benchConv.hs + GHC-Options: -Wall -O2 + Build-Depends: + tz, + base >= 4 && < 5, + criterion >= 0.8 && < 0.9, time