Changeset 14246 in project


Ignore:
Timestamp:
04/14/09 18:35:49 (11 years ago)
Author:
Jim Ursetto
Message:

base64: return to a fast, pure R5RS implementation

Location:
release/4/base64/trunk
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/base64/trunk/base64.meta

    r10017 r14246  
    11;;; base64.meta -*- Hen -*-
    22((egg "base64.egg")
    3  (date "2008-02-03")
    4  (synopsis "Parsing and unparsing of base-64 strings")
     3 (date "2009-04-14")
     4 (synopsis "Encoding and decoding of base64 strings")
    55 (category parsing)
    66 (license "BSD")
    77 (doc-from-wiki)
    88 (files "base64.setup" "base64.scm" "base64.html")
    9  (author "James Bailey") )
     9 (author "James Bailey, Jim Ursetto"))
    1010
  • release/4/base64/trunk/base64.scm

    r12346 r14246  
    11;; Copyright (c) 2004 James Bailey (dgym.REMOVE_THIS.bailey@gmail.com).
     2;; Copyright (c) 2009 Jim Ursetto.
    23;;
    34;; Permission is hereby granted, free of charge, to any person obtaining a
     
    2223;; and fixed division "/fx" it should be slightly portable
    2324
    24 ;; ported to CHICKEN by felix
    25 ;; reimplemented in C by zbigniew [2008]
     25;; Ported to CHICKEN by felix
     26;; Optimized for CHICKEN by Jim Ursetto.  Optimization notes:
     27;;  Local anonymous functions (bits-at) are not inlined; use define-inline.
     28;;  Toplevel tables moved to lexical scope.
     29;;  Encode algorithm moves the test for 1 or 2 remaining bytes out
     30;;  of the main loop; generates -significantly- better code under Chicken.
     31;;  Decode algorithm rewritten as state machine; invalid input is
     32;;  silently skipped.
     33;;  Compiling with -unsafe is HIGHLY recommended, and gains more benefit
     34;;  as your inner loop gets tighter.
     35;;  The optimized variants are almost on par with pure C.
     36
     37(declare
     38  (fixnum))
    2639
    2740(module base64
    28   (encode decode)
    29   (import chicken scheme)
    30 
    31 (declare (fixnum))
    32 
    33 #>
    34 static char enc_table[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
    35 
    36 static char dec_table[] = {
    37      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    38      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    39      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  62, 0,  0,  0,  63,
    40      52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 0,  0,  0,  0,  0,  0,
    41      0,  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,  10, 11, 12, 13, 14,
    42      15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 0,  0,  0,  0,  0,
    43      0,  26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
    44      41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 0,  0,  0,  0,  0,
    45      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    46      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    47      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    48      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    49      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    50      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    51      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    52      0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0
    53 };
    54 
    55 static void base64_encode(char *dst, const char *src0, int len) {
    56     int i, o, r;
    57     const unsigned char *src = (unsigned char *)src0;
    58     for (i = 0, o = 0, r = len; i < len; i+= 3, o+= 4, r -= 3) {
    59         int n = src[i] << 16;
    60         if (r > 1)
    61             n |= src[i+1] << 8;
    62         dst[o] = enc_table[(n >> 18) & 63];
    63         dst[o+1] = enc_table[(n >> 12) & 63];
    64         if (r > 1) {
    65             if (r > 2) {
    66                 n |= src[i+2];
    67                 dst[o+3] = enc_table[n & 63];
    68             }
    69             dst[o+2] = enc_table[(n >> 6) & 63];
    70         }
    71     }
    72 
    73     switch(r) {
    74       case -2: dst[o-2] = '=';
    75       case -1: dst[o-1] = '=';
    76     }
    77 }                                                               
    78 
    79 static void base64_decode(char *dst, const char *src, int len) {
    80     int i, o, r;
    81     for (i = 0, o = 0, r = len; i < len; i += 4, o += 3, r -= 3) {
    82         int n = dec_table[(int) src[i]] << 18  | dec_table[(int) src[i+1]] << 12 |
    83                 dec_table[(int) src[i+2]] << 6 | dec_table[(int) src[i+3]];
    84         dst[o] = (n >> 16) & 255;
    85         if (r > 1) {
    86             dst[o+1] = (n >> 8) & 255;
    87             if (r > 2) {
    88                 dst[o+2] = n & 255;
    89             }
    90         }
    91     }
    92 }                                                               
    93 
    94 <#
    95 
    96 (define (encode str)
    97   (define base64_encode (foreign-lambda void base64_encode pointer c-string int))
    98   (let* ((len (string-length str))
    99          (buf (##sys#make-string (* 4 (/ (+ len 2) 3))
    100                                  #f)))
    101     (base64_encode buf str len)
    102     buf))
    103 
    104 (define (decode str)
    105   (define base64_decode (foreign-lambda void base64_decode pointer c-string int))
    106   (let ((len (string-length str)))
    107     (if (zero? len)
    108       ""
    109       (let* ((result-len (- (* 3 (/ len 4))
    110                             (cond ((char=? (string-ref str (- len 2)) #\=) 2)
    111                                   ((char=? (string-ref str (- len 1)) #\=) 1)
    112                                   (else 0))))
    113              (buf (##sys#make-string result-len #f)))
    114         (base64_decode buf str len)
    115         buf))))
     41  (base64-encode base64-decode) ;; base64-decode/lax
     42 
     43  (import scheme chicken)
     44
     45(define (base64-encode str)
     46  (define-inline (bits-at idx)
     47    (char->integer (string-ref str idx)))
     48  (define-inline (b64->char n)
     49    (define enc-table
     50      '#(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
     51         #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z
     52         #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
     53         #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
     54         #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\/))
     55    (vector-ref enc-table (bitwise-and n 63)))
     56
     57  (define (encode-tail out i o r)
     58    ;; Handle last 1 or 2 bytes
     59    (case r
     60      ((0) out)
     61      ((1)
     62       (let ((n (arithmetic-shift (bits-at i) 16)))
     63         (string-set! out o (b64->char (arithmetic-shift n -18)))
     64         (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
     65         out))
     66      ((2)
     67       (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 16)
     68                             (arithmetic-shift (bits-at (+ i 1)) 8))))
     69         (string-set! out o (b64->char (arithmetic-shift n -18)))
     70         (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
     71         (string-set! out (+ o 2) (b64->char (arithmetic-shift n -6)))
     72         out))))
     73
     74  (##sys#check-string str 'base64:encode)
     75  (let* ((l (string-length str))
     76         (out (make-string (* 4 (/ (+ l 2) 3)) #\=)))
     77    (do ((i 0 (+ i 3))
     78         (o 0 (+ o 4))
     79         (r l (- r 3)))
     80        ((< r 3) (encode-tail out i o r))
     81      (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 16)
     82                            (arithmetic-shift (bits-at (+ i 1)) 8)
     83                            (bits-at (+ i 2)))))
     84        (string-set! out o       (b64->char (arithmetic-shift n -18)))
     85        (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
     86        (string-set! out (+ o 2) (b64->char (arithmetic-shift n -6)))
     87        (string-set! out (+ o 3) (b64->char n))))))
     88
     89;; (define (calc-dec-table)
     90;;    (let ((res (make-vector 256 -1)))
     91;;      (do ((i 0 (+ i 1)))
     92;;          ((>= i 64))
     93;;        (vector-set! res (char->integer (vector-ref enc-table i)) i))
     94;;      res))
     95
     96(define (base64-decode str)
     97  (define-inline (bits-at idx)
     98    (define dec-table
     99         '#(-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     100            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     101            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 62 -1 -1 -1 63
     102            52 53 54 55 56 57 58 59 60 61 -1 -1 -1 -1 -1 -1
     103            -1  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14
     104            15 16 17 18 19 20 21 22 23 24 25 -1 -1 -1 -1 -1
     105            -1 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
     106            41 42 43 44 45 46 47 48 49 50 51 -1 -1 -1 -1 -1
     107            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     108            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     109            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     110            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     111            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     112            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     113            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     114            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1))
     115    (vector-ref dec-table (char->integer (string-ref str idx))))
     116  (define-inline (int->char n)
     117    (integer->char (bitwise-and n 255)))
     118  ;; Guess upper bound for string length--assumes no invalid characters
     119  ;; encountered, and checks the last two chars for validity
     120  ;; in strings of length 4n.
     121  (define-inline (guess-out-length l)           ; assumes L > 0
     122    (let ((floored (fx* 4 (fx/ l 4))))
     123      (+ (fx* 3 (fx/ l 4))
     124         (cond ((not (= l floored)) 3)
     125               (else
     126                (if (= -1 (bits-at (- l 1)))
     127                    (if (= -1 (bits-at (- l 2))) -2 -1)
     128                    0))))))
     129
     130  (##sys#check-string str 'base64:decode)
     131  (let ((l (string-length str)))
     132    (if (= l 0)
     133        ""
     134        (let* ((outlen (guess-out-length l))  ; avoid substring if possible
     135               (out (make-string outlen))
     136               (o
     137                (let loop ((i 0) (o 0) (state 0) (n 0))
     138                  (if (>= i l)
     139                      o
     140                      (let ((b (bits-at i)))
     141                        (if (= -1 b)
     142                            (loop (+ i 1) o state n)
     143                            (case state
     144                              ((0) (loop (+ i 1) o 1 b))
     145                              ((1) (let ((n (bitwise-ior b (arithmetic-shift n 6))))
     146                                     (string-set! out o (int->char (arithmetic-shift n -4)))
     147                                     (loop (+ i 1) (+ o 1) 2 n)))
     148                              ((2) (let ((n (bitwise-ior b (arithmetic-shift n 6))))
     149                                     (string-set! out o (int->char (arithmetic-shift n -2)))
     150                                     (loop (+ i 1) (+ o 1) 3 n)))
     151                              (else (let ((n (bitwise-ior b (arithmetic-shift n 6))))
     152                                      (string-set! out o (int->char n))
     153                                      (loop (+ i 1) (+ o 1) 0 0))))))))))
     154          ;; Pull this out of the loop; otherwise the code is pessimized.
     155          (if (= outlen o)
     156              out
     157              (substring out 0 o))))))
     158
     159;; Lax decode which includes invalid characters in input.
     160;; Around 2x faster.  Not exported.
     161(define (base64-decode/lax str)
     162  (define-inline (bits-at idx)
     163    (define dec-table
     164      '#(0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
     165         0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
     166         0  0  0  0  0  0  0  0  0  0  0  62 0  0  0  63
     167         52 53 54 55 56 57 58 59 60 61 0  0  0  0  0  0
     168         0  0  1  2  3  4  5  6  7  8  9  10 11 12 13 14
     169         15 16 17 18 19 20 21 22 23 24 25 0  0  0  0  0
     170         0  26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
     171         41 42 43 44 45 46 47 48 49 50 51 0  0  0  0  0
     172         0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
     173         0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
     174         0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
     175         0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
     176         0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
     177         0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
     178         0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
     179         0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0))
     180    (vector-ref dec-table (char->integer (string-ref str idx))))
     181  (define-inline (int->char n)
     182    (integer->char (bitwise-and n 255)))
     183  (define (decode-tail out i o r)
     184    (case r
     185      ((0) out)
     186      ((1) (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 18)
     187                                 (arithmetic-shift (bits-at (+ i 1)) 12))))
     188             (string-set! out o       (int->char (arithmetic-shift n -16)))
     189             out))
     190      ((2) (let ((n (bitwise-ior
     191                     (bitwise-ior (arithmetic-shift (bits-at i) 18)
     192                                  (arithmetic-shift (bits-at (+ i 1)) 12))
     193                     (arithmetic-shift (bits-at (+ i 2)) 6))))
     194             (string-set! out o       (int->char (arithmetic-shift n -16)))
     195             (string-set! out (+ o 1) (int->char (arithmetic-shift n -8)))
     196             out))))
     197
     198  (##sys#check-string str 'base64:decode)
     199  (let ((l (string-length str)))
     200    (cond
     201     ((= l 0) "")
     202     ((not (= l (fx* 4 (fx/ l 4))))
     203      (error 'base64:decode "string length must be a multiple of 4" l))
     204     (else
     205      (let* ((outlen (- (* 3 (fx/ l 4))
     206                        (cond
     207                         ((char=? (string-ref str (- l 2)) #\=) 2)
     208                         ((char=? (string-ref str (- l 1)) #\=) 1)
     209                         (else 0))))
     210             (out (make-string outlen)))
     211        (do ((i 0 (+ i 4))
     212             (o 0 (+ o 3))
     213             (r outlen (- r 3)))
     214            ((< r 3) (decode-tail out i o r))
     215          ;; take in 4 bytes, making a 24 bit integer
     216          (let ((n (bitwise-ior
     217                    (bitwise-ior (arithmetic-shift (bits-at i) 18)
     218                                 (arithmetic-shift (bits-at (+ i 1)) 12))
     219                    (bitwise-ior (arithmetic-shift (bits-at (+ i 2)) 6)
     220                                 (bits-at (+ i 3))))))
     221            ;; now write out 3 bytes at a time
     222            (string-set! out o       (int->char (arithmetic-shift n -16)))
     223            (string-set! out (+ o 1) (int->char (arithmetic-shift n -8)))
     224            (string-set! out (+ o 2) (int->char n)))))))))
     225
    116226)
  • release/4/base64/trunk/base64.setup

    r12346 r14246  
    1 (compile -s -O2 -d1 base64.scm -j base64)
    2 (compile -s -O2 -d1 base64.import.scm)
     1(compile -s -O2 -d0 -u base64.scm -j base64)
     2(compile -s -O2 -d0 base64.import.scm)
    33
    44(install-extension
    55 'base64
    66 '("base64.import.so" "base64.so")
    7  '((version 2.2)
     7 '((version 3.0)
    88   (documentation "base64.html")))
Note: See TracChangeset for help on using the changeset viewer.