From 2d2ff1ef683dada1e084aed230a3fcf2f1348ce4 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Sun, 19 May 2019 18:48:01 -0700
Subject: [PATCH] base64: much faster base64.

---
 basis/base64/base64.factor | 135 +++++++++++++++++++++++--------------
 1 file changed, 86 insertions(+), 49 deletions(-)

diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor
index 98f549b4a2..1e46e60275 100644
--- a/basis/base64/base64.factor
+++ b/basis/base64/base64.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs byte-arrays combinators fry io io.binary
-io.encodings.binary io.streams.byte-array kernel kernel.private
-literals math namespaces sbufs sequences ;
+USING: arrays assocs byte-arrays combinators fry growable io
+io.binary io.encodings.binary io.streams.byte-array kernel
+kernel.private literals locals math math.bitwise namespaces
+sbufs sequences sequences.private ;
 IN: base64
 
 ERROR: malformed-base64 ;
@@ -28,80 +29,116 @@ CONSTANT: alphabet $[
     $[ alphabet alphabet-inverse 0 CHAR: = pick set-nth ] nth
     [ malformed-base64 ] unless* { fixnum } declare ; inline
 
-: (write-lines) ( column byte-array -- column' )
-    output-stream get dup '[
-        _ stream-write1 1 + dup 76 = [
-            drop B{ CHAR: \r CHAR: \n } _ stream-write 0
-        ] when
-    ] each ; inline
+: encode3 ( x y z -- a b c d )
+    { fixnum fixnum fixnum } declare {
+        [ [ -2 shift ch>base64 ] [ 2 bits 4 shift ] bi ]
+        [ [ -4 shift bitor ch>base64 ] [ 4 bits 2 shift ] bi ]
+        [ [ -6 shift bitor ch>base64 ] [ 6 bits ch>base64 ] bi ]
+    } spread ; inline
 
-: write-lines ( column byte-array -- column' )
-    over [ (write-lines) ] [ write ] if ; inline
+:: (stream-write-lines) ( column data stream -- column' )
+    column data over 71 > [
+        [
+            stream stream-write1 1 + dup 76 = [
+                drop 0
+                B{ CHAR: \r CHAR: \n } stream stream-write
+            ] when
+        ] each
+    ] [
+        stream stream-write 4 +
+    ] if ; inline
 
-: encode3 ( seq -- byte-array )
-    be> { -18 -12 -6 0 } '[
-        shift 0x3f bitand ch>base64
-    ] with B{ } map-as ; inline
+: stream-write-lines ( column data stream -- column' )
+    pick [ (stream-write-lines) ] [ stream-write ] if ; inline
 
-: encode-pad ( seq n -- byte-array )
-    [ 3 0 pad-tail encode3 ] [ 1 + ] bi* head-slice
-    4 CHAR: = pad-tail ; inline
+: write-lines ( column data -- column' )
+    output-stream get stream-write-lines ; inline
 
-: (encode-base64) ( stream column -- )
-    3 pick stream-read dup length {
-        { 0 [ 3drop ] }
-        { 3 [ encode3 write-lines (encode-base64) ] }
-        [ encode-pad write-lines (encode-base64) ]
-    } case ;
+:: (encode-base64) ( input output column -- )
+    4 <byte-array> :> data
+    column [ input stream-read1 dup ] [
+        input stream-read1
+        input stream-read1
+        [ [ 0 or ] bi@ encode3 ] 2keep [ 0 1 ? ] bi@ + {
+            { 0 [ ] }
+            { 1 [ drop CHAR: = ] }
+            { 2 [ 2drop CHAR: = CHAR: = ] }
+        } case data (4sequence) output stream-write-lines
+    ] while 2drop ; inline
 
 PRIVATE>
 
 : encode-base64 ( -- )
-    input-stream get f (encode-base64) ;
+    input-stream get output-stream get f (encode-base64) ;
 
 : encode-base64-lines ( -- )
-    input-stream get 0 (encode-base64) ;
+    input-stream get output-stream get 0 (encode-base64) ;
 
 <PRIVATE
 
 : read1-ignoring ( ignoring stream -- ch )
-    dup stream-read1 pick dupd member?
+    dup stream-read1 pick dupd member-eq?
     [ drop read1-ignoring ] [ 2nip ] if ; inline recursive
 
-: push-ignoring ( accum ch -- accum )
-    dup { f 0 } member-eq? [ drop ] [ suffix! ] if ; inline
-
-: read-into-ignoring ( accum n ignoring stream -- accum )
-    '[ _ _ read1-ignoring push-ignoring ] times ; inline
-
 : read-ignoring ( n ignoring stream -- accum )
-    [ [ <sbuf> ] keep ] 2dip read-into-ignoring ; inline
+    pick <sbuf> [
+        '[ _ _ read1-ignoring [ ] _ push-if ] times
+    ] keep ;
 
-: decode4 ( seq -- )
-    [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
-    [ [ CHAR: = = ] count ] bi
-    [ write ] [ head-slice* write ] if-zero ; inline
+: decode4 ( a b c d -- x y z )
+    { fixnum fixnum fixnum fixnum } declare {
+        [ base64>ch 2 shift ]
+        [ base64>ch [ -4 shift bitor ] [ 4 bits 4 shift ] bi ]
+        [ base64>ch [ -2 shift bitor ] [ 2 bits 6 shift ] bi ]
+        [ base64>ch bitor ]
+    } spread ; inline
 
-: (decode-base64) ( stream -- )
-    4 "\n\r" pick read-ignoring dup length {
-        { 0 [ 2drop ] }
-        { 4 [ decode4 (decode-base64) ] }
-        [ drop 4 CHAR: = pad-tail decode4 (decode-base64) ]
-    } case ;
+:: (decode-base64) ( input output -- )
+    3 <byte-array> :> data
+    [ B{ CHAR: \n CHAR: \r } input read1-ignoring dup ] [
+        B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
+        B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
+        B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
+        [ decode4 data (3sequence) ] 3keep
+        [ CHAR: = eq? 1 0 ? ] tri@ + +
+        [ head-slice* ] unless-zero
+        output stream-write
+    ] while drop ;
 
 PRIVATE>
 
 : decode-base64 ( -- )
-    input-stream get (decode-base64) ;
+    input-stream get output-stream get (decode-base64) ;
 
-: >base64 ( seq -- base64 )
-    binary [ binary [ encode-base64 ] with-byte-reader ] with-byte-writer ;
+<PRIVATE
+
+: ensure-encode-length ( base64 -- base64 )
+    dup length 3 /mod zero? [ 1 + ] unless 4 *
+    output-stream get expand ;
+
+: ensure-decode-length ( seq -- seq )
+    dup length 4 /mod zero? [ 1 + ] unless 3 *
+    output-stream get expand ;
+
+PRIVATE>
+
+: >base64 ( base64 -- seq )
+    binary [
+        ensure-encode-length
+        binary [ encode-base64 ] with-byte-reader
+    ] with-byte-writer ;
 
 : base64> ( base64 -- seq )
-    binary [ binary [ decode-base64 ] with-byte-reader ] with-byte-writer ;
+    binary [
+        ensure-decode-length
+        binary [ decode-base64 ] with-byte-reader
+    ] with-byte-writer ;
 
 : >base64-lines ( seq -- base64 )
-    binary [ binary [ encode-base64-lines ] with-byte-reader ] with-byte-writer ;
+    binary [
+        ensure-encode-length
+        binary [ encode-base64-lines ] with-byte-reader
+    ] with-byte-writer ;
 
 : >urlsafe-base64 ( seq -- base64 )
     >base64 H{