generate-ten-powers.scm 10 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286
  1. ;; Copyright 2010 the V8 project authors. All rights reserved.
  2. ;; Redistribution and use in source and binary forms, with or without
  3. ;; modification, are permitted provided that the following conditions are
  4. ;; met:
  5. ;;
  6. ;; * Redistributions of source code must retain the above copyright
  7. ;; notice, this list of conditions and the following disclaimer.
  8. ;; * Redistributions in binary form must reproduce the above
  9. ;; copyright notice, this list of conditions and the following
  10. ;; disclaimer in the documentation and/or other materials provided
  11. ;; with the distribution.
  12. ;; * Neither the name of Google Inc. nor the names of its
  13. ;; contributors may be used to endorse or promote products derived
  14. ;; from this software without specific prior written permission.
  15. ;;
  16. ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  17. ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  18. ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  19. ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  20. ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  21. ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  22. ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  23. ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  24. ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  25. ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  26. ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27. ;; This is a Scheme script for the Bigloo compiler. Bigloo must be compiled with
  28. ;; support for bignums. The compilation of the script can be done as follows:
  29. ;; bigloo -static-bigloo -o generate-ten-powers generate-ten-powers.scm
  30. ;;
  31. ;; Generate approximations of 10^k.
  32. (module gen-ten-powers
  33. (static (class Cached-Fast
  34. v::bignum
  35. e::bint
  36. exact?::bool))
  37. (main my-main))
  38. ;;----------------bignum shifts -----------------------------------------------
  39. (define (bit-lshbx::bignum x::bignum by::bint)
  40. (if (<fx by 0)
  41. #z0
  42. (*bx x (exptbx #z2 (fixnum->bignum by)))))
  43. (define (bit-rshbx::bignum x::bignum by::bint)
  44. (if (<fx by 0)
  45. #z0
  46. (/bx x (exptbx #z2 (fixnum->bignum by)))))
  47. ;;----------------the actual power generation -------------------------------
  48. ;; e should be an indication. it might be too small.
  49. (define (round-n-cut n e nb-bits)
  50. (define max-container (- (bit-lshbx #z1 nb-bits) 1))
  51. (define (round n)
  52. (case *round*
  53. ((down) n)
  54. ((up)
  55. (+bx n
  56. ;; with the -1 it will only round up if the cut off part is
  57. ;; non-zero
  58. (-bx (bit-lshbx #z1
  59. (-fx (+fx e nb-bits) 1))
  60. #z1)))
  61. ((round)
  62. (+bx n
  63. (bit-lshbx #z1
  64. (-fx (+fx e nb-bits) 2))))))
  65. (let* ((shift (-fx (+fx e nb-bits) 1))
  66. (cut (bit-rshbx (round n) shift))
  67. (exact? (=bx n (bit-lshbx cut shift))))
  68. (if (<=bx cut max-container)
  69. (values cut e exact?)
  70. (round-n-cut n (+fx e 1) nb-bits))))
  71. (define (rounded-/bx x y)
  72. (case *round*
  73. ((down) (/bx x y))
  74. ((up) (+bx (/bx x y) #z1))
  75. ((round) (let ((tmp (/bx (*bx #z2 x) y)))
  76. (if (zerobx? (remainderbx tmp #z2))
  77. (/bx tmp #z2)
  78. (+bx (/bx tmp #z2) #z1))))))
  79. (define (generate-powers from to mantissa-size)
  80. (let* ((nb-bits mantissa-size)
  81. (offset (- from))
  82. (nb-elements (+ (- from) to 1))
  83. (vec (make-vector nb-elements))
  84. (max-container (- (bit-lshbx #z1 nb-bits) 1)))
  85. ;; the negative ones. 10^-1, 10^-2, etc.
  86. ;; We already know, that we can't be exact, so exact? will always be #f.
  87. ;; Basically we will have a ten^i that we will *10 at each iteration. We
  88. ;; want to create the matissa of 1/ten^i. However the mantissa must be
  89. ;; normalized (start with a 1). -> we have to shift the number.
  90. ;; We shift by multiplying with two^e. -> We encode two^e*(1/ten^i) ==
  91. ;; two^e/ten^i.
  92. (let loop ((i 1)
  93. (ten^i #z10)
  94. (two^e #z1)
  95. (e 0))
  96. (unless (< (- i) from)
  97. (if (>bx (/bx (*bx #z2 two^e) ten^i) max-container)
  98. ;; another shift would make the number too big. We are
  99. ;; hence normalized now.
  100. (begin
  101. (vector-set! vec (-fx offset i)
  102. (instantiate::Cached-Fast
  103. (v (rounded-/bx two^e ten^i))
  104. (e (negfx e))
  105. (exact? #f)))
  106. (loop (+fx i 1) (*bx ten^i #z10) two^e e))
  107. (loop i ten^i (bit-lshbx two^e 1) (+fx e 1)))))
  108. ;; the positive ones 10^0, 10^1, etc.
  109. ;; start with 1.0. mantissa: 10...0 (1 followed by nb-bits-1 bits)
  110. ;; -> e = -(nb-bits-1)
  111. ;; exact? is true when the container can still hold the complete 10^i
  112. (let loop ((i 0)
  113. (n (bit-lshbx #z1 (-fx nb-bits 1)))
  114. (e (-fx 1 nb-bits)))
  115. (when (<= i to)
  116. (receive (cut e exact?)
  117. (round-n-cut n e nb-bits)
  118. (vector-set! vec (+fx i offset)
  119. (instantiate::Cached-Fast
  120. (v cut)
  121. (e e)
  122. (exact? exact?)))
  123. (loop (+fx i 1) (*bx n #z10) e))))
  124. vec))
  125. (define (print-c powers from to struct-type
  126. cache-name max-distance-name offset-name macro64)
  127. (define (display-power power k)
  128. (with-access::Cached-Fast power (v e exact?)
  129. (let ((tmp-p (open-output-string)))
  130. ;; really hackish way of getting the digits
  131. (display (format "~x" v) tmp-p)
  132. (let ((str (close-output-port tmp-p)))
  133. (printf " {~a(0x~a, ~a), ~a, ~a},\n"
  134. macro64
  135. (substring str 0 8)
  136. (substring str 8 16)
  137. e
  138. k)))))
  139. (define (print-powers-reduced n)
  140. (print "static const " struct-type " " cache-name
  141. "(" n ")"
  142. "[] = {")
  143. (let loop ((i 0)
  144. (nb-elements 0)
  145. (last-e 0)
  146. (max-distance 0))
  147. (cond
  148. ((>= i (vector-length powers))
  149. (print " };")
  150. (print "static const int " max-distance-name "(" n ") = "
  151. max-distance ";")
  152. (print "// nb elements (" n "): " nb-elements))
  153. (else
  154. (let* ((power (vector-ref powers i))
  155. (e (Cached-Fast-e power)))
  156. (display-power power (+ i from))
  157. (loop (+ i n)
  158. (+ nb-elements 1)
  159. e
  160. (cond
  161. ((=fx i 0) max-distance)
  162. ((> (- e last-e) max-distance) (- e last-e))
  163. (else max-distance))))))))
  164. (print "// Copyright 2010 the V8 project authors. All rights reserved.")
  165. (print "// ------------ GENERATED FILE ----------------")
  166. (print "// command used:")
  167. (print "// "
  168. (apply string-append (map (lambda (str)
  169. (string-append " " str))
  170. *main-args*))
  171. " // NOLINT")
  172. (print)
  173. (print
  174. "// This file is intended to be included inside another .h or .cc files\n"
  175. "// with the following defines set:\n"
  176. "// GRISU_CACHE_STRUCT: should expand to the name of a struct that will\n"
  177. "// hold the cached powers of ten. Each entry will hold a 64-bit\n"
  178. "// significand, a 16-bit signed binary exponent, and a 16-bit\n"
  179. "// signed decimal exponent. Each entry will be constructed as follows:\n"
  180. "// { significand, binary_exponent, decimal_exponent }.\n"
  181. "// GRISU_CACHE_NAME(i): generates the name for the different caches.\n"
  182. "// The parameter i will be a number in the range 1-20. A cache will\n"
  183. "// hold every i'th element of a full cache. GRISU_CACHE_NAME(1) will\n"
  184. "// thus hold all elements. The higher i the fewer elements it has.\n"
  185. "// Ideally the user should only reference one cache and let the\n"
  186. "// compiler remove the unused ones.\n"
  187. "// GRISU_CACHE_MAX_DISTANCE(i): generates the name for the maximum\n"
  188. "// binary exponent distance between all elements of a given cache.\n"
  189. "// GRISU_CACHE_OFFSET: is used as variable name for the decimal\n"
  190. "// exponent offset. It is equal to -cache[0].decimal_exponent.\n"
  191. "// GRISU_UINT64_C: used to construct 64-bit values in a platform\n"
  192. "// independent way. In order to encode 0x123456789ABCDEF0 the macro\n"
  193. "// will be invoked as follows: GRISU_UINT64_C(0x12345678,9ABCDEF0).\n")
  194. (print)
  195. (print-powers-reduced 1)
  196. (print-powers-reduced 2)
  197. (print-powers-reduced 3)
  198. (print-powers-reduced 4)
  199. (print-powers-reduced 5)
  200. (print-powers-reduced 6)
  201. (print-powers-reduced 7)
  202. (print-powers-reduced 8)
  203. (print-powers-reduced 9)
  204. (print-powers-reduced 10)
  205. (print-powers-reduced 11)
  206. (print-powers-reduced 12)
  207. (print-powers-reduced 13)
  208. (print-powers-reduced 14)
  209. (print-powers-reduced 15)
  210. (print-powers-reduced 16)
  211. (print-powers-reduced 17)
  212. (print-powers-reduced 18)
  213. (print-powers-reduced 19)
  214. (print-powers-reduced 20)
  215. (print "static const int GRISU_CACHE_OFFSET = " (- from) ";"))
  216. ;;----------------main --------------------------------------------------------
  217. (define *main-args* #f)
  218. (define *mantissa-size* #f)
  219. (define *dest* #f)
  220. (define *round* #f)
  221. (define *from* #f)
  222. (define *to* #f)
  223. (define (my-main args)
  224. (set! *main-args* args)
  225. (args-parse (cdr args)
  226. (section "Help")
  227. (("?") (args-parse-usage #f))
  228. ((("-h" "--help") (help "?, -h, --help" "This help message"))
  229. (args-parse-usage #f))
  230. (section "Misc")
  231. (("-o" ?file (help "The output file"))
  232. (set! *dest* file))
  233. (("--mantissa-size" ?size (help "Container-size in bits"))
  234. (set! *mantissa-size* (string->number size)))
  235. (("--round" ?direction (help "Round bignums (down, round or up)"))
  236. (set! *round* (string->symbol direction)))
  237. (("--from" ?from (help "start at 10^from"))
  238. (set! *from* (string->number from)))
  239. (("--to" ?to (help "go up to 10^to"))
  240. (set! *to* (string->number to)))
  241. (else
  242. (print "Illegal argument `" else "'. Usage:")
  243. (args-parse-usage #f)))
  244. (when (not *from*)
  245. (error "generate-ten-powers"
  246. "Missing from"
  247. #f))
  248. (when (not *to*)
  249. (error "generate-ten-powers"
  250. "Missing to"
  251. #f))
  252. (when (not *mantissa-size*)
  253. (error "generate-ten-powers"
  254. "Missing mantissa size"
  255. #f))
  256. (when (not (memv *round* '(up down round)))
  257. (error "generate-ten-powers"
  258. "Missing round-method"
  259. *round*))
  260. (let ((dividers (generate-powers *from* *to* *mantissa-size*))
  261. (p (if (not *dest*)
  262. (current-output-port)
  263. (open-output-file *dest*))))
  264. (unwind-protect
  265. (with-output-to-port p
  266. (lambda ()
  267. (print-c dividers *from* *to*
  268. "GRISU_CACHE_STRUCT" "GRISU_CACHE_NAME"
  269. "GRISU_CACHE_MAX_DISTANCE" "GRISU_CACHE_OFFSET"
  270. "GRISU_UINT64_C"
  271. )))
  272. (if *dest*
  273. (close-output-port p)))))