source code
;; The Computer Language Benchmarks Game
;; https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
;;
;; contributed by Alexey Voznyuk
;;;
;;; modified by Marko Kocic
;;; * add optimization declarations
(defpackage #:k-nucleotide
(:use :cl))
(in-package :k-nucleotide)
(declaim (optimize (speed 3)(safety 0)(space 0)(debug 0)))
(defmacro with-packed-sequences ((&rest sequences) &body body)
(loop :for (bind update length) :in sequences
:collect `(,bind 0) :into binds
:collect `(type (integer 0 ,(1- (expt 4 length))) ,bind) :into decls
:collect `(,update (char) `(setf ,',bind
(logior (ash ,',bind -2)
(ash (logand (char-code ,char) #x6)
,',(1- (* (1- length) 2)))))) :into updates
:finally (return `(let (,@binds) (declare ,@decls) (macrolet (,@updates) ,@body)))))
(defmacro pack-sequence (sequence)
`(with-packed-sequences ((bind update ,(length sequence)))
(loop :for char :across ,sequence
:do (update char))
bind))
(defun unpack-sequence (length packed-seq)
(declare (optimize (speed 3) (safety 0) (debug 0))
(type fixnum length packed-seq))
(with-output-to-string (seq-out)
(loop :repeat length
:do (write-char (ecase (logand packed-seq #x3)
(0 #\A) (1 #\C) (2 #\T) (3 #\G))
seq-out)
:do (setf packed-seq (ash packed-seq -2)))))
(defmacro with-packed-caches-fill ((hash-access) &rest updaters)
`(progn ,@(loop
:for tick :from 1 :to (apply #'max (mapcar #'third updaters))
:collect `(with-current-char (char :skip-newline t)
,@(loop :for (bind update length) :in updaters
:collect `(,update char)
:when (>= tick length)
:collect `(,hash-access ,length ,bind))))))
(defmacro with-reading-stream ((stream &key (block-size 8192)) &body body)
`(block outer-tag
(let ((advance (let ((buffer (make-array ,block-size :element-type 'standard-char :initial-element #\Newline))
(index 0)
(amount 0))
(declare (type fixnum index amount))
(lambda ()
(prog2 (when (>= index amount)
(setf amount (read-sequence buffer ,stream)
index 0)
(when (zerop amount)
(return-from outer-tag nil)))
(elt buffer index)
(incf index))))))
(flet ((get-char () (funcall advance)))
(macrolet ((with-current-char ((char &key skip-newline) &body body)
`(let ((,char ,(if skip-newline
`(loop :for ,char = (get-char) :while (char= ,char #\Newline)
:finally (return ,char))
`(get-char))))
(declare (type standard-char ,char))
,@body)))
,@body)))))
(defmacro skip-buffer-to (&rest patterns)
`(progn ,@(loop :for pattern :in patterns
:collect `(loop :until (and ,@(loop :for char :across (string pattern)
:collect `(with-current-char (char)
(char= char ,char))))))))
(defmacro with-dna-analyzed ((stream hash-access &key (block-size 8192)) &rest sequence-lengths)
(loop :for length :in sequence-lengths
:collect (gensym) :into binds
:collect (gensym) :into updaters
:finally (let ((desc (mapcar #'list binds updaters sequence-lengths)))
(return `(with-packed-sequences (,@desc)
(with-reading-stream (,stream :block-size ,block-size)
(skip-buffer-to ">THREE" #\Newline)
(with-packed-caches-fill (,hash-access)
,@desc)
(loop (with-current-char (char :skip-newline t)
,@(loop
:for update :in updaters
:for bind :in binds
:for length :in sequence-lengths
:collect `(,update char)
:collect `(,hash-access ,length ,bind))))))))))
(defun seq= (seq-a seq-b)
(declare (optimize (speed 3) (safety 0) (debug 0)) (type fixnum seq-a seq-b))
(= seq-a seq-b))
(defun seq-hash (seq)
(declare (optimize (speed 3) (safety 0) (debug 0)) (type fixnum seq))
seq)
(sb-ext:define-hash-table-test seq= seq-hash)
(defmacro with-smart-dna-hash ((hash-access hash-loop &key (vector-threshold 1048576)) (&rest sequence-lengths) &body body)
(loop :for length :in sequence-lengths
:for bind = (gensym)
:for area = (expt 4 length)
:for vec-p = (<= area vector-threshold)
:collect `(,bind ,(if vec-p
`(make-array ,area :element-type 'fixnum :initial-element 0)
`(make-hash-table :test ',(if (< area most-positive-fixnum) 'seq= 'eql)
:rehash-size ,(expt 2 (1- length))
:rehash-threshold 0.7))) :into binds
:collect `(,length ,(if vec-p ``(elt ,',bind ,key) ``(the fixnum (gethash ,key ,',bind 0)))) :into accesses
:collect `(,length ,(if vec-p
``(loop :for i :from 0 :below ,',(expt 4 length)
:for ,value = (elt ,',bind i)
:for ,key = (unpack-sequence ,',length i)
:unless (zerop ,value)
,@loop-keywords)
``(loop :for packed-key :being :the :hash-keys :in ,',bind
:for ,key = (unpack-sequence ,',length packed-key)
:for ,value = (,',hash-access ,',length packed-key)
,@loop-keywords))) :into loops
:finally (return `(let (,@binds)
(macrolet ((,hash-access (seq-length key) (ecase seq-length ,@accesses))
(,hash-loop ((seq-length key value) &rest loop-keywords) (ecase seq-length ,@loops)))
,@body)))))
(defmacro with-percentage ((hash-loop &rest seq-descriptions) &body body)
(if (null seq-descriptions)
`(progn ,@body)
(destructuring-bind (seq-bind seq-length)
(car seq-descriptions)
`(let ((,seq-bind (,hash-loop (,seq-length k v)
:summing v :into total :of-type fixnum
:and :collect k :into seqs
:and :collect v :into counts
:finally (return (mapcar #'list
seqs
(mapcar (lambda (count)
(declare (type fixnum count))
(/ (* count 100.0) total))
counts))))))
(with-percentage (,hash-loop ,@(cdr seq-descriptions)) ,@body)))))
(defmacro obtain-seq-count (hash-access seq)
`(list (,hash-access ,(length seq) (pack-sequence ,seq)) #\Tab ,seq))
(defun perform-work (stream)
(declare (optimize (speed 3) (safety 0) (debug 0)))
(with-smart-dna-hash (hash-access hash-loop :vector-threshold 16777216)
(1 2 3 4 6 12 18)
(macrolet ((incf-hash-element (seq-length key)
`(incf (hash-access ,seq-length ,key))))
(with-dna-analyzed (stream incf-hash-element :block-size 655350) 1 2 3 4 6 12 18)
(with-percentage (hash-loop (seqs-1 1) (seqs-2 2))
(values (list seqs-1 seqs-2)
(list (obtain-seq-count hash-access "GGT")
(obtain-seq-count hash-access "GGTA")
(obtain-seq-count hash-access "GGTATT")
(obtain-seq-count hash-access "GGTATTTTAATT")
(obtain-seq-count hash-access "GGTATTTTAATTTATAGT")))))))
(defun print-results (seq-freqs seq-counts)
(labels ((compare (a b)
(cond ((> (second a) (second b)) t)
((< (second a) (second b)) nil)
(t (string< (first a) (first b)))))
(print-freq (freq)
(format t "~{~{~a ~3$~}~%~}~%" (sort freq #'compare))))
(mapc #'print-freq seq-freqs)
(format t "~{~{~a~c~a~}~%~}" seq-counts)))
(defun main ()
(with-open-file (input-s #p"/dev/stdin" :external-format :iso-8859-1)
(multiple-value-bind (freqs counts)
(perform-work input-s)
(print-results freqs counts))))
(in-package :cl-user)
(defun main ()
(k-nucleotide::main))
notes, command-line, and program output
NOTES:
64-bit Ubuntu quad core
SBCL 2.4.2
Mon, 04 Mar 2024 23:05:41 GMT
MAKE:
cp: 'knucleotide.sbcl-5.sbcl' and './knucleotide.sbcl-5.sbcl' are the same file
SBCL built with: /opt/src/sbcl-2.4.2/bin/sbcl --userinit /dev/null --batch --eval '(load "knucleotide.sbcl-5.sbcl_compile")'
### START knucleotide.sbcl-5.sbcl_compile
(handler-bind ((sb-ext:defconstant-uneql (lambda (c) (abort c)))) (require :sb-concurrency) (load (compile-file "knucleotide.sbcl-5.sbcl" ))) (save-lisp-and-die "sbcl.core" :purify t)
### END knucleotide.sbcl-5.sbcl_compile
; compiling file "/home/dunham/all-benchmarksgame/benchmarksgame_i53330/knucleotide/tmp/knucleotide.sbcl-5.sbcl" (written 26 APR 2018 12:48:18 PM):
; file: /home/dunham/all-benchmarksgame/benchmarksgame_i53330/knucleotide/tmp/knucleotide.sbcl-5.sbcl
; in: DEFMACRO WITH-PACKED-SEQUENCES
; (EXPT 4 LENGTH)
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a INTEGER.
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a UNSIGNED-BYTE.
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a INTEGER.
; `(,K-NUCLEOTIDE::UPDATE (CHAR)
; `(SETF ,',K-NUCLEOTIDE::BIND
; (LOGIOR (ASH ,',K-NUCLEOTIDE::BIND -2) (ASH # ,',#))))
;
; note: unable to
; optimize
; due to type uncertainty:
; The first argument is a NUMBER, not a SINGLE-FLOAT.
;
; note: unable to
; optimize
; due to type uncertainty:
; The first argument is a NUMBER, not a DOUBLE-FLOAT.
;
; note: unable to
; convert x*2^k to shift
; due to type uncertainty:
; The first argument is a NUMBER, not a INTEGER.
;
; note: unable to
; associate */(* /) of constants
; due to type uncertainty:
; The first argument is a NUMBER, not a RATIONAL.
; (1- (EXPT 4 LENGTH))
;
; note: forced to do GENERIC-- (cost 10)
; unable to do inline fixnum arithmetic (cost 1) because:
; The first argument is a NUMBER, not a FIXNUM.
; The result is a (VALUES NUMBER &OPTIONAL), not a (VALUES FIXNUM &OPTIONAL).
; unable to do inline fixnum arithmetic (cost 2) because:
; The first argument is a NUMBER, not a FIXNUM.
; The result is a (VALUES NUMBER &OPTIONAL), not a (VALUES FIXNUM &OPTIONAL).
; etc.
; `(,K-NUCLEOTIDE::UPDATE (CHAR)
; `(SETF ,',K-NUCLEOTIDE::BIND
; (LOGIOR (ASH ,',K-NUCLEOTIDE::BIND -2) (ASH # ,',#))))
;
; note: forced to do GENERIC-- (cost 10)
; unable to do inline fixnum arithmetic (cost 1) because:
; The first argument is a NUMBER, not a FIXNUM.
; The result is a (VALUES NUMBER &OPTIONAL), not a (VALUES FIXNUM &OPTIONAL).
; unable to do inline fixnum arithmetic (cost 2) because:
; The first argument is a NUMBER, not a FIXNUM.
; The result is a (VALUES NUMBER &OPTIONAL), not a (VALUES FIXNUM &OPTIONAL).
; etc.
;
; note: forced to do GENERIC-* (cost 30)
; unable to do inline fixnum arithmetic (cost 1) because:
; The first argument is a NUMBER, not a FIXNUM.
; The result is a (VALUES NUMBER &OPTIONAL), not a (VALUES FIXNUM &OPTIONAL).
; unable to do inline fixnum arithmetic (cost 2) because:
; The first argument is a NUMBER, not a FIXNUM.
; The result is a (VALUES NUMBER &OPTIONAL), not a (VALUES FIXNUM &OPTIONAL).
; etc.
;
; note: forced to do GENERIC-- (cost 10)
; unable to do inline fixnum arithmetic (cost 1) because:
; The first argument is a NUMBER, not a FIXNUM.
; The result is a (VALUES NUMBER &OPTIONAL), not a (VALUES FIXNUM &OPTIONAL).
; unable to do inline fixnum arithmetic (cost 2) because:
; The first argument is a NUMBER, not a FIXNUM.
; The result is a (VALUES NUMBER &OPTIONAL), not a (VALUES FIXNUM &OPTIONAL).
; etc.
; in: DEFMACRO PACK-SEQUENCE
; (LENGTH SEQUENCE)
;
; note: unable to
; optimize
; due to type uncertainty:
; The first argument is a SEQUENCE, not a VECTOR.
; in: DEFMACRO WITH-PACKED-CACHES-FILL
; (LOOP :FOR K-NUCLEOTIDE::TICK :FROM 1 :TO (APPLY #'MAX
; (MAPCAR #'THIRD
; K-NUCLEOTIDE::UPDATERS))
; :COLLECT `(K-NUCLEOTIDE::WITH-CURRENT-CHAR (CHAR :SKIP-NEWLINE T)
; ,@(LOOP :FOR (K-NUCLEOTIDE::BIND K-NUCLEOTIDE::UPDATE
; LENGTH) :IN K-NUCLEOTIDE::UPDATERS
; :COLLECT `(,K-NUCLEOTIDE::UPDATE CHAR)
; :WHEN (>= K-NUCLEOTIDE::TICK LENGTH)
; :COLLECT `(,K-NUCLEOTIDE::HASH-ACCESS ,LENGTH
; ,K-NUCLEOTIDE::BIND))))
; --> LET SB-LOOP::WITH-LOOP-LIST-COLLECTION-HEAD LET* TAGBODY WHEN IF
; ==>
; (> K-NUCLEOTIDE::TICK #:LOOP-LIMIT-2)
;
; note: forced to do GENERIC-> (cost 10)
; unable to do inline fixnum comparison (cost 4) because:
; The first argument is a (INTEGER 1), not a FIXNUM.
; The second argument is a REAL, not a FIXNUM.
; --> LET SB-LOOP::WITH-LOOP-LIST-COLLECTION-HEAD LET* TAGBODY
; --> SB-LOOP::LOOP-DESETQ SETQ THE 1+
; ==>
; 1
;
; note: forced to do GENERIC-+ (cost 10)
; unable to do inline fixnum arithmetic (cost 1) because:
; The first argument is a (INTEGER 1), not a FIXNUM.
; The result is a (VALUES (INTEGER 2) &OPTIONAL), not a (VALUES FIXNUM
; &OPTIONAL).
; unable to do inline fixnum arithmetic (cost 2) because:
; The first argument is a (INTEGER 1), not a FIXNUM.
; The result is a (VALUES (INTEGER 2) &OPTIONAL), not a (VALUES FIXNUM
; &OPTIONAL).
; etc.
; in: DEFMACRO SKIP-BUFFER-TO
; (STRING K-NUCLEOTIDE::PATTERN)
;
; note: unable to
; optimize
; due to type uncertainty:
; The first argument is a (OR STRING SYMBOL CHARACTER), not a SYMBOL.
;
; note: unable to
; optimize
; due to type uncertainty:
; The first argument is a (OR STRING SYMBOL CHARACTER), not a STRING.
; (LOOP :FOR CHAR :ACROSS (STRING K-NUCLEOTIDE::PATTERN)
; :COLLECT `(K-NUCLEOTIDE::WITH-CURRENT-CHAR (CHAR) (CHAR= CHAR ,CHAR)))
;
; note: unable to
; optimize
; due to type uncertainty:
; The first argument is a STRING, not a SIMPLE-STRING.
;
; note: unable to
; avoid runtime dispatch on array element type
; due to type uncertainty:
; The first argument is a STRING, not a SIMPLE-ARRAY.
; in: DEFMACRO WITH-SMART-DNA-HASH
; (EXPT 4 LENGTH)
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a INTEGER.
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a UNSIGNED-BYTE.
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a INTEGER.
; (<= K-NUCLEOTIDE::AREA K-NUCLEOTIDE::VECTOR-THRESHOLD)
;
; note: unable to
; open-code FLOAT to RATIONAL comparison
; due to type uncertainty:
; The first argument is a REAL, not a SINGLE-FLOAT.
; The second argument is a REAL, not a RATIONAL.
;
; note: unable to
; open-code FLOAT to RATIONAL comparison
; due to type uncertainty:
; The first argument is a REAL, not a DOUBLE-FLOAT.
; The second argument is a REAL, not a RATIONAL.
; `(MAKE-HASH-TABLE :TEST
; ',(IF (< K-NUCLEOTIDE::AREA MOST-POSITIVE-FIXNUM)
; 'K-NUCLEOTIDE::SEQ=
; 'EQL)
; :REHASH-SIZE ,(EXPT 2 (1- LENGTH)) :REHASH-THRESHOLD 0.7)
;
; note: unable to
; open-code FLOAT to RATIONAL comparison
; due to type uncertainty:
; The first argument is a REAL, not a SINGLE-FLOAT.
;
; note: unable to
; open-code FLOAT to RATIONAL comparison
; due to type uncertainty:
; The first argument is a REAL, not a DOUBLE-FLOAT.
; (EXPT 2 (1- LENGTH))
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a INTEGER.
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a UNSIGNED-BYTE.
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a INTEGER.
; ``(LOOP :FOR K-NUCLEOTIDE::I :FROM 0 :BELOW ,',(EXPT 4 LENGTH)
; :FOR ,K-NUCLEOTIDE::VALUE = (ELT ,',K-NUCLEOTIDE::BIND
; K-NUCLEOTIDE::I)
; :FOR ...)
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a INTEGER.
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a UNSIGNED-BYTE.
;
; note: unable to
; optimize
; due to type uncertainty:
; The second argument is a NUMBER, not a INTEGER.
; (<= K-NUCLEOTIDE::AREA K-NUCLEOTIDE::VECTOR-THRESHOLD)
;
; note: forced to do full call
; unable to do inline float comparison (cost 3) because:
; The first argument is a REAL, not a SINGLE-FLOAT.
; The second argument is a REAL, not a SINGLE-FLOAT.
; unable to do inline float comparison (cost 3) because:
; The first argument is a REAL, not a DOUBLE-FLOAT.
; The second argument is a REAL, not a DOUBLE-FLOAT.
; `(MAKE-HASH-TABLE :TEST
; ',(IF (< K-NUCLEOTIDE::AREA MOST-POSITIVE-FIXNUM)
; 'K-NUCLEOTIDE::SEQ=
; 'EQL)
; :REHASH-SIZE ,(EXPT 2 (1- LENGTH)) :REHASH-THRESHOLD 0.7)
;
; note: forced to do GENERIC-< (cost 10)
; unable to do inline fixnum comparison (cost 3) because:
; The first argument is a REAL, not a FIXNUM.
; unable to do inline fixnum comparison (cost 4) because:
; The first argument is a REAL, not a FIXNUM.
; etc.
; (1- LENGTH)
;
; note: forced to do GENERIC-- (cost 10)
; unable to do inline fixnum arithmetic (cost 1) because:
; The first argument is a NUMBER, not a FIXNUM.
; The result is a (VALUES NUMBER &OPTIONAL), not a (VALUES FIXNUM &OPTIONAL).
; unable to do inline fixnum arithmetic (cost 2) because:
; The first argument is a NUMBER, not a FIXNUM.
; The result is a (VALUES NUMBER &OPTIONAL), not a (VALUES FIXNUM &OPTIONAL).
; etc.
; in: DEFMACRO OBTAIN-SEQ-COUNT
; (LENGTH K-NUCLEOTIDE::SEQ)
;
; note: unable to
; optimize
; due to type uncertainty:
; The first argument is a SEQUENCE, not a VECTOR.
; in: DEFUN PRINT-RESULTS
; (> (SECOND K-NUCLEOTIDE::A) (SECOND K-NUCLEOTIDE::B))
;
; note: unable to
; open-code FLOAT to RATIONAL comparison
; due to type uncertainty:
; The first argument is a REAL, not a SINGLE-FLOAT.
; The second argument is a REAL, not a RATIONAL.
;
; note: unable to
; open-code FLOAT to RATIONAL comparison
; due to type uncertainty:
; The first argument is a REAL, not a DOUBLE-FLOAT.
; The second argument is a REAL, not a RATIONAL.
; (< (SECOND K-NUCLEOTIDE::A) (SECOND K-NUCLEOTIDE::B))
;
; note: unable to
; open-code FLOAT to RATIONAL comparison
; due to type uncertainty:
; The first argument is a REAL, not a SINGLE-FLOAT.
; The second argument is a REAL, not a RATIONAL.
;
; note: unable to
; open-code FLOAT to RATIONAL comparison
; due to type uncertainty:
; The first argument is a REAL, not a DOUBLE-FLOAT.
; The second argument is a REAL, not a RATIONAL.
; (STRING< (FIRST K-NUCLEOTIDE::A) (FIRST K-NUCLEOTIDE::B))
;
; note: unable to
; optimize
; due to type uncertainty:
; The first argument is a (OR STRING SYMBOL CHARACTER), not a SIMPLE-STRING.
; The second argument is a (OR STRING SYMBOL CHARACTER), not a SIMPLE-STRING.
; (> (SECOND K-NUCLEOTIDE::A) (SECOND K-NUCLEOTIDE::B))
;
; note: forced to do GENERIC-> (cost 10)
; unable to do inline float comparison (cost 3) because:
; The first argument is a REAL, not a SINGLE-FLOAT.
; The second argument is a REAL, not a SINGLE-FLOAT.
; unable to do inline float comparison (cost 3) because:
; The first argument is a REAL, not a DOUBLE-FLOAT.
; The second argument is a REAL, not a DOUBLE-FLOAT.
; etc.
; (< (SECOND K-NUCLEOTIDE::A) (SECOND K-NUCLEOTIDE::B))
;
; note: forced to do GENERIC-< (cost 10)
; unable to do inline float comparison (cost 3) because:
; The first argument is a REAL, not a SINGLE-FLOAT.
; The second argument is a REAL, not a SINGLE-FLOAT.
; unable to do inline float comparison (cost 3) because:
; The first argument is a REAL, not a DOUBLE-FLOAT.
; The second argument is a REAL, not a DOUBLE-FLOAT.
; etc.
;
; compilation unit finished
; printed 42 notes
; wrote /home/dunham/all-benchmarksgame/benchmarksgame_i53330/knucleotide/tmp/knucleotide.sbcl-5.fasl
; compilation finished in 0:00:00.484
### START knucleotide.sbcl-5.sbcl_run
(main) (quit)
### END knucleotide.sbcl-5.sbcl_run
3.87s to complete and log all make actions
COMMAND LINE:
/opt/src/sbcl-2.4.2/bin/sbcl --noinform --core sbcl.core --userinit /dev/null --load knucleotide.sbcl-5.sbcl_run 0 < knucleotide-input25000000.txt
PROGRAM OUTPUT:
A 30.295
T 30.151
C 19.800
G 19.754
AA 9.177
TA 9.132
AT 9.131
TT 9.091
CA 6.002
AC 6.001
AG 5.987
GA 5.984
CT 5.971
TC 5.971
GT 5.957
TG 5.956
CC 3.917
GC 3.911
CG 3.909
GG 3.902
1471758 GGT
446535 GGTA
47336 GGTATT
893 GGTATTTTAATT
893 GGTATTTTAATTTATAGT