Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * Copyright (C) 1997-2000 NEC Research Institute. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | structure Time: TIME_EXTRA = | |
10 | struct | |
11 | ||
12 | structure Prim = PrimitiveFFI.Time | |
13 | ||
14 | (* A time is represented as a number of nanoseconds. *) | |
15 | val ticksPerSecond: LargeInt.int = 1000000000 | |
16 | ||
17 | datatype time = T of LargeInt.int | |
18 | ||
19 | val fromTicks = T | |
20 | ||
21 | exception Time | |
22 | ||
23 | val zeroTime = T 0 | |
24 | ||
25 | fun fromReal r = | |
26 | T (LargeReal.toLargeInt IEEEReal.TO_NEAREST | |
27 | (LargeReal.* (r, LargeReal.fromLargeInt ticksPerSecond))) | |
28 | handle Overflow => raise Time | |
29 | ||
30 | fun toReal (T i) = | |
31 | LargeReal./ (LargeReal.fromLargeInt i, | |
32 | LargeReal.fromLargeInt ticksPerSecond) | |
33 | ||
34 | local | |
35 | fun make ticksPer = | |
36 | let | |
37 | val d = LargeInt.quot (ticksPerSecond, ticksPer) | |
38 | in | |
39 | (fn i => T (LargeInt.* (i, d)), | |
40 | fn T i => LargeInt.quot (i, d)) | |
41 | end | |
42 | in | |
43 | val (fromSeconds, toSeconds) = make 1 | |
44 | val (fromMilliseconds, toMilliseconds) = make 1000 | |
45 | val (fromMicroseconds, toMicroseconds) = make 1000000 | |
46 | val (fromNanoseconds, toNanoseconds) = make 1000000000 | |
47 | end | |
48 | ||
49 | local | |
50 | fun make f (T i, T i') = f (i, i') | |
51 | in | |
52 | val compare = make LargeInt.compare | |
53 | val op < = make LargeInt.< | |
54 | val op <= = make LargeInt.<= | |
55 | val op > = make LargeInt.> | |
56 | val op >= = make LargeInt.>= | |
57 | end | |
58 | local | |
59 | fun make f (T i, T i') = T (f (i, i')) | |
60 | in | |
61 | val timeAdd = make LargeInt.+ | |
62 | val timeSub = make LargeInt.- | |
63 | end | |
64 | ||
65 | (* There's a mess here to work around a bug in vmware virtual machines | |
66 | * that may return a decreasing(!) sequence of time values. This will | |
67 | * cause some programs to raise Time exceptions where it should be | |
68 | * impossible. | |
69 | *) | |
70 | local | |
71 | fun getNow (): time = | |
72 | let | |
73 | val sec = ref (C_Time.castFromFixedInt 0) | |
74 | val usec = ref (C_SUSeconds.castFromFixedInt 0) | |
75 | in | |
76 | if ~1 = Prim.getTimeOfDay (sec, usec) | |
77 | then raise Fail "Time.now" | |
78 | else timeAdd(fromSeconds (C_Time.toLargeInt (! sec)), | |
79 | fromMicroseconds (C_SUSeconds.toLargeInt (! usec))) | |
80 | end | |
81 | val prev = ref (getNow ()) | |
82 | in | |
83 | fun now (): time = | |
84 | let | |
85 | val old = !prev | |
86 | val t = getNow () | |
87 | in | |
88 | case compare (old, t) of | |
89 | GREATER => old | |
90 | | _ => (prev := t; t) | |
91 | end | |
92 | end | |
93 | ||
94 | val fmt: int -> time -> string = | |
95 | fn n => (LargeReal.fmt (StringCvt.FIX (SOME n))) o toReal | |
96 | ||
97 | val toString = fmt 3 | |
98 | ||
99 | (* Adapted from the ML Kit 4.1.4; basislib/Time.sml | |
100 | * by mfluet@acm.org on 2005-11-10 based on | |
101 | * by mfluet@acm.org on 2005-8-10 based on | |
102 | * adaptations from the ML Kit 3 Version; basislib/Time.sml | |
103 | * by sweeks@research.nj.nec.com on 1999-1-3. | |
104 | *) | |
105 | fun scan getc src = | |
106 | let | |
107 | val charToDigit = StringCvt.charToDigit StringCvt.DEC | |
108 | fun pow10 0 = 1 | |
109 | | pow10 n = 10 * pow10 (n-1) | |
110 | fun mkTime sign intv fracv decs = | |
111 | let | |
112 | val nsec = | |
113 | LargeInt.div (LargeInt.+ (LargeInt.* (Int.toLarge (pow10 (10 - decs)), | |
114 | Int.toLarge fracv), | |
115 | 5), | |
116 | 10) | |
117 | val t = | |
118 | LargeInt.+ (LargeInt.* (Int.toLarge intv, ticksPerSecond), | |
119 | nsec) | |
120 | val t = if sign then t else LargeInt.~ t | |
121 | in | |
122 | T t | |
123 | end | |
124 | fun frac' sign intv fracv decs src = | |
125 | if Int.>= (decs, 7) | |
126 | then SOME (mkTime sign intv fracv decs, | |
127 | StringCvt.dropl Char.isDigit getc src) | |
128 | else case getc src of | |
129 | NONE => SOME (mkTime sign intv fracv decs, src) | |
130 | | SOME (c, rest) => | |
131 | (case charToDigit c of | |
132 | NONE => SOME (mkTime sign intv fracv decs, src) | |
133 | | SOME d => frac' sign intv (10 * fracv + d) (decs + 1) rest) | |
134 | fun frac sign intv src = | |
135 | case getc src of | |
136 | NONE => NONE | |
137 | | SOME (c, rest) => | |
138 | (case charToDigit c of | |
139 | NONE => NONE | |
140 | | SOME d => frac' sign intv d 1 rest) | |
141 | fun int' sign intv src = | |
142 | case getc src of | |
143 | NONE => SOME (mkTime sign intv 0 7, src) | |
144 | | SOME (#".", rest) => frac sign intv rest | |
145 | | SOME (c, rest) => | |
146 | (case charToDigit c of | |
147 | NONE => SOME (mkTime sign intv 0 7, src) | |
148 | | SOME d => int' sign (10 * intv + d) rest) | |
149 | fun int sign src = | |
150 | case getc src of | |
151 | NONE => NONE | |
152 | | SOME (#".", rest) => frac sign 0 rest | |
153 | | SOME (c, rest) => | |
154 | (case charToDigit c of | |
155 | NONE => NONE | |
156 | | SOME d => int' sign d rest) | |
157 | in | |
158 | case getc (StringCvt.skipWS getc src) of | |
159 | NONE => NONE | |
160 | | SOME (#"+", rest) => int true rest | |
161 | | SOME (#"~", rest) => int false rest | |
162 | | SOME (#"-", rest) => int false rest | |
163 | | SOME (#".", rest) => frac true 0 rest | |
164 | | SOME (c, rest) => | |
165 | (case charToDigit c of | |
166 | NONE => NONE | |
167 | | SOME d => int' true d rest) | |
168 | end | |
169 | handle Overflow => raise Time | |
170 | ||
171 | val fromString = StringCvt.scanString scan | |
172 | ||
173 | val op + = timeAdd | |
174 | val op - = timeSub | |
175 | ||
176 | end |