src/v8/tools/generate-ten-powers.scm

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