optimizing

audio-streams.lisp

@@ -44,6 +44,10 @@
       )
     (setf vect nil)))
 
+;;; finding out current file position is so common, we also
+;;; provide a macro
+(defmacro stream-here (stream) `(index ,stream))
+
 (defmethod stream-seek ((stream mem-stream) &optional (offset 0) (from :current))
   "Set INDEX to requested value.  No error checking done here, but subsequent reads will fail if INDEX is out-of-bounds.
 As a convenience, OFFSET and FROM are optional, so (STREAM-SEEK stream) returns the current read-offset in stream."

flac-frame.lisp

@@ -57,7 +57,7 @@
   (log5:with-context "make-flac-header"
     (let* ((header (stream-read-u32 stream))
            (flac-header (make-instance 'flac-header
-                                       :pos (- (stream-seek stream) 4)
+                                       :pos (- (stream-here stream) 4)
                                        :last-bit (utils:get-bitfield header 31 1)
                                        :header-type (utils:get-bitfield header 30 7)
                                        :header-len (utils:get-bitfield header 23 24))))

id3-frame.lisp

@@ -217,7 +217,7 @@ NB: 2.3 and 2.4 extended flags are different..."
     (with-slots (version revision flags size ext-header frames v21-tag-header) me
       (stream-seek instream 128 :end)
       (when (string= "TAG" (stream-read-string-with-len instream 3))
-        (log-id3-frame "looking at last 128 bytes at ~:d to try to read id3v21 header" (stream-seek instream))
+        (log-id3-frame "looking at last 128 bytes at ~:d to try to read id3v21 header" (stream-here instream))
         (handler-case
             (setf v21-tag-header (make-instance 'v21-tag-header :instream instream))
           (condition (c)
@@ -258,10 +258,10 @@ NB: 2.3 and 2.4 extended flags are different..."
 (defun get-name-value-pair (instream len name-encoding value-encoding)
   (declare #.utils:*standard-optimize-settings*)
   (log5:with-context  "get-name-value-pair"
-    (log-id3-frame "reading from ~:d, len ~:d, name-encoding = ~d, value-encoding = ~d" (stream-seek instream) len name-encoding value-encoding)
-    (let* ((old-pos (stream-seek instream))
+    (log-id3-frame "reading from ~:d, len ~:d, name-encoding = ~d, value-encoding = ~d" (stream-here instream) len name-encoding value-encoding)
+    (let* ((old-pos (stream-here instream))
            (name (stream-read-string instream :encoding name-encoding))
-           (name-len (- (stream-seek instream) old-pos))
+           (name-len (- (stream-here instream) old-pos))
            (value))
 
       (log-id3-frame "name = <~a>, name-len = ~d" name name-len)
@@ -926,12 +926,13 @@ NB: 2.3 and 2.4 extended flags are different..."
 
       (log-id3-frame "general case for id <~a> is ~a" id found-class)
       found-class)))
+(utils:memoize 'find-frame-class)
 
 (defun make-frame (version instream fn)
   "Create an appropriate mp3 frame by reading data from INSTREAM."
   (declare #.utils:*standard-optimize-settings*)
   (log5:with-context "make-frame"
-    (let* ((pos (stream-seek instream))
+    (let* ((pos (stream-here instream))
            (byte (stream-read-u8 instream))
            frame-name frame-len frame-flags frame-class)
 
@@ -962,7 +963,7 @@ NB: 2.3 and 2.4 extended flags are different..."
 
       ;; edge case where found a frame name, but it is not valid or where making this frame
       ;; would blow past the end of the file/buffer
-      (when (or (> (+ (stream-seek instream) frame-len) (stream-size instream))
+      (when (or (> (+ (stream-here instream) frame-len) (stream-size instream))
                 (null frame-class))
         (error "bad frame at position ~d found: ~a" pos frame-name))
 
@@ -977,7 +978,7 @@ NB: 2.3 and 2.4 extended flags are different..."
                (log-id3-frame "Starting loop through ~:d bytes" (stream-size stream))
                (let (frames this-frame)
                  (do ()
-                     ((>= (stream-seek stream) (stream-size stream)))
+                     ((>= (stream-here stream) (stream-size stream)))
                    (handler-case
                        (progn
                          (setf this-frame (make-frame version stream (stream-filename mp3-file)))
@@ -985,7 +986,7 @@ NB: 2.3 and 2.4 extended flags are different..."
                            (log-id3-frame "hit padding: returning ~d frames" (length frames))
                            (return-from read-loop (values t (nreverse frames))))
 
-                         (log-id3-frame "bottom of read-loop: pos = ~:d, size = ~:d" (stream-seek stream) (stream-size stream))
+                         (log-id3-frame "bottom of read-loop: pos = ~:d, size = ~:d" (stream-here stream) (stream-size stream))
                          (push this-frame frames))
                      (condition (c)
                        (utils:warn-user "find-id3-frame got condition ~a" c)

mp4-atom.lisp

@@ -104,10 +104,10 @@
 ;;   (declare #.utils:*standard-optimize-settings*)
 ;;   (log5:with-context "atom-read-loop"
 ;;     (do ()
-;;         ((>= (stream-seek mp4-file) end))
-;;       (log-mp4-atom "atom-read-loop: @~:d before dispatch" (stream-seek mp4-file))
+;;         ((>= (stream-here mp4-file) end))
+;;       (log-mp4-atom "atom-read-loop: @~:d before dispatch" (stream-here mp4-file))
 ;;       (funcall func)
-;;       (log-mp4-atom "atom-read-loop: @~:d after dispatch" (stream-seek mp4-file)))))
+;;       (log-mp4-atom "atom-read-loop: @~:d after dispatch" (stream-here mp4-file)))))
 
 (defclass mp4-atom ()
   ((atom-file-position :accessor atom-file-position :initarg :atom-file-position)
@@ -155,10 +155,10 @@ Loop through this container and construct constituent atoms"
   (log5:with-context "atom-ilst-initializer"
     (with-slots (atom-size atom-type atom-children) me
       (log-mp4-atom "atom-ilst-init: found ilst atom <~a> @ ~:d, looping for ~:d bytes"
-                    (as-string atom-type) (stream-seek mp4-file) (- atom-size 8))
+                    (as-string atom-type) (stream-here mp4-file) (- atom-size 8))
 
-      (let ((end (+ (stream-seek mp4-file) (- atom-size 8))))
-        (loop for current = (stream-seek mp4-file) then (stream-seek mp4-file)
+      (let ((end (+ (stream-here mp4-file) (- atom-size 8))))
+        (loop for current = (stream-here mp4-file) then (stream-here mp4-file)
             while (< current end) do
               (log-mp4-atom "at ~:d:~:d~%" current end)
               (addc me (make-mp4-atom mp4-file atom-type)))))))
@@ -380,7 +380,7 @@ Loop through this container and construct constituent atoms"
           flags (stream-read-u24 mp4-file))
     (assert (= +MP4-ESDescrTag+ (stream-read-u8 mp4-file)) () "Expected description tag of ESDescrTag")
     (let* ((len (read-descriptor-len mp4-file))
-           (end-of-atom (+ (stream-seek mp4-file) len)))
+           (end-of-atom (+ (stream-here mp4-file) len)))
       (setf esid (stream-read-u16 mp4-file)
             s-priority (stream-read-u8 mp4-file))
       (assert (= +MP4-DecConfigDescrTag+ (stream-read-u8 mp4-file)) () "Expected tag type of DecConfigDescrTag")
@@ -444,7 +444,7 @@ Loop through this container and construct constituent atoms"
   (declare #.utils:*standard-optimize-settings*)
   (with-slots (atom-children atom-file-position atom-of-interest atom-size atom-type atom-decoded) parent-atom
     (let ((end (+ atom-file-position atom-size)))
-      (loop for current = (stream-seek mp4-file) then (stream-seek mp4-file)
+      (loop for current = (stream-here mp4-file) then (stream-here mp4-file)
             while (< current end) do
               (let ((child (make-mp4-atom mp4-file atom-type)))
                 (log-mp4-atom "read-container-atoms: adding new child ~a" (vpprint child nil))
@@ -477,12 +477,12 @@ Loop through this container and construct constituent atoms"
     ;; didn't find a class, so return ATOM-SKIP class
     (log-mp4-atom "find-atom-class: class not found")
     'atom-skip))
-
+(utils:memoize 'find-atom-class)
 (defun make-mp4-atom (mp4-file &optional parent-type)
   "Get current file position, read in size/type, then construct the correct atom."
   (declare #.utils:*standard-optimize-settings*)
   (log5:with-context "make-mp4-atom"
-    (let* ((pos (stream-seek mp4-file))
+    (let* ((pos (stream-here mp4-file))
            (siz (stream-read-u32 mp4-file))
            (typ (stream-read-u32 mp4-file))
            (atom))
@@ -499,15 +499,16 @@ Loop through this container and construct constituent atoms"
       atom)))
 
 (defmethod vpprint ((me mp4-atom) stream)
-  (format stream "~a" (with-output-to-string (s)
-                        (with-slots (atom-children atom-file-position atom-size atom-type) me
-                          (format s "ATOM: type: <~a> @ ~:d of size ~:d and child count of ~d"
-                                  (as-string atom-type) atom-file-position atom-size (length atom-children)))
-                        (if (typep me 'atom-data)
-                            (with-slots (atom-version atom-flags atom-value atom-type atom-parent-type) me
-                              (format s " having ilst fields: atom-parent-type = ~a, verison = ~d, flags = ~x, data = ~x"
-                                      (as-string atom-parent-type) atom-version atom-flags
-                                      (if (typep atom-value 'array) (printable-array atom-value) atom-value)))))))
+  (format stream "~a"
+          (with-output-to-string (s)
+            (with-slots (atom-children atom-file-position atom-size atom-type) me
+              (format s "ATOM: type: <~a> @ ~:d of size ~:d and child count of ~d"
+                      (as-string atom-type) atom-file-position atom-size (length atom-children)))
+            (if (typep me 'atom-data)
+                (with-slots (atom-version atom-flags atom-value atom-type atom-parent-type) me
+                  (format s " having ilst fields: atom-parent-type = ~a, verison = ~d, flags = ~x, data = ~x"
+                          (as-string atom-parent-type) atom-version atom-flags
+                          (if (typep atom-value 'array) (printable-array atom-value) atom-value)))))))
 
 (defun is-valid-m4-file (mp4-file)
   "Make sure this is an MP4 file.  Quick check: is first atom (at file-offset 4) == FSTYP?
@@ -537,11 +538,11 @@ Written in this fashion so as to be 'crash-proof' when passed an arbitrary file.
   (log5:with-context "find-mp4-atoms"
 
     (log-mp4-atom "find-mp4-atoms: ~a, before read-file loop, file-position = ~:d, end = ~:d"
-                  (stream-filename mp4-file) (stream-seek mp4-file) (stream-size mp4-file))
+                  (stream-filename mp4-file) (stream-here mp4-file) (stream-size mp4-file))
 
     (let ((atoms)
           (end (stream-size mp4-file)))
-      (loop for current = (stream-seek mp4-file) then (stream-seek mp4-file)
+      (loop for current = (stream-here mp4-file) then (stream-here mp4-file)
             while (< current end) do
               (let ((new-atom (make-mp4-atom mp4-file)))
                 (when new-atom
@@ -613,7 +614,7 @@ call traverse atom (unless length of path == 1, in which case, we've found our m
                           (format out-stream "~vt~a~%" depth (vpprint atom nil))))))
 
 (defun find-all (base name)
-  "Starting as BASE atom, recursively search for all instances of NAME"
+  "Starting at BASE atom, recursively search for all instances of NAME"
   (declare #.utils:*standard-optimize-settings*)
   (let* ((search-name (if (typep name 'string) (as-int name) name))
          (found))

mpeg.lisp

@@ -192,14 +192,13 @@
 (defmethod load-frame ((me frame) &key instream (read-payload nil))
   "Load an MPEG frame from current file position.  If READ-PAYLOAD is set, read in frame's content."
   (declare #.utils:*standard-optimize-settings*)
-  (declare #.utils:*standard-optimize-settings*)
   (log5:with-context "load-frame"
     (handler-case
         (with-frame-slots (me)
-          (log-mpeg-frame "loading frame from pos ~:d" (stream-seek instream))
+          (log-mpeg-frame "loading frame from pos ~:d" (stream-here instream))
           (when (null hdr-u32)          ; has header already been read in?
             (log-mpeg-frame "reading in header")
-            (setf pos (stream-seek instream)
+            (setf pos (stream-here instream)
                   hdr-u32 (stream-read-u32 instream))
             (when (null hdr-u32)
               (log-mpeg-frame "hit EOF")
@@ -396,14 +395,14 @@ Bits   1-0 (2  bits): the emphasis"
   (declare #.utils:*standard-optimize-settings*)
   (log5:with-context "find-first-sync"
 
-    (log-mpeg-frame "Looking for first sync, begining at file position ~:d" (stream-seek in))
+    (log-mpeg-frame "Looking for first sync, begining at file position ~:d" (stream-here in))
     (let ((hdr-u32)
           (count 0)
           (pos))
 
       (handler-case
           (loop
-            (setf pos (stream-seek in)
+            (setf pos (stream-here in)
                   hdr-u32 (stream-read-u32 in))
             (when (null hdr-u32)
               (return-from find-first-sync nil))
@@ -432,11 +431,11 @@ Bits   1-0 (2  bits): the emphasis"
     (let ((nxt-frame (make-instance 'frame)))
       (when (not (payload me))
         (log-mpeg-frame "no payload load required in current frame, skipping from ~:d forward ~:d bytes"
-                        (stream-seek instream)
+                        (stream-here instream)
                         (- (size me) 4) :current)
         (stream-seek instream (- (size me) 4) :current))
 
-      (log-mpeg-frame "at pos ~:d, read-payload is ~a" (stream-seek instream) read-payload)
+      (log-mpeg-frame "at pos ~:d, read-payload is ~a" (stream-here instream) read-payload)
       (if (load-frame nxt-frame :instream instream :read-payload read-payload)
           nxt-frame
           nil))))
@@ -446,7 +445,7 @@ Bits   1-0 (2  bits): the emphasis"
 (defun map-frames (in func &key (start-pos nil) (read-payload nil) (max nil))
   "Loop through the MPEG audio frames in a file.  If *MAX-FRAMES-TO-READ* is set, return after reading that many frames."
   (declare #.utils:*standard-optimize-settings*)
-  (log5:with-context "next-frame"
+  (log5:with-context "map-frames"
     (log-mpeg-frame "mapping frames, start pos ~:d" start-pos)
 
     (when start-pos

packages.lisp

@@ -29,7 +29,7 @@
            #:stream-read-iso-string #:stream-read-ucs-string #:stream-read-ucs-be-string
            #:stream-read-utf-8-string #:stream-read-string
            #:stream-read-string #:stream-read-sequence #:stream-size
-           #:stream-seek #:stream-close)
+           #:stream-seek #:stream-here #:stream-close)
   (:use #:common-lisp #:utils))
 
 (defpackage #:flac-frame

utils.lisp

@@ -3,6 +3,7 @@
 (in-package #:utils)
 
 #+CCL (eval-when (:compile-toplevel :load-toplevel :execute)
+        (pushnew :INSTRUMENT-MEMOIZED *features*)
         (defvar *standard-optimize-settings* '(optimize (speed 3) (safety 0) (space 0) (debug 0))))
 
 (defparameter *break-on-warn-user* nil "set to T if you'd like to stop in warn-user")
@@ -77,16 +78,18 @@ The above will expand to (ash (logand #xFFFBB240 #xFFE00000) -21) at COMPILE tim
 
 #+INSTRUMENT-MEMOIZED (progn
                         (defstruct memoized-funcs
+                          name
                           table
                           calls
                           finds
                           news)
                         (defvar *memoized-funcs* nil))
 
-(defun mk-memoize (func)
+(defun mk-memoize (func-name)
   "Takes a normal function object and returns a memoized one"
-  (let* ((hash-table (make-hash-table :test 'equal))
-          #+INSTRUMENT-MEMOIZED (s (make-memoized-funcs :table hash-table :calls 0 :finds 0 :news 0))
+  (let* ((func (symbol-function func-name))
+         (hash-table (make-hash-table :test 'equal))
+          #+INSTRUMENT-MEMOIZED (s (make-memoized-funcs :table hash-table :calls 0 :finds 0 :news 0 :name func-name))
          )
 
     #+INSTRUMENT-MEMOIZED (push s *memoized-funcs*)
@@ -104,4 +107,4 @@ The above will expand to (ash (logand #xFFFBB240 #xFFE00000) -21) at COMPILE tim
 
 (defmacro memoize (func-name)
   "Memoize function associated with Function-Name. Simplified version"
-  `(setf (symbol-function ,func-name) (utils::mk-memoize (symbol-function ,func-name))))
+  `(setf (symbol-function ,func-name) (utils::mk-memoize ,func-name)))