X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FTime.lhs;h=a3d9a733a6613e9005ee1b2f063aa32a56fabdb7;hb=1e2dc51066e0ebaf5d9baa8578386478078a430f;hp=b9bd4caa9efc4d647ae0b6263766e107b3112b44;hpb=ba98a8762849d4b6cfc1ac31f878ac6c50383907;p=ghc-hetmet.git diff --git a/ghc/lib/std/Time.lhs b/ghc/lib/std/Time.lhs index b9bd4ca..a3d9a73 100644 --- a/ghc/lib/std/Time.lhs +++ b/ghc/lib/std/Time.lhs @@ -19,6 +19,7 @@ module Time , getClockTime , TimeDiff(..) + , noTimeDiff -- non-standard (but useful when constructing TimeDiff vals.) , diffClockTimes , addToClockTime @@ -37,14 +38,21 @@ module Time #ifdef __HUGS__ import PreludeBuiltin #else -import PrelBase -import PrelShow -import PrelIOBase -import PrelHandle -import PrelArr -import PrelST -import PrelAddr -import PrelPack ( unpackCString, new_ps_array ) +import PrelGHC ( RealWorld, (>#), (<#), (==#), + newIntArray#, readIntArray#, + unsafeFreezeByteArray#, + int2Integer#, negateInt# ) +import PrelBase ( Int(..) ) +import PrelNum ( Integer(..), fromInt ) +import PrelIOBase ( IO(..), unsafePerformIO, stToIO, constructErrorAndFail ) +import PrelShow ( showList__ ) +import PrelPack ( unpackCString, unpackCStringBA, + new_ps_array, freeze_ps_array + ) +import PrelByteArr ( MutableByteArray(..) ) +import PrelHandle ( Bytes ) +import PrelAddr ( Addr ) + #endif import Ix @@ -79,7 +87,10 @@ external calendar time @CalendarTime@. -- In fact, I think one of Int32 or Word32 would do. - ADR data ClockTime = TOD Int64 Int64 deriving (Eq, Ord) #else -data ClockTime = TOD Integer Integer deriving (Eq, Ord) +data ClockTime = TOD Integer -- Seconds since 00:00:00 on 1 Jan 1970 + Integer -- Picoseconds with the specified second + deriving (Eq, Ord) + #endif \end{code} @@ -100,9 +111,17 @@ instance Show ClockTime where case int2Integer# i of (# s, d #) -> showsPrec p (TOD (J# s d) _nsec) showsPrec _ (TOD (J# s# d#) _nsec) = showString $ unsafePerformIO $ do - buf <- allocChars 38 -- exactly enough for error message - str <- showTime (I# s#) d# buf - return (unpackCString str) + let buflen@(I# buflen#) = 50 -- big enough for error message + buf <- allocChars buflen + if s# <# (negateInt# 1#) || s# ># 1# then + return "ClockTime.show{Time}: out of range" + else do + rc <- showTime (I# s#) d# buflen buf + if rc < 0 then + return "ClockTime.show{Time}: internal error" + else do + ba <- stToIO (freeze_ps_array buf buflen#) + return (unpackCStringBA ba) showList = showList__ (showsPrec 0) #endif @@ -136,7 +155,7 @@ field indicates whether Daylight Savings Time would be in effect. data CalendarTime = CalendarTime { ctYear :: Int, - ctMonth :: Int, + ctMonth :: Month, ctDay :: Int, ctHour :: Int, ctMin :: Int, @@ -175,6 +194,9 @@ data TimeDiff #endif } deriving (Eq,Ord,Read,Show) + +noTimeDiff :: TimeDiff +noTimeDiff = TimeDiff 0 0 0 0 0 0 0 \end{code} @getClockTime@ returns the current time in its internal representation. @@ -192,29 +214,30 @@ getClockTime = do return (TOD sec (nsec * 1000)) else constructErrorAndFail "getClockTime" - where + #ifdef __HUGS__ - malloc1 = primNewByteArray sizeof_int64 - cvtUnsigned arr = primReadInt64Array arr 0 +malloc1 = primNewByteArray sizeof_int64 +cvtUnsigned arr = primReadInt64Array arr 0 #else - malloc1 = IO $ \ s# -> - case newIntArray# 1# s# of - (# s2#, barr# #) -> - (# s2#, MutableByteArray bottom barr# #) - - -- The C routine fills in an unsigned word. We don't have - -- `unsigned2Integer#,' so we freeze the data bits and use them - -- for an MP_INT structure. Note that zero is still handled specially, - -- although (J# 1# (ptr to 0#)) is probably acceptable to gmp. - - cvtUnsigned (MutableByteArray _ arr#) = IO $ \ s# -> - case readIntArray# arr# 0# s# of - (# s2#, r# #) -> - if r# ==# 0# - then (# s2#, 0 #) - else case unsafeFreezeByteArray# arr# s2# of - (# s3#, frozen# #) -> - (# s3#, J# 1# frozen# #) +malloc1 :: IO (MutableByteArray RealWorld Int) +malloc1 = IO $ \ s# -> + case newIntArray# 1# s# of + (# s2#, barr# #) -> (# s2#, MutableByteArray bot bot barr# #) + where + bot = error "Time.malloc1" + + -- The C routine fills in an unsigned word. We don't have + -- `unsigned2Integer#,' so we freeze the data bits and use them + -- for an MP_INT structure. Note that zero is still handled specially, + -- although (J# 1# (ptr to 0#)) is probably acceptable to gmp. + +cvtUnsigned :: MutableByteArray RealWorld Int -> IO Integer +cvtUnsigned (MutableByteArray _ _ arr#) = IO $ \ s# -> + case readIntArray# arr# 0# s# of + (# s2#, r# #) | r# ==# 0# -> (# s2#, 0 #) + | otherwise -> + case unsafeFreezeByteArray# arr# s2# of + (# s3#, frozen# #) -> (# s3#, J# 1# frozen# #) #endif \end{code} @@ -226,35 +249,24 @@ t2} as a @TimeDiff@. \begin{code} -#ifdef __HUGS__ addToClockTime :: TimeDiff -> ClockTime -> ClockTime addToClockTime (TimeDiff year mon day hour min sec psec) - (TOD c_sec c_psec) = unsafePerformIO $ do - res <- allocWords sizeof_int64 - rc <- toClockSec year mon day hour min sec 0 res - if rc /= (0::Int) - then do - diff_sec <- primReadInt64Array res 0 - let diff_psec = psec - return (TOD (c_sec + diff_sec) (c_psec + diff_psec)) - else - error "Time.addToClockTime: can't perform conversion of TimeDiff" -#else -addToClockTime :: TimeDiff -> ClockTime -> ClockTime -addToClockTime (TimeDiff year mon day hour min sec psec) - (TOD c_sec c_psec) = unsafePerformIO $ do - res <- stToIO (newIntArray (0,sizeof_time_t)) - rc <- toClockSec year mon day hour min sec (0::Int) res - if rc /= 0 - then do - diff_sec_i <- stToIO (readIntArray res 0) - let - diff_sec = int2Integer (case diff_sec_i of I# i# -> i#) - diff_psec = psec - return (TOD (c_sec + diff_sec) (c_psec + diff_psec)) - else - error "Time.addToClockTime: can't perform conversion of TimeDiff" -#endif + (TOD c_sec c_psec) = + let + sec_diff = fromInt sec + 60 * fromInt min + 3600 * fromInt hour + 24 * 3600 * fromInt day + cal = toUTCTime (TOD (c_sec + sec_diff) (c_psec + psec)) + + new_mon = fromEnum (ctMonth cal) + r_mon + (month', yr_diff) + | new_mon < 0 = (toEnum (12 + new_mon), (-1)) + | new_mon > 11 = (toEnum (new_mon `mod` 12), 1) + | otherwise = (toEnum new_mon, 0) + + (r_yr, r_mon) = mon `quotRem` 12 + + year' = ctYear cal + year + r_yr + yr_diff + in + toClockTime cal{ctMonth=month', ctYear=year'} diffClockTimes :: ClockTime -> ClockTime -> TimeDiff diffClockTimes tod_a tod_b = @@ -263,7 +275,7 @@ diffClockTimes tod_a tod_b = CalendarTime year_b mon_b day_b hour_b min_b sec_b psec_b _ _ _ _ _ = toUTCTime tod_b in TimeDiff (year_a - year_b) - (mon_a - mon_b) + (fromEnum mon_a - fromEnum mon_b) (day_a - day_b) (hour_a - hour_b) (min_a - min_b) @@ -333,7 +345,7 @@ toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz is else unsafePerformIO ( do res <- allocWords sizeof_int64 - rc <- toClockSec year mon mday hour min sec isDst res + rc <- toClockSec year (fromEnum mon) mday hour min sec isDst res if rc /= (0::Int) then do tm <- primReadInt64Array res 0 @@ -366,7 +378,11 @@ toCalendarTime (TOD (J# s# d#) psec) = do zone <- get_ZONE res tz <- get_GMTOFF res let tzname = unpackCString zone - return (CalendarTime (1900+year) mon mday hour min sec psec + month + | mon >= 0 && mon <= 11 = toEnum mon + | otherwise = error ("toCalendarTime: illegal month value: " ++ show mon) + + return (CalendarTime (1900+year) month mday hour min sec psec (toEnum wday) yday tzname tz (isdst /= (0::Int))) toUTCTime :: ClockTime -> CalendarTime @@ -388,7 +404,12 @@ toUTCTime (TOD (J# s# d#) psec) = unsafePerformIO $ do year <- get_tm_year res wday <- get_tm_wday res yday <- get_tm_yday res - return (CalendarTime (1900+year) mon mday hour min sec psec + let + month + | mon >= 0 && mon <= 11 = toEnum mon + | otherwise = error ("toCalendarTime: illegal month value: " ++ show mon) + + return (CalendarTime (1900+year) month mday hour min sec psec (toEnum wday) yday "UTC" 0 False) toClockTime :: CalendarTime -> ClockTime @@ -399,21 +420,18 @@ toClockTime (CalendarTime year mon mday hour min sec psec _wday _yday _tzname tz error "Time.toClockTime: timezone offset out of range" else unsafePerformIO ( do - res <- stToIO (newIntArray (0, sizeof_time_t)) - rc <- toClockSec year mon mday hour min sec isDst res + res <- malloc1 + rc <- toClockSec year (fromEnum mon) mday hour min sec isDst res if rc /= 0 then do - i <- stToIO (readIntArray res 0) - return (TOD (int2Integer (case i of I# i# -> i#)) psec) + i <- cvtUnsigned res + return (TOD i psec) else error "Time.toClockTime: can't perform conversion" ) where isDst = if isdst then (1::Int) else 0 #endif -bottom :: (Int,Int) -bottom = error "Time.bottom" - -- (copied from PosixUtil, for now) -- Allocate a mutable array of characters with no indices. @@ -436,7 +454,7 @@ allocWords :: Int -> IO (MutableByteArray RealWorld Int) allocWords (I# size#) = IO $ \ s# -> case newIntArray# size# s# of (# s2#, barr# #) -> - (# s2#, MutableByteArray bot barr# #) + (# s2#, MutableByteArray bot bot barr# #) where bot = error "Time.allocWords" #endif @@ -561,20 +579,20 @@ formatTimeDiff l fmt (TimeDiff year month day hour min sec _) \end{code} \begin{code} -foreign import "libHS_cbits" "get_tm_sec" get_tm_sec :: MBytes -> IO Int -foreign import "libHS_cbits" "get_tm_min" get_tm_min :: MBytes -> IO Int -foreign import "libHS_cbits" "get_tm_hour" get_tm_hour :: MBytes -> IO Int -foreign import "libHS_cbits" "get_tm_mday" get_tm_mday :: MBytes -> IO Int -foreign import "libHS_cbits" "get_tm_mon" get_tm_mon :: MBytes -> IO Int -foreign import "libHS_cbits" "get_tm_year" get_tm_year :: MBytes -> IO Int -foreign import "libHS_cbits" "get_tm_wday" get_tm_wday :: MBytes -> IO Int -foreign import "libHS_cbits" "get_tm_yday" get_tm_yday :: MBytes -> IO Int -foreign import "libHS_cbits" "get_tm_isdst" get_tm_isdst :: MBytes -> IO Int +foreign import "libHS_cbits" "get_tm_sec" unsafe get_tm_sec :: MBytes -> IO Int +foreign import "libHS_cbits" "get_tm_min" unsafe get_tm_min :: MBytes -> IO Int +foreign import "libHS_cbits" "get_tm_hour" unsafe get_tm_hour :: MBytes -> IO Int +foreign import "libHS_cbits" "get_tm_mday" unsafe get_tm_mday :: MBytes -> IO Int +foreign import "libHS_cbits" "get_tm_mon" unsafe get_tm_mon :: MBytes -> IO Int +foreign import "libHS_cbits" "get_tm_year" unsafe get_tm_year :: MBytes -> IO Int +foreign import "libHS_cbits" "get_tm_wday" unsafe get_tm_wday :: MBytes -> IO Int +foreign import "libHS_cbits" "get_tm_yday" unsafe get_tm_yday :: MBytes -> IO Int +foreign import "libHS_cbits" "get_tm_isdst" unsafe get_tm_isdst :: MBytes -> IO Int -foreign import "libHS_cbits" "prim_ZONE" prim_ZONE :: Bytes -> IO Addr -foreign import "libHS_cbits" "prim_GMTOFF" prim_GMTOFF :: Bytes -> IO Int +foreign import "libHS_cbits" "prim_ZONE" unsafe prim_ZONE :: Bytes -> IO Addr +foreign import "libHS_cbits" "prim_GMTOFF" unsafe prim_GMTOFF :: Bytes -> IO Int -foreign import "libHS_cbits" "sizeof_struct_tm" sizeof_struct_tm :: Int +foreign import "libHS_cbits" "sizeof_struct_tm" unsafe sizeof_struct_tm :: Int #ifdef __HUGS__ -- believed to be at least 1 bit (the sign bit!) bigger than sizeof_time_t @@ -584,32 +602,33 @@ sizeof_int64 = 8 type MBytes = MutableByteArray RealWorld Int -foreign import "libHS_cbits" "sizeof_time_t" sizeof_time_t :: Int +foreign import "libHS_cbits" "sizeof_time_t" unsafe sizeof_time_t :: Int -foreign import "libHS_cbits" "prim_SETZONE" prim_SETZONE :: MBytes -> MBytes -> IO Int +foreign import "libHS_cbits" "prim_SETZONE" unsafe prim_SETZONE :: MBytes -> MBytes -> IO () #ifdef __HUGS__ -foreign import "libHS_cbits" "prim_toLocalTime" prim_toLocalTime :: Int64 -> MBytes -> IO Int -foreign import "libHS_cbits" "prim_toUTCTime" prim_toUTCTime :: Int64 -> MBytes -> IO Int +foreign import "libHS_cbits" "prim_toLocalTime" unsafe prim_toLocalTime :: Int64 -> MBytes -> IO Int +foreign import "libHS_cbits" "prim_toUTCTime" unsafe prim_toUTCTime :: Int64 -> MBytes -> IO Int #else -foreign import "libHS_cbits" "toLocalTime" prim_toLocalTime :: Int -> Bytes -> MBytes -> IO Int -foreign import "libHS_cbits" "toUTCTime" prim_toUTCTime :: Int -> Bytes -> MBytes -> IO Int +foreign import "libHS_cbits" "toLocalTime" unsafe prim_toLocalTime :: Int -> Bytes -> MBytes -> IO Int +foreign import "libHS_cbits" "toUTCTime" unsafe prim_toUTCTime :: Int -> Bytes -> MBytes -> IO Int #endif -foreign import "libHS_cbits" "get_ZONE" get_ZONE :: MBytes -> IO Addr -foreign import "libHS_cbits" "GMTOFF" get_GMTOFF :: MBytes -> IO Int +foreign import "libHS_cbits" "get_ZONE" unsafe get_ZONE :: MBytes -> IO Addr +foreign import "libHS_cbits" "GMTOFF" unsafe get_GMTOFF :: MBytes -> IO Int -foreign import "libHS_cbits" "toClockSec" +foreign import "libHS_cbits" "toClockSec" unsafe toClockSec :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> MBytes -> IO Int -foreign import "libHS_cbits" "prim_getClockTime" +foreign import "libHS_cbits" "getClockTime" unsafe primGetClockTime :: MutableByteArray RealWorld Int -> MutableByteArray RealWorld Int -> IO Int -foreign import "libHS_cbits" "showTime" +foreign import "libHS_cbits" "showTime" unsafe showTime :: Int -> Bytes + -> Int -> MBytes - -> IO Addr{-packed C string -} + -> IO Int \end{code}