diff --git a/code/bit-bash.lisp b/code/bit-bash.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e3716279f389b557ec34f84f041decffc35eae29 --- /dev/null +++ b/code/bit-bash.lisp @@ -0,0 +1,296 @@ +;;; -*- Log: code.log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; Functions to implement bit bashing. +;;; +;;; Written by William Lott. +;;; + +(in-package "LISP") + + + +;;;; Constants and Types. + + +(eval-when (compile load eval) + +(defconstant unit-bits 16 + "The number of bits to process at a time.") + +(defconstant max-bits (ash most-positive-fixnum -2) + "The maximum number of bits that can be delt with during a single call.") + + +(deftype unit () + `(signed-byte ,unit-bits)) + +(deftype offset () + `(integer 0 ,max-bits)) + +(deftype bit-offset () + `(integer 0 (,unit-bits))) + +(deftype word-offset () + `(integer 0 (,(ceiling max-bits unit-bits)))) + + +); eval-when + + + +;;;; Macros for generating bit-bashing routines. + + +(eval-when (compile eval) + +(defmacro end-bits (count) + "Returns the byte spec for COUNT bits at the end of a word, i.e. the bits + at the largest address." + (ecase vm:target-byte-order + (:little-endian `(byte ,count (- unit-bits ,count))) + (:big-endian `(byte ,count 0)))) + +(defmacro start-bits (count) + "Returns the byte spec for COUNT bits at the start of a word, i.e. the bits + at the smallest address." + (ecase vm:target-byte-order + (:little-endian `(byte ,count 0)) + (:big-endian `(byte ,count (- unit-bits ,count))))) + +(defmacro middle-bits (count where) + "Return the byte spec for COUNT bits starting at bit WHERE. WHERE of zero + corresponds to the start of the word (lowest address) and WHERE of + unit-bits corresponds to the end of the word (highest address). In other + words, act like :little-endian" + (ecase vm:target-byte-order + (:little-endian `(byte ,count ,where)) + (:big-endian `(byte ,count (- unit-bits ,where ,count))))) + + + +(defmacro merge-bits (shift prev next) + "Return (ldb (byte 32 0) (ash (logior (ash prev 32) next) shift)) but stay + out of bignum land." + `(logior (the unit (ash (ldb (byte (- unit-bits ,shift) 0) ,prev) + (- unit-bits ,shift))) + (ash ,next (- ,shift)))) + + + +(defmacro bit-bash-bindings (&body guts) + `(let* ((final-bits (mod (+ len dst-bit-offset) unit-bits)) + (interior (floor (- len final-bits) unit-bits))) + (declare (type bit-offset final-bits) + (type word-offset interior)) + ,@guts)) + +(defmacro bind-srcs ((kind incf-p ref-fn) &body body) + (ecase kind + (:constant `(progn + ,@body + ,@(when incf-p + `((incf dst-word-offset))))) + (:unary `(let ((next-1 (,ref-fn src-1 src-1-word-offset))) + (declare (type unit next-1)) + ,@body + ,@(when incf-p + '((incf dst-word-offset) + (incf src-1-word-offset))))) + (:binary `(let ((next-1 (,ref-fn src-1 src-1-word-offset)) + (next-2 (,ref-fn src-2 src-2-word-offset))) + (declare (type unit next-1 next-2)) + ,@body + ,@(when incf-p + '((incf dst-word-offset) + (incf src-1-word-offset) + (incf src-2-word-offset))))))) + + +(defmacro bit-bash-loop (kind ref-fn function &optional update) + `(progn + (unless (zerop dst-bit-offset) + (bind-srcs (,kind t ,ref-fn) + (setf (ldb (end-bits (- unit-bits dst-bit-offset)) + (,ref-fn dst dst-word-offset)) + ,function) + ,update)) + (dotimes (count interior) + (declare (type word-offset count)) + (bind-srcs (,kind t ,ref-fn) + (setf (,ref-fn dst dst-word-offset) ,function) + ,update)) + (unless (zerop final-bits) + (bind-srcs (,kind nil ,ref-fn) + (setf (ldb (start-bits final-bits) + (,ref-fn dst dst-word-offset)) + (ldb (start-bits final-bits) + ,function)))))) + + +(defun pick-args (op kind arg1 arg2) + (ecase kind + (:constant + op) + (:unary + (list op arg1)) + (:binary + (list op arg1 arg2)))) + +(defmacro def-bit-basher (name op &optional (kind :binary) (ref-fn '%raw-bits)) + (let ((form + `(cond + ((<= (+ dst-bit-offset len) unit-bits) + ;; It's narrow. + (setf (ldb (middle-bits len dst-bit-offset) + (,ref-fn dst dst-word-offset)) + ,(pick-args op kind + `(the unit + (ldb (middle-bits (the bit-offset len) + src-1-bit-offset) + (,ref-fn src-1 src-1-word-offset))) + `(the unit + (ldb (middle-bits (the bit-offset len) + src-2-bit-offset) + (,ref-fn src-2 + src-2-word-offset)))))) + (,(ecase kind + (:constant t) + (:unary '(= src-1-bit-offset dst-bit-offset)) + (:binary '(= src-1-bit-offset src-2-bit-offset dst-bit-offset ))) + ;; Everything is aligned evenly. + (bit-bash-bindings + (bit-bash-loop ,kind ,ref-fn + ,(pick-args op kind 'next-1 'next-2)))) + ,@(when (eq kind :binary) + `(((= src-1-bit-offset dst-bit-offset) + ;; Src1 and the destination are aligned, but src2 is not. + (bit-bash-bindings + (when (> dst-bit-offset src-2-bit-offset) + (decf src-2-word-offset)) + (let* ((src-2-shift + (mod (- dst-offset src-2-offset) unit-bits)) + (prev-2 (,ref-fn src-2 src-2-word-offset))) + (declare (type bit-offset src-2-shift)) + (declare (type unit prev-2)) + (incf src-2-word-offset) + (bit-bash-loop ,kind ,ref-fn + (,op next-1 (merge-bits src-2-shift prev-2 next-2)) + (setf prev-2 next-2))))) + ((= src-2-bit-offset + dst-bit-offset) + ;; Src2 and the destination are aligned, but src1 is not. + (bit-bash-bindings + (when (> dst-bit-offset src-1-bit-offset) + (decf src-1-word-offset)) + (let* ((src-1-shift + (mod (- dst-offset src-1-offset) unit-bits)) + (prev-1 (,ref-fn src-1 src-1-word-offset))) + (declare (type bit-offset src-1-shift)) + (declare (type unit prev-1)) + (incf src-1-word-offset) + (bit-bash-loop ,kind ,ref-fn + (,op (merge-bits src-1-shift prev-1 next-1) next-2) + (setf prev-1 next-1))))))) + ,@(unless (eq kind :constant) + `((t + ;; Nothing is aligned. Ack. + (bit-bash-bindings + (when (> dst-bit-offset src-1-bit-offset) + (decf src-1-word-offset)) + ,@(when (eq kind :binary) + '((when (> dst-bit-offset src-2-bit-offset) + (decf src-2-word-offset)))) + (let* ((src-1-shift + (mod (- dst-offset src-1-offset) unit-bits)) + (prev-1 (,ref-fn src-1 src-1-word-offset)) + ,@(when (eq kind :binary) + `((src-2-shift + (mod (- dst-offset src-2-offset) unit-bits)) + (prev-2 (,ref-fn src-2 src-2-word-offset))))) + (declare (type bit-offset src-1-shift + ,@(when (eq kind :binary) + '(src-2-shift))) + (type unit prev-1 + ,@(when (eq kind :binary) '(prev-2)))) + (incf src-1-word-offset) + ,@(when (eq kind :binary) + '((incf src-2-word-offset))) + (bit-bash-loop ,kind ,ref-fn + ,(pick-args op kind + '(merge-bits src-1-shift prev-1 next-1) + '(merge-bits src-2-shift prev-2 next-2)) + (setf prev-1 next-1 + ,@(when (eq kind :binary) + '(prev-2 next-2))))))))))) + (function-args '(len)) + (function-decls '(len))) + (dolist (arg (ecase kind + (:constant '(dst)) + (:unary '(dst src-1)) + (:binary '(dst src-2 src-1)))) + (let* ((name (string arg)) + (offset + (intern (concatenate 'simple-string name "-OFFSET"))) + (bit-offset + (intern (concatenate 'simple-string name "-BIT-OFFSET"))) + (word-offset + (intern (concatenate 'simple-string name "-WORD-OFFSET")))) + (setf form + `(multiple-value-bind (,word-offset ,bit-offset) + (floor ,offset unit-bits) + (declare (type word-offset ,word-offset) + (type bit-offset ,bit-offset)) + ,form)) + (push offset function-args) + (push offset function-decls) + (push arg function-args))) + `(defun ,name ,function-args + (declare (type offset ,@function-decls)) + ,form))) + +); eval when + + +;;;; The actual bashers. + +(proclaim '(optimize (speed 3) (safety 0))) + + +;;; %raw-bits can be used to index into other-pointer objects. + +(defun %raw-bits (object offset) + (%raw-bits object offset)) + +(defun (setf %raw-bits) (object offset value) + (setf (%raw-bits object offset) value)) + + +(def-bit-basher bit-bash-clear 0 :constant) +(def-bit-basher bit-bash-set (1- (ash 1 unit-bits)) :constant) + +(def-bit-basher bit-bash-not lognot :unary) +(def-bit-basher bit-bash-copy identity :unary) + +(def-bit-basher bit-bash-and logand) +(def-bit-basher bit-bash-ior logior) +(def-bit-basher bit-bash-xor logxor) +(def-bit-basher bit-bash-eqv logeqv) +(def-bit-basher bit-bash-nand lognand) +(def-bit-basher bit-bash-nor lognor) +(def-bit-basher bit-bash-andc1 logandc1) +(def-bit-basher bit-bash-andc2 logandc2) +(def-bit-basher bit-bash-orc1 logorc1) +(def-bit-basher bit-bash-orc2 logorc2) + + +;;; Sap-ref-16 can be used to index into SAP objects. + +(def-bit-basher system-area-clear 0 :constant sap-ref-16) +(def-bit-basher system-area-copy identity :unary sap-ref-16) diff --git a/code/mipsstrops.lisp b/code/mipsstrops.lisp new file mode 100644 index 0000000000000000000000000000000000000000..854d121d62b488c61912d68df4208bfcabfe79f0 --- /dev/null +++ b/code/mipsstrops.lisp @@ -0,0 +1,207 @@ +;;; -*- Log: Code.Log; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; String hacking functions that are stubs for things that might +;;; be microcoded someday. +;;; +;;; Written by Rob MacLachlan and Skef Wholey +;;; +(in-package "SYSTEM") +(export '(%sp-reverse-find-character-with-attribute)) + +(in-package "LISP") + +;(defun %sp-byte-blt (src-string src-start dst-string dst-start dst-end) +; "Moves bytes from Src-String into Dst-String between Dst-Start (inclusive) +;and Dst-End (exclusive) (Dst-Start - Dst-End bytes are moved). Overlap of the +;strings does not affect the result. This would be done on the Vax +;with MOVC3. The arguments do not need to be strings: 8-bit U-Vectors +;are also acceptable." +; (%primitive byte-blt src-string src-start dst-string dst-start dst-end)) + +(defun %sp-string-compare (string1 start1 end1 string2 start2 end2) + (declare (simple-string string1 string2)) + (declare (fixnum start1 end1 start2 end2)) + "Compares the substrings specified by String1 and String2 and returns +NIL if the strings are String=, or the lowest index of String1 in +which the two differ. If one string is longer than the other and the +shorter is a prefix of the longer, the length of the shorter + start1 is +returned. This would be done on the Vax with CMPC3. The arguments must +be simple strings." + (let ((len1 (- end1 start1)) + (len2 (- end2 start2))) + (declare (fixnum len1 len2)) + (cond + ((= len1 len2) + (do ((index1 start1 (1+ index1)) + (index2 start2 (1+ index2))) + ((= index1 end1) nil) + (declare (fixnum index1 index2)) + (if (char/= (elt string1 index1) (elt string2 index2)) + (return index1)))) + ((> len1 len2) + (do ((index1 start1 (1+ index1)) + (index2 start2 (1+ index2))) + ((= index2 end2) index1) + (declare (fixnum index1 index2)) + (if (char/= (elt string1 index1) (elt string2 index2)) + (return index1)))) + (t + (do ((index1 start1 (1+ index1)) + (index2 start2 (1+ index2))) + ((= index1 end1) index1) + (declare (fixnum index1 index2)) + (if (char/= (elt string1 index1) (elt string2 index2)) + (return index1))))))) + +(defun %sp-reverse-string-compare (string1 start1 end1 string2 start2 end2) + (declare (simple-string string1 string2)) + (declare (fixnum start1 end1 start2 end2)) + "Like %sp-string-compare, only backwards." + (let ((len1 (- end1 start1)) + (len2 (- end2 start2))) + (declare (fixnum len1 len2)) + (cond + ((= len1 len2) + (do ((index1 (1- end1) (1- index1)) + (index2 (1- end2) (1- index2))) + ((< index1 start1) nil) + (declare (fixnum index1 index2)) + (if (char/= (elt string1 index1) (elt string2 index2)) + (return index1)))) + ((> len1 len2) + (do ((index1 (1- end1) (1- index1)) + (index2 (1- end2) (1- index2))) + ((< index2 start2) index1) + (declare (fixnum index1 index2)) + (if (char/= (elt string1 index1) (elt string2 index2)) + (return index1)))) + (t + (do ((index1 (1- end1) (1- index1)) + (index2 (1- end2) (1- index2))) + ((< index1 start1) index1) + (declare (fixnum index1 index2)) + (if (char/= (elt string1 index1) (elt string2 index2)) + (return index1))))))) + +;(defun %sp-find-character-with-attribute (string start end table mask) +; (declare (type (simple-array (mod 256) char-code-max) table)) +; (declare (simple-string string)) +; (declare (fixnum start end)) +; "%SP-Find-Character-With-Attribute String, Start, End, Table, Mask +; The codes of the characters of String from Start to End are used as indices +; into the Table, which is a U-Vector of 8-bit bytes. When the number picked +; up from the table bitwise ANDed with Mask is non-zero, the current +; index into the String is returned. The corresponds to SCANC on the Vax." +; (%primitive find-character-with-attribute string start end table mask)) + +;;;; ### Warning ### ### Warning ### ### Warning ### ### Warning ### +;;; +;;; This will lose big if a GC can happen during its execution, since +;;; a pointer to after the header of the table is maintained. Currently +;;; GC's happen only immediately after allocation, so we're safe. +;;; +(defun %sp-reverse-find-character-with-attribute (string start end table mask) + "Like %SP-Find-Character-With-Attribute, only sdrawkcaB." + (declare (fixnum start end mask)) + (incf start 8) + (do ((table (%primitive sap+ table 8)) + (index (+ end 7) (1- index))) + ((< index start) nil) + (declare (fixnum index)) + (unless (eql (logand (the fixnum + (%primitive 8bit-system-ref table + (%primitive 8bit-system-ref string index))) + mask) + 0) + (return (- index 8))))) + +;(defun %sp-find-character (string start end character) +; "%SP-Find-Character String, Start, End, Character +; Searches String for the Character from Start to End. If the character is +; found, the corresponding index into String is returned, otherwise NIL is +; returned." +; (%primitive find-character string start end character)) + +(defun %sp-skip-character (string start end character) + (declare (simple-string string)) + (declare (fixnum start end)) + "%SP-Skip-Character String, Start, End, Character + Returns the index of the first character between Start and End which + is not Char= to Character, or NIL if there is no such character." + (do ((index start (1+ index))) + ((= index end) nil) + (declare (fixnum index)) + (if (char/= (char string index) character) + (return index)))) + +(defun %sp-reverse-find-character (string start end character) + (declare (simple-string string)) + (declare (fixnum start end)) + "%SP-Reverse-Find-Character String, Start, End, Character + Searches String for Character from End to Start. If the character is + found, the corresponding index into String is returned, otherwise NIL is + returned." + (do ((index (1- end) (1- index)) + (terminus (1- start))) + ((= index terminus) nil) + (declare (fixnum terminus index)) + (if (char= (char string index) character) + (return index)))) + +(defun %sp-reverse-skip-character (string start end character) + (declare (simple-string string)) + (declare (fixnum start end)) + "%SP-Skip-Character String, Start, End, Character + Returns the index of the last character between Start and End which + is not Char= to Character, or NIL if there is no such character." + (do ((index (1- end) (1- index)) + (terminus (1- start))) + ((= index terminus) nil) + (declare (fixnum terminus index)) + (if (char/= (char string index) character) + (return index)))) + +(defun %sp-string-search (string1 start1 end1 string2 start2 end2) + "%SP-String-Search String1, Start1, End1, String2, Start2, End2 + Searches for the substring of String1 specified in String2. + Returns an index into String2 or NIL if the substring wasn't + found." + (do ((index2 start2 (1+ index2))) + ((= index2 end2) nil) + (if (do ((index1 start1 (1+ index1)) + (index2 index2 (1+ index2))) + ((= index1 end1) t) + (if (char/= (char string1 index1) (char string2 index2)) + (return nil))) + (return index2)))) + + +(defun %sp-char-upcase (character) + "%SP-Char-Upcase Character + Returns a character with the same font and bits, but with an upper case + code if it was alphabetic." + (char-upcase character)) + +(defun %sp-char-downcase (character) + "%SP-Char-Downcase Character + Returns a character with the same font and bits, but with a lower + case character code if it was alphabetic." + (char-downcase character)) + +(defun %sp-string-upcase (string start end) + "Creates a new string with the chars from start to end uppercased." + (string-upcase string :start start :end end)) + +(defun %sp-string-downcase (string start end) + "Creates a new string with the chars from start to end lowercased." + (string-downcase string :start start :end end)) + +;(defun %sp-sxhash-simple-string (string) +; (%primitive sxhash-simple-string string))