From 76b5e40b38bd9783170844c5900e7bb1869ae1db Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Fri, 24 Aug 1990 18:36:10 +0000 Subject: [PATCH] Merged MIPS branch with the trunk. --- compiler/aliencomp.lisp | 511 ++++++++++++++++++++++++++++----------- compiler/codegen.lisp | 36 ++- compiler/debug-dump.lisp | 13 +- compiler/debug.lisp | 41 +++- compiler/eval.lisp | 8 +- compiler/fndb.lisp | 44 ++-- compiler/ir1opt.lisp | 2 + compiler/ir1tran.lisp | 4 +- compiler/ir2tran.lisp | 60 ++--- compiler/main.lisp | 47 ++-- compiler/vmdef.lisp | 4 +- 11 files changed, 542 insertions(+), 228 deletions(-) diff --git a/compiler/aliencomp.lisp b/compiler/aliencomp.lisp index db4fecc7f..bc87ba412 100644 --- a/compiler/aliencomp.lisp +++ b/compiler/aliencomp.lisp @@ -22,9 +22,11 @@ ct-a-val-p ct-a-val make-ct-a-val ct-a-val-alien check<= check= %alien-indirect %aligned-sap naturalize-integer deport-integer naturalize-boolean deport-boolean - sap-ref-8 sap-ref-16 sap-ref-32 + sap-ref-8 sap-ref-16 sap-ref-32 sap-ref-sap signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32 - %set-alien-access + %set-sap-ref-8 %set-sap-ref-16 %set-sap-ref-32 %set-sap-ref-sap + sap+ %set-alien-access %set-sap-ref-single %set-sap-ref-double + %set-sap-ref-descriptor *alien-eval-when* make-alien alien-type alien-size alien-address copy-alien dispose-alien defalien alien-value @@ -164,7 +166,7 @@ (eql (continuation-value size) 32)) (give-up "Size may not be 32:~% ~S" (continuation-value exp))) - '(%primitive sap-system-ref sap (ash offset -4))) + '(sap-ref-sap sap (ash offset -5))) ;;; Grovel-Alien-Var -- Internal @@ -202,7 +204,8 @@ (defun grovel-alien-operator (type exp info) (unless (or (not type) (equal (lisp::alien-info-result-type info) type)) - (compiler-error "Does not result in a ~S alien value:~% ~S" type exp)) + (compiler-error "Results in a ~S alien value, not a ~S:~% ~S" + (lisp::alien-info-result-type info) type exp)) (unless (= (lisp::alien-info-num-args info) (length (cdr exp))) (compiler-error "Alien operator not called with ~D args:~% ~S" @@ -288,21 +291,26 @@ ;;;; Miscellaneous internal frobs: -(defknown sap+ (t t) t (movable flushable)) +(defknown sap+ (system-area-pointer integer) system-area-pointer + (movable flushable)) (deftransform sap+ ((sap offset)) (unless (and (constant-continuation-p offset) (eql (continuation-value offset) 0)) (give-up)) 'sap) -(defknown sap-int (t) unsigned-byte (movable flushable)) -(defknown int-sap (unsigned-byte) t (movable flushable)) +(defknown sap- (system-area-pointer system-area-pointer) (signed-byte 32) + (movable flushable)) + +(defknown sap-int (system-area-pointer) (unsigned-byte 32) (movable flushable)) +(defknown int-sap ((unsigned-byte 32)) system-area-pointer (movable)) -(defknown %aligned-sap (t t t) t (movable flushable)) +(defknown %aligned-sap (system-area-pointer unsigned-byte t) system-area-pointer + (movable flushable)) (deftransform %aligned-sap ((sap offset form)) (unless (> (find-alignment offset) 3) (give-up)) - '(sap+ sap offset)) + '(sap+ sap (ash offset -3))) (defknown (check<= check=) (index index) void (movable)) @@ -327,12 +335,47 @@ (defknown record-size (symbol) index (movable foldable flushable)) -(defknown sap-ref-8 (t index) (unsigned-byte 8) (flushable)) -(defknown sap-ref-16 (t index) (unsigned-byte 16) (flushable)) -(defknown sap-ref-32 (t index) (unsigned-byte 32) (flushable)) -(defknown (setf sap-ref-8) (t index (unsigned-byte 8)) (unsigned-byte 8) ()) -(defknown (setf sap-ref-16) (t index (unsigned-byte 16)) (unsigned-byte 16) ()) -(defknown (setf sap-ref-32) (t index (unsigned-byte 32)) (unsigned-byte 32) ()) +(defknown sap-ref-8 (system-area-pointer index) (unsigned-byte 8) + (flushable)) +(defknown sap-ref-16 (system-area-pointer index) (unsigned-byte 16) + (flushable)) +(defknown sap-ref-32 (system-area-pointer index) (unsigned-byte 32) + (flushable)) + +(defknown signed-sap-ref-8 (system-area-pointer index) (signed-byte 8) + (flushable)) +(defknown signed-sap-ref-16 (system-area-pointer index) (signed-byte 16) + (flushable)) +(defknown signed-sap-ref-32 (system-area-pointer index) (signed-byte 32) + (flushable)) + +(defknown %set-sap-ref-8 + (system-area-pointer index (or (unsigned-byte 8) (signed-byte 8))) + (or (unsigned-byte 8) (signed-byte 8)) ()) +(defknown %set-sap-ref-16 + (system-area-pointer index (or (unsigned-byte 16) (signed-byte 16))) + (or (unsigned-byte 16) (signed-byte 16)) ()) +(defknown %set-sap-ref-32 + (system-area-pointer index (or (unsigned-byte 32) (signed-byte 32))) + (or (unsigned-byte 32) (signed-byte 32)) ()) + +(defknown sap-ref-sap (system-area-pointer index) system-area-pointer + (flushable)) +(defknown %set-sap-ref-sap (system-area-pointer index system-area-pointer) + system-area-pointer + ()) + +(defknown sap-ref-single (system-area-pointer index) single-float + (flushable)) +(defknown sap-ref-double (system-area-pointer index) double-float + (flushable)) + +(defknown %set-sap-ref-single + (system-area-pointer index single-float) single-float + ()) +(defknown %set-sap-ref-double + (system-area-pointer index double-float) double-float + ()) ;;;; Alien variable special forms: @@ -388,27 +431,209 @@ ;;; With-Stack-Alien-Transform -- Internal ;;; ;;; -(def-ir1-translator with-stack-alien (((var stack) &body forms) start cont) - (let ((info (info alien-stack info stack))) - (unless info - (compiler-error "~S is not the name of a declared alien stack." stack)) - - (let* ((n-current (lisp::stack-info-current info)) - (n-sap (gensym)) - (n-alien (gensym)) - (a-val (make-ct-a-val :type (lisp::stack-info-type info) - :size (lisp::stack-info-size info) - :sap n-sap - :offset 0 - :alien n-alien)) - (*lexical-environment* - (make-lexenv :variables (list (cons var a-val))))) - (ir1-convert start cont - `(let* ((,n-alien (or (car ,n-current) - (,(lisp::stack-info-grow info)))) - (,n-sap (lisp::alien-value-sap ,n-alien)) - (,n-current (cdr ,n-current))) - ,@forms))))) +(def-ir1-translator with-stack-alien (((var type &optional size) + &body forms) start cont) + (unless size + (let ((info (info alien-stack info type))) + (unless info + (compiler-error "~S is not the name of a declared alien stack." type)) + (setf type (lisp::stack-info-type info)) + (setf size (lisp::stack-info-size info)))) + (let* ((sap-var (gensym)) + (*venv* (acons var + (make-ct-a-val :type type + :size size + :sap sap-var + :offset 0) + *venv*))) + (ir1-convert start cont + `(let ((,sap-var + (truly-the system-area-pointer + (%primitive alloc-number-stack-space + (ceiling ,size vm:byte-bits))))) + (declare (ignorable ,sap-var)) + (multiple-value-prog1 + (progn ,@forms) + (%primitive dealloc-number-stack-space + (ceiling ,size vm:byte-bits))))))) + + +;;;; CALL-FOREIGN-FUNCTION stuff. + +(defknown ext::call-foreign-function (simple-base-string t t &rest t) t) + +(defun alien-type-type (type) + (let ((name (if (listp type) (car type) type))) + (case name + ((unsigned-byte signed-byte system-area-pointer + double-float single-float) + (specifier-type type)) + (port + (specifier-type '(unsigned-byte 32))) + (t + (error "Alien type ~S has no corresponding Lisp type." type))))) + +(defoptimizer (ext::call-foreign-function derive-type) + ((name return-type arg-types &rest args)) + (assert (constant-continuation-p return-type)) + (assert (constant-continuation-p arg-types)) + (let ((return-type (continuation-value return-type)) + (arg-types (continuation-value arg-types))) + (unless (= (length arg-types) (length args)) + (error "Different number of argument types (~D) from arguments (~D)." + (length arg-types) + (length args))) + (dolist (type arg-types) + (let ((arg (pop args))) + (assert-continuation-type arg (alien-type-type type)))) + (if return-type + (alien-type-type return-type) + *universal-type*))) + +(defun make-call-out-nsp-tn () + (make-wired-tn (primitive-type-or-lose 'positive-fixnum) + (sc-number-or-lose 'any-reg) + nsp-offset)) + +(defun make-call-out-argument-tns (arg-types) + (let ((stack-frame-size 0) + (did-int-arg nil) + (float-args 0)) + (collect ((tns)) + (dolist (type arg-types) + (let ((name (if (consp type) (car type) type))) + (ecase name + ((unsigned-byte port) + (if (< stack-frame-size 4) + (tns (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32) + (sc-number-or-lose 'unsigned-reg) + (+ stack-frame-size 4))) + (tns (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32) + (sc-number-or-lose 'unsigned-stack) + stack-frame-size))) + (incf stack-frame-size) + (setf did-int-arg t)) + (signed-byte + (if (< stack-frame-size 4) + (tns (make-wired-tn (primitive-type-or-lose 'signed-byte-32) + (sc-number-or-lose 'signed-reg) + (+ stack-frame-size 4))) + (tns (make-wired-tn (primitive-type-or-lose 'signed-byte-32) + (sc-number-or-lose 'signed-stack) + stack-frame-size))) + (incf stack-frame-size) + (setf did-int-arg t)) + (system-area-pointer + (if (< stack-frame-size 4) + (tns (make-wired-tn (primitive-type-or-lose + 'system-area-pointer) + (sc-number-or-lose 'sap-reg) + (+ stack-frame-size 4))) + (tns (make-wired-tn (primitive-type-or-lose + 'system-area-pointer) + (sc-number-or-lose 'sap-stack) + stack-frame-size))) + (incf stack-frame-size) + (setf did-int-arg t)) + (double-float + ;; Round to a dual-word. + (setf stack-frame-size (logandc2 (1+ stack-frame-size) 1)) + (cond ((>= stack-frame-size 4) + (tns (make-wired-tn (primitive-type-or-lose 'double-float) + (sc-number-or-lose 'double-stack) + stack-frame-size))) + ((and (not did-int-arg) (< float-args 2)) + (tns (make-wired-tn (primitive-type-or-lose 'double-float) + (sc-number-or-lose 'double-reg) + (+ (* float-args 2) 12)))) + (t + (error "Can't put floats in int regs yet."))) + (incf stack-frame-size 2) + (incf float-args)) + (single-float + (cond ((>= stack-frame-size 4) + (tns (make-wired-tn (primitive-type-or-lose 'single-float) + (sc-number-or-lose 'single-stack) + stack-frame-size))) + ((and (not did-int-arg) (< float-args 2)) + (tns (make-wired-tn (primitive-type-or-lose 'single-float) + (sc-number-or-lose 'single-reg) + (+ (* float-args 2) 12)))) + (t + (error "Can't put floats in int regs yet."))) + (incf stack-frame-size) + (incf float-args))))) + (values (tns) + (logandc2 (1+ stack-frame-size) 1))))) + +(defun make-call-out-result-tn (type) + (let ((name (if (consp type) (car type) type))) + (ecase name + ((unsigned-byte port) + (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32) + (sc-number-or-lose 'unsigned-reg) + 2)) + (signed-byte + (make-wired-tn (primitive-type-or-lose 'signed-byte-32) + (sc-number-or-lose 'signed-reg) + 2)) + (system-area-pointer + (make-wired-tn (primitive-type-or-lose 'system-area-pointer) + (sc-number-or-lose 'sap-reg) + 2)) + (double-float + (make-wired-tn (primitive-type-or-lose 'double-float) + (sc-number-or-lose 'double-reg) + 0)) + (single-float + (make-wired-tn (primitive-type-or-lose 'single-float) + (sc-number-or-lose 'single-reg) + 0))))) + +(defoptimizer (ext::call-foreign-function ltn-annotate) + ((name return-type arg-types &rest args) node policy) + (setf (basic-combination-info node) :funny) + (setf (node-tail-p node) nil) + (dolist (arg args) + (annotate-ordinary-continuation arg policy))) + +(defoptimizer (ext::call-foreign-function ir2-convert) + ((name return-type arg-types &rest args) call block) + (assert (constant-continuation-p name)) + (assert (constant-continuation-p return-type)) + (assert (constant-continuation-p arg-types)) + (let* ((name (continuation-value name)) + (return-type (continuation-value return-type)) + (arg-types (continuation-value arg-types)) + (cont (node-cont call))) + (multiple-value-bind (arg-tns stack-frame-size) + (make-call-out-argument-tns arg-types) + (unless (zerop stack-frame-size) + (let ((nsp (make-call-out-nsp-tn)) + (args args)) + (vop alloc-number-stack-space call block stack-frame-size nsp) + (dolist (tn arg-tns) + (let* ((arg (pop args)) + (sc (tn-sc tn)) + (scn (sc-number sc)) + (temp-tn (make-representation-tn (tn-primitive-type tn) + scn))) + (assert arg) + (emit-move call block (continuation-tn call block arg) temp-tn) + (emit-move-arg-template call block + (svref (sc-move-arg-vops sc) scn) + temp-tn nsp tn))) + (assert (null args)))) + + (let ((results (when return-type + (list (make-call-out-result-tn return-type))))) + (vop* call-out call block + ((reference-tn-list arg-tns nil)) + ((reference-tn-list results t)) + name) + (unless (zerop stack-frame-size) + (vop dealloc-number-stack-space call block stack-frame-size)) + (move-continuation-result call block results cont))))) ;;;; Transforms for basic Alien accessors. @@ -427,11 +652,13 @@ `(let* ,(reverse binds) ,(ignore-unreferenced-vars binds) ,@(nreverse stuff) - (+ (sap-int ,(ct-a-val-sap res)) (/ ,(ct-a-val-offset res) 16))))) + (+ (sap-int ,(ct-a-val-sap res)) + (/ ,(ct-a-val-offset res) vm:byte-bits))))) ;;; Alien-SAP soruce transform -- Internal ;;; +;;; (def-source-transform alien-sap (alien &whole source) (multiple-value-bind (binds stuff res) (analyze-alien-expression nil alien) @@ -477,7 +704,8 @@ ,(ct-a-val-size res) ',(ct-a-val-type res) ,lisp-type ',form)))) -(defknown %alien-access (t unsigned-byte unsigned-byte t t t) t +(defknown %alien-access + (system-area-pointer unsigned-byte unsigned-byte t t t) t (movable flushable)) ;;; %Alien-Access transform -- Internal @@ -517,7 +745,8 @@ ,(if nv-p new-value lisp-type) ',form)))) -(defknown %%set-alien-access (t unsigned-byte unsigned-byte t t t t) t) +(defknown %%set-alien-access + (system-area-pointer unsigned-byte unsigned-byte t t t t) t) ;;; %%Set-Alien-Access transform -- Internal ;;; @@ -639,14 +868,14 @@ (defun sign-extend (form size &optional (signed t)) (if signed `(let ((res ,form)) - (declare (fixnum res)) (if (zerop (logand res ,(ash 1 (1- size)))) res (logior res ,(ash -1 size)))) form)) -(defknown naturalize-integer (t t unsigned-byte unsigned-byte t) integer +(defknown naturalize-integer + (t system-area-pointer unsigned-byte unsigned-byte t) integer (flushable)) ;;; Naturalize-Integer Transform -- Internal @@ -670,56 +899,76 @@ (let ((align (find-alignment offset)) (size (continuation-value size)) - (signed (continuation-value signed))) + (signed (continuation-value signed)) + (bits (find-bit-offset offset))) (cond - ((or (and (> size 15) (< align 4)) - (and (> size 16) (< align 5))) - (give-up "Could not show ~D bit access to be word-aligned:~%~S" - size (continuation-value form))) - ((= size 32) + ((and (= size 32) (> align 4)) (if signed - '(%primitive signed-32bit-system-ref sap (ash offset -4)) - '(%primitive unsigned-32bit-system-ref sap (ash offset -4)))) - ((= size 16) + '(signed-sap-ref-32 sap (ash offset -5)) + '(sap-ref-32 sap (ash offset -5)))) + ((and (= size 16) (> align 3)) (if signed - '(%primitive signed-16bit-system-ref sap (ash offset -4)) - '(%primitive 16bit-system-ref sap (ash offset -4)))) - ((> size 15) - (compiler-warning "Access of ~D bit bytes is not supported:~%~S" - size (continuation-value form)) - (give-up)) - ((and (> align 2) (= size 8)) - (sign-extend '(%primitive 8bit-system-ref sap (ash offset -3)) - 8 signed)) + '(signed-sap-ref-16 sap (ash offset -4)) + '(sap-ref-16 sap (ash offset -4)))) + ((and (= size 8) (> align 2)) + (if signed + '(signed-sap-ref-8 sap (ash offset -3)) + '(sap-ref-8 sap (ash offset -3)))) + ((not bits) + (give-up "Can't determine offset within word, so cannot open-code:~%~S" + (continuation-value form))) + ((<= (+ bits size) 32) + (sign-extend `(ldb (byte ,size ,bits) + (sap-ref-32 sap (ash offset -5))) + size signed)) + ((> size 32) + (give-up "Accesses of ~D bits unsupported:~%~S" + size (continuation-value form))) (t - (let ((bits (find-bit-offset offset))) - (unless bits - (give-up "Can't determine offset within word, so cannot ~ - open-code:~%~S" - (continuation-value form))) - - (if (>= (+ bits size) 16) - (let* ((hi-bits (- 16 bits)) - (lo-bits (- size hi-bits))) - ;; - ;; If the integer spans a 16bit boundry, then the high bits in - ;; the integer are the low bits in the first word, and the low - ;; bits in the integer are the high bits in the next word. - (sign-extend - `(let ((offset (ash offset -4))) - (logior (ash (ldb (byte ,hi-bits 0) - (sap-ref-16 sap offset)) - ,lo-bits) - (ash (sap-ref-16 sap (1+ offset)) - ,(- (- 16 lo-bits))))) - size signed)) - (sign-extend `(ldb (byte ,size ,bits) - (sap-ref-16 sap (ash offset -4))) - size signed))))))) - - - -(defknown deport-integer (t t unsigned-byte unsigned-byte integer t) void + ;; If the integer spans a boundry, how we combine the two partial results + ;; depends on the target byte order. + ;; + ;; little-endian: + ;; 0 1 2 3 4 5 6 7 + ;; 7 07 07 07 0 + ;; [ ][ ][ ][ ][ ][ ][ ][ ] + ;; 210 543 + ;; We get the low bits from the high part of the first word and + ;; the high bits from the low part of the second word. + ;; + ;; big-endian: + ;; 0 1 2 3 4 5 6 7 + ;; 7 07 07 07 0 + ;; [ ][ ][ ][ ][ ][ ][ ][ ] + ;; 543210 + ;; We get the low bits from the high part of the second word + ;; and the high bits from the low part of the first. + ;; + ;; Therefore, the only difference is which byte to use for what. + ;; What bits to use from each byte is constant. + ;; + ;; We sign extend the high bits instead of the entire value because + ;; it has a higher probability of being a fixnum. + ;; + (let* ((high-bits (- 32 bits)) + (low-bits (- size high-bits))) + (multiple-value-bind (low-byte high-byte) + (ecase vm:target-byte-order + (:little-endian + (values 'offset '(1+ offset))) + (:big-endian + (values '(1+ offset) 'offset))) + `(let ((offset (ash offset -5))) + (logior (ash ,(sign-extend `(ldb (byte ,high-bits 0) + (sap-ref-32 sap ,high-byte)) + size signed) + ,low-bits) + (ash (sap-ref-32 sap ,low-byte) + ,(- (- 32 low-bits))))))))))) + + +(defknown deport-integer + (t system-area-pointer unsigned-byte unsigned-byte integer t) void ()) ;;; Deport-Integer transform -- Internal @@ -732,56 +981,51 @@ (continuation-value form))) (let ((align (find-alignment offset)) - (size (continuation-value size))) + (size (continuation-value size)) + (bits (find-bit-offset offset))) (cond - ((or (and (> size 15) (< align 4)) - (and (> size 16) (< align 5))) - (give-up "Could not show ~D bit access to be word-aligned:~%~S" + ((and (= size 32) (> align 4)) + '(setf (sap-ref-32 sap (ash offset -5)) value)) + ((and (= size 16) (> align 3)) + '(setf (sap-ref-16 sap (ash offset -4)) value)) + ((and (= size 8) (> align 2)) + '(setf (sap-ref-8 sap (ash offset -3)) value)) + ((not bits) + (give-up "Can't determine offset within word, so cannot open-code:~%~S" + (continuation-value form))) + ((<= (+ bits size) 32) + `(setf (ldb (byte ,size ,bits) (sap-ref-32 sap (ash offset -5))) + value)) + ((> size 32) + (give-up "Accesses of ~D bits unsupported:~%~S" size (continuation-value form))) - ((= size 32) - '(%primitive signed-32bit-system-set sap (ash offset -4) value)) - ((= size 16) - '(%primitive 16bit-system-set sap (ash offset -4) value)) - ((> size 15) - (compiler-warning "Access of ~D bit bytes is not supported:~%~S" - size (continuation-value form)) - (give-up)) - ((and (> align 2) (= size 8)) - '(%primitive 8bit-system-set sap (ash offset -3) value)) (t - (let ((bits (find-bit-offset offset))) - (unless bits - (give-up "Can't determine offset within word, so cannot ~ - open-code:~%~S" - (continuation-value form))) - - (if (>= (+ bits size) 16) - (let* ((hi-bits (- 16 bits)) - (lo-bits (- size hi-bits))) - ;; - ;; If the integer spans a 16bit boundry, then the high bits in - ;; the integer are the low bits in the first word, and the low - ;; bits in the integer are the high bits in the next word. - `(let ((offset (ash offset -4))) - (%primitive 16bit-system-set sap offset - (dpb (ash value ,(- lo-bits)) - (byte ,hi-bits 0) - (sap-ref-16 sap offset))) - (%primitive 16bit-system-set sap (1+ offset) - (dpb value - (byte ,lo-bits ,(- 16 lo-bits)) - (sap-ref-16 (1+ offset)))))) - `(let ((offset (ash offset -4))) - (setf (sap-ref-16 sap offset) - (dpb value - (byte ,size ,bits) - (sap-ref-16 sap offset)))))))))) + ;; + ;; If the integer spans a 32 bit boundry, what we do depends on + ;; the byte order. See the comments in naturalize-integer. + ;; + (let* ((high-bits (- 32 bits)) + (low-bits (- size high-bits))) + (multiple-value-bind (low-byte high-byte) + (ecase vm:target-byte-order + (:little-endian + (values 'offset '(1+ offset))) + (:big-endian + (values '(1+ offset) 'offset))) + `(let ((offset (ash offset -5))) + (setf (ldb (byte ,high-bits 0) + (sap-ref-32 sap ,high-byte)) + (ash value ,(- low-bits))) + (setf (ldb (byte ,low-bits ,(- 32 low-bits)) + (sap-ref-32 sap ,low-byte)) + value)))))))) ;;;; Boolean stuff: -(defknown naturalize-boolean (t index index t) boolean (flushable)) -(defknown deport-boolean (t index index t t) void ()) +(defknown naturalize-boolean (system-area-pointer index index t) boolean + (flushable)) +(defknown deport-boolean (system-area-pointer index index t t) void ()) ;;; Naturalize and Deport Boolean transforms -- Internal ;;; @@ -822,10 +1066,7 @@ (continuation-value form))) (if (= size 1) `(let ((offset (ash offset -3))) - (setf (sap-ref-8 sap offset) - (let ((old (sap-ref-8 sap offset))) - (if value - (logior old ,(ash 1 (- 7 off))) - (logand old ,(lognot (ash 1 (- 7 off)))))))) + (setf (ldb (byte 1 ,off) (sap-ref-8 sap offset)) + (if value 1 0))) `(deport-integer nil sap offset ,size (if value 1 0) ',(continuation-value form))))) diff --git a/compiler/codegen.lisp b/compiler/codegen.lisp index f91233bfe..14f8ba758 100644 --- a/compiler/codegen.lisp +++ b/compiler/codegen.lisp @@ -18,6 +18,15 @@ ;;;; Utilities used during code generation. +;;; Component-Header-Length -- Interface +;;; +(defun component-header-length (&optional (component *compile-component*)) + "Returns the number of bytes used by the code object header." + (let* ((2comp (component-info component)) + (constants (ir2-component-constants 2comp)) + (num-consts (length constants))) + (ash (logandc2 (1+ num-consts) 1) vm:word-shift))) + ;;; SB-Allocated-Size -- Interface ;;; (defun sb-allocated-size (name) @@ -58,6 +67,18 @@ (ir2-environment-return-pc-pass 2env)) +;;;; Generate-code and support routines. + +(defvar *code-segment* nil) +(defvar *elsewhere* nil) + +;;; Init-Assembler -- Interface +;;; +(defun init-assembler () + (setf *code-segment* (make-segment)) + (setf *elsewhere* (make-segment)) + (undefined-value)) + ;;; Generate-Code -- Interface ;;; (defun generate-code (component) @@ -66,7 +87,8 @@ (let ((1block (ir2-block-block block))) (when (and (eq (block-info 1block) block) (block-start 1block)) - (emit-label (block-label 1block)) + (assemble (*code-segment* nil) + (emit-label (block-label 1block))) (let ((env (block-environment 1block))) (unless (eq env prev-env) (let ((lab (gen-label))) @@ -82,5 +104,15 @@ (funcall gen vop) (format t "Missing generator for ~S.~%" (template-name (vop-info vop)))))))) + (assemble (*code-segment* nil) + (insert-segment *elsewhere*)) + (finalize-segment *code-segment*)) + + +(defun emit-label-elsewhere (label) + (assemble (*elsewhere* nil) + (emit-label label))) + - (finish-assembly)) +(defun label-elsewhere-p (label) + (<= (label-position *elsewhere*) (label-position label))) diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp index 0565691bc..7b678c706 100644 --- a/compiler/debug-dump.lisp +++ b/compiler/debug-dump.lisp @@ -110,7 +110,7 @@ 0) *byte-buffer*) - (let ((loc (label-location label))) + (let ((loc (label-position label))) (write-var-integer (- loc *previous-location*) *byte-buffer*) (setq *previous-location* loc)) @@ -498,9 +498,8 @@ ;;; at some particular time (after assembly) so that source map information is ;;; available. ;;; -(defun debug-info-for-component (component assem-nodes count) - (declare (type component component) (simple-vector assem-nodes) - (type index count)) +(defun debug-info-for-component (component) + (declare (type component component)) (let ((level (cookie-debug *default-cookie*)) (res (make-compiled-debug-info :name (component-name component) :package (package-name *package*)))) @@ -525,11 +524,11 @@ (ir2-environment-return-pc 2env)) :old-fp (tn-sc-offset (ir2-environment-old-fp 2env)) - :start-pc (label-location + :start-pc (label-position (ir2-environment-environment-start 2env)) :elsewhere-pc - (label-location + (label-position (ir2-environment-elsewhere-start 2env))))) (when (>= level 1) @@ -556,7 +555,7 @@ (setf (compiled-debug-function-returns dfun) (compute-debug-returns fun))))))) - (dfuns (cons (label-location + (dfuns (cons (label-position (block-label (node-block (lambda-bind fun)))) diff --git a/compiler/debug.lisp b/compiler/debug.lisp index 32a9f1fb2..9081885e3 100644 --- a/compiler/debug.lisp +++ b/compiler/debug.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug.lisp,v 1.13 1990/08/24 18:35:02 wlott Exp $ +;;; ;;; Utilities for debugging the compiler. Currently contains only stuff for ;;; checking the consistency of the IR1. ;;; @@ -1065,15 +1067,22 @@ (defun print-tn (tn &optional (stream *standard-output*)) (declare (type tn tn)) (let ((leaf (tn-leaf tn))) - (cond (leaf + (cond #-new-compiler + (leaf (xp::princ (with-output-to-string (stream) (print-leaf leaf stream)) stream) (xp::format stream "!~D" (tn-id tn))) + #+new-compiler + (leaf + (print-leaf leaf stream) + (format stream "!~D" (tn-id tn))) (t - (xp::format stream "t~D" (tn-id tn)))) + (#-new-compiler xp::format #+new-compiler format + stream "t~D" (tn-id tn)))) (when (and (tn-sc tn) (tn-offset tn)) - (xp::format stream "[~A]" (location-print-name tn))))) + (#-new-compiler xp::format #+new-compiler format + stream "[~A]" (location-print-name tn))))) ;;; Print-Operands -- Internal @@ -1083,7 +1092,8 @@ ;;; (defun print-operands (refs) (declare (type (or tn-ref null) refs)) - (xp:within-logical-block (nil nil) + (#-new-compiler xp:within-logical-block #-new-compiler (nil nil) + #+new-compiler progn (do ((ref refs (tn-ref-across ref))) ((null ref)) (let ((tn (tn-ref-tn ref)) @@ -1092,9 +1102,11 @@ (print-tn tn)) (t (print-tn tn) - (xp::princ (if (tn-ref-write-p ref) #\< #\>)) + (#-new-compiler xp::princ #+new-compiler princ + (if (tn-ref-write-p ref) #\< #\>)) (print-tn ltn))) - (xp::princ #\space) + (#-new-compiler xp::princ #+new-compiler princ #\space) + #-new-compiler (xp:conditional-newline :fill))))) @@ -1103,6 +1115,7 @@ ;;; Print the vop on a single line. ;;; (defun print-vop (vop) + #-new-compiler (xp:within-logical-block (nil nil) (xp::princ (vop-info-name (vop-info vop))) (xp::princ #\space) @@ -1118,7 +1131,21 @@ (when (vop-results vop) (xp::princ "=> ") (print-operands (vop-results vop)))) - (xp::terpri)) + #-new-compiler + (xp::terpri) + #+new-compiler + (progn + (princ (vop-info-name (vop-info vop))) + (princ #\space) + (print-operands (vop-args vop)) + (when (vop-codegen-info vop) + (let ((*print-level* 1) + (*print-length* 3)) + (format t "{~{~S~^ ~}} " (vop-codegen-info vop)))) + (when (vop-results vop) + (princ "=> ") + (print-operands (vop-results vop))) + (terpri))) ;;; Print-IR2-Block -- Internal ;;; diff --git a/compiler/eval.lisp b/compiler/eval.lisp index 851f78d0d..c459f4ce4 100644 --- a/compiler/eval.lisp +++ b/compiler/eval.lisp @@ -7,6 +7,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/eval.lisp,v 1.13 1990/08/24 18:35:11 wlott Exp $ +;;; ;;; This file contains the interpreter. We first convert to the compiler's ;;; IR1 and interpret that. ;;; @@ -254,7 +256,7 @@ (declare (ignore ig1 ig2)) res)) ;;; -(defun (setf interpreted-function-name) (x val) +(defun (setf interpreted-function-name) (val x) (let* ((eval-fun (get-eval-function x)) (def (eval-function-definition eval-fun))) (when def @@ -266,7 +268,7 @@ (defun interpreted-function-arglist (x) (eval-function-arglist (get-eval-function x))) ;;; -(defun (setf interpreted-function-arglist) (x val) +(defun (setf interpreted-function-arglist) (val x) (setf (eval-function-arglist (get-eval-function x)) val)) @@ -464,7 +466,7 @@ ;; binding mechanism to unbind one variable. (eval-stack-pop) (maybe-trace-funny-fun node ,name) - (system:%primitive unbind 1)) + (system:%primitive unbind)) (c::%catch (let* ((tag (eval-stack-pop)) (nlx-info (eval-stack-pop)) diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp index 1d9a2a0dc..23ee289f5 100644 --- a/compiler/fndb.lisp +++ b/compiler/fndb.lisp @@ -7,15 +7,17 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.10 1990/08/24 18:35:19 wlott Exp $ +;;; ;;; This file defines all the standard functions to be known functions. ;;; Each function has type and side-effect information, and may also have IR1 ;;; optimizers. ;;; ;;; Written by Rob MacLachlan ;;; -(in-package 'c) +(in-package "C") -(in-package 'lisp) +(in-package "LISP") (import '( %aset %bitset @@ -29,6 +31,7 @@ %set-documentation %set-fdefinition %set-fill-pointer + %set-row-major-aref %setelt %setnth %sp-set-definition @@ -39,6 +42,7 @@ %typep %array-typep array-header-p + base-char-p double-float-p long-float-p short-float-p @@ -385,21 +389,13 @@ (defknown character (t) character (movable foldable flushable)) (defknown char-code (character) char-code (movable foldable flushable)) -(defknown char-bits (character) char-bits (movable foldable flushable)) -(defknown char-font (character) char-font (movable foldable flushable)) -(defknown code-char (char-code &optional char-bits char-font) - character (movable foldable flushable)) -(defknown make-char (character &optional char-bits char-font) - character (movable foldable flushable)) +(defknown code-char (char-code) base-character (movable foldable flushable)) (defknown (char-upcase char-downcase) (character) character (movable foldable flushable)) (defknown digit-char (integer &optional integer char-bits) (or character null) (movable foldable flushable)) -(defknown char-int (character) char-int (movable foldable flushable)) -(defknown int-char (char-int) character (movable foldable flushable)) +(defknown char-int (character) char-code (movable foldable flushable)) (defknown char-name (character) (or simple-string null) (movable foldable flushable)) (defknown name-char (stringable) (or character null) (movable foldable flushable)) -(defknown char-bit (character bit-names) boolean (movable foldable flushable)) -(defknown set-char-bit (character bit-names t) character (movable foldable flushable)) ;;;; In the "Sequences" chapter: @@ -681,6 +677,7 @@ (defknown vector (&rest t) simple-vector (flushable unsafe)) (defknown aref (array &rest index) t (foldable flushable)) +(defknown row-major-aref (array index) t (foldable flushable)) (defknown array-element-type (array) type-specifier (foldable flushable)) (defknown array-rank (array) array-rank (foldable flushable)) @@ -725,8 +722,8 @@ ;;;; In the "Strings" chapter: -(defknown char (string index) string-char (foldable flushable)) -(defknown schar (simple-string index) string-char (foldable flushable)) +(defknown char (string index) character (foldable flushable)) +(defknown schar (simple-string index) character (foldable flushable)) (defknown (string= string-equal) (stringlike stringlike &key (start1 index) (end1 sequence-end) @@ -742,7 +739,7 @@ (or index null) (foldable flushable)) -(defknown make-string (index &key (initial-element string-char)) +(defknown make-string (index &key (initial-element character)) simple-string (flushable)) (defknown (string-trim string-left-trim string-right-trim) @@ -943,8 +940,8 @@ (defknown file-length (stream) (or unsigned-byte null) (flushable)) (defknown load - (filename &key (verbose t) (print t) - (if-does-not-exist (member :error :create nil))) + ((or filename stream) + &key (verbose t) (print t) (if-does-not-exist (member :error :create nil))) t) (defknown directory (pathnamelike &key) list (flushable)) @@ -1044,8 +1041,12 @@ (defknown (%dpb %deposit-field) (integer bit-index bit-index integer) integer (movable foldable flushable)) (defknown %negate (number) number (movable foldable flushable)) +(defknown %check-bound (array index fixnum) index (movable foldable flushable)) +(defknown data-vector-ref (array index) t (foldable flushable)) +(defknown data-vector-set (array index t) t (unsafe)) (defknown kernel:%caller-frame-and-pc () (values t t) (flushable)) + ;;; Structure slot accessors or setters are magically "known" to be these ;;; functions, although the var remains the Slot-Accessor describing the actual ;;; function called. @@ -1057,6 +1058,7 @@ ;;;; Setf inverses: (defknown %aset (array &rest t) t (unsafe)) +(defknown %set-row-major-aref (array index t) t (unsafe)) (defknown %rplaca (cons t) t (unsafe)) (defknown %rplacd (cons t) t (unsafe)) (defknown %put (symbol t t) t (unsafe)) @@ -1064,8 +1066,8 @@ (defknown %svset (simple-vector index t) t (unsafe)) (defknown %bitset (bit-vector index bit) bit (unsafe)) (defknown %sbitset (simple-bit-vector index bit) bit (unsafe)) -(defknown %charset (string index string-char) string-char (unsafe)) -(defknown %scharset (simple-string index string-char) string-char (unsafe)) +(defknown %charset (string index character) character (unsafe)) +(defknown %scharset (simple-string index character) character (unsafe)) (defknown %sp-set-definition (symbol function) function (unsafe)) (defknown %sp-set-plist (symbol t) t (unsafe)) (defknown %set-documentation @@ -1082,8 +1084,8 @@ ;;; into non-standard unary predicates. (defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p - long-float-p %string-char-p %standard-char-p structurep - array-header-p) + long-float-p base-char-p %string-char-p %standard-char-p structurep + array-header-p) (t) boolean (movable foldable flushable)) diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp index 3dd36eb8b..8b09890ba 100644 --- a/compiler/ir1opt.lisp +++ b/compiler/ir1opt.lisp @@ -825,6 +825,8 @@ :argument-test #'types-intersect :result-test #'values-types-intersect)) (setf (gethash node *failed-optimizations*) type) + t) + (t t)))) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index eab285153..d615e62ce 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -1468,7 +1468,7 @@ :name name :type (specifier-type (if (listp name) - `(function (,type ,slot-type) ,slot-type) + `(function (,slot-type ,type) ,slot-type) `(function (,type) ,slot-type))) :for info :slot slot))) @@ -2416,7 +2416,7 @@ (unless (dsd-read-only slot) (process-1-ftype-proclamation `(setf ,fun) - (specifier-type `(function (,name ,type) ,type)))))) + (specifier-type `(function (,type ,name) ,type)))))) (collect ((forms)) (when copier diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp index 4f601fb5d..ee778a30a 100644 --- a/compiler/ir2tran.lisp +++ b/compiler/ir2tran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.19 1990/08/16 16:16:50 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.20 1990/08/24 18:35:51 wlott Exp $ ;;; ;;; This file contains the virtual machine independent parts of the code ;;; which does the actual translation of nodes to VOPs. @@ -202,7 +202,7 @@ (closure (environment-closure (lambda-environment leaf)))) (vop make-closure node block (emit-constant (length closure)) entry res) - (let ((n (1- system:%function-closure-variables-offset))) + (let ((n -1)) (dolist (what closure) (vop closure-init node block res (find-in-environment what this-env) @@ -1072,21 +1072,22 @@ ;;; (defun init-xep-environment (node block fun) (declare (type bind node) (type ir2-block block) (type clambda fun)) - (vop xep-allocate-frame node block (entry-info-offset (leaf-info fun))) - (let ((ef (functional-entry-function fun))) - (when (and (optional-dispatch-p ef) - (optional-dispatch-more-entry ef)) - (vop copy-more-arg node block (optional-dispatch-max-args ef)))) - - (let ((env (environment-info (node-environment node)))) + (let ((start-label (entry-info-offset (leaf-info fun))) + (env (environment-info (node-environment node)))) + (vop xep-allocate-frame node block start-label) + (let ((ef (functional-entry-function fun))) + (when (and (optional-dispatch-p ef) + (optional-dispatch-more-entry ef)) + (vop copy-more-arg node block (optional-dispatch-max-args ef)))) + (if (ir2-environment-environment env) (let ((closure (make-normal-tn *any-primitive-type*))) - (vop setup-closure-environment node block closure) - (let ((n (1- system:%function-closure-variables-offset))) + (vop setup-closure-environment node block start-label closure) + (let ((n -1)) (dolist (loc (ir2-environment-environment env)) (vop closure-ref node block closure (incf n) (cdr loc))))) - (vop setup-environment node block)) - + (vop setup-environment node block start-label)) + (unless (eq (functional-kind fun) :top-level) (let ((vars (lambda-vars fun)) (n 0)) @@ -1104,7 +1105,7 @@ (emit-move node block (make-old-fp-passing-location t) (ir2-environment-old-fp env))) - + (undefined-value)) @@ -1328,7 +1329,7 @@ (emit-constant name)))) ;;; (defoptimizer (%special-unbind ir2-convert) ((var) node block) - (vop unbind node block (emit-constant 1))) + (vop unbind node block)) ;;; PROGV IR1 convert -- Internal @@ -1412,9 +1413,8 @@ ;;; ;;; Emit code to set up a non-local-exit. Info is the NLX-Info for the ;;; exit, and Tag is the continuation for the catch tag (if any.) We get at -;;; the entry PC by making a :Label load-time constant TN. This is a -;;; non-immediate constant TN that is initialized to the offset of the -;;; specified label. +;;; the target PC by passing in the label to the vop. The vop is responsible +;;; for building a return-PC object. ;;; (defun emit-nlx-start (node block info tag) (declare (type node node) (type ir2-block block) (type nlx-info info) @@ -1424,11 +1424,8 @@ (block-tn (environment-live-tn (make-normal-tn (primitive-type-or-lose 'catch-block)) (node-environment node))) - (res (make-normal-tn *any-primitive-type*)) - (target-tn - (make-load-time-constant-tn - :label - (block-label (nlx-info-target info))))) + (res (make-stack-pointer-tn)) + (target-label (ir2-nlx-info-target 2info))) (vop* save-dynamic-state node block (nil) @@ -1438,9 +1435,9 @@ (ecase kind (:catch (vop make-catch-block node block block-tn - (continuation-tn node block tag) target-tn res)) - ((:unwind-protect :block :tagbody) - (vop make-unwind-block node block block-tn target-tn res))) + (continuation-tn node block tag) target-label res)) + ((:unwind-protect :entry) + (vop make-unwind-block node block block-tn target-label res))) (ecase kind ((:block :tagbody) @@ -1508,23 +1505,26 @@ (2info (nlx-info-info info)) (top-loc (ir2-nlx-info-save-sp 2info)) (start-loc (make-old-fp-passing-location t)) - (count-loc (make-argument-count-location))) + (count-loc (make-argument-count-location)) + (target (ir2-nlx-info-target 2info))) (ecase (cleanup-kind (nlx-info-cleanup info)) ((:catch :block :tagbody) (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) (vop* nlx-entry-multiple node block (top-loc start-loc count-loc nil) - ((reference-tn-list (ir2-continuation-locs 2cont) t))) + ((reference-tn-list (ir2-continuation-locs 2cont) t)) + target) (let ((locs (standard-result-tns cont))) (vop* nlx-entry node block (top-loc start-loc count-loc nil) ((reference-tn-list locs t)) + target (length locs)) (move-continuation-result node block locs cont)))) (:unwind-protect (let ((block-loc (standard-argument-location 0))) - (vop uwp-entry node block block-loc start-loc count-loc) + (vop uwp-entry node block target block-loc start-loc count-loc) (move-continuation-result node block (list block-loc start-loc count-loc) @@ -1569,7 +1569,7 @@ (first res)) (move-continuation-result node block res cont))) -(defoptimizer (%slot-setter ir2-convert) ((str value) node block) +(defoptimizer (%slot-setter ir2-convert) ((value str) node block) (let ((val (continuation-tn node block value))) (vop structure-set node block (continuation-tn node block str) diff --git a/compiler/main.lisp b/compiler/main.lisp index bfc8fa9cb..fb04e72da 100644 --- a/compiler/main.lisp +++ b/compiler/main.lisp @@ -165,7 +165,9 @@ (loop-analyze component) |# - (let ((*compile-component* component)) + (let ((*compile-component* component) + (*code-segment* nil) + (*elsewhere* nil)) (maybe-mumble "Env ") (environment-analyze component) (maybe-mumble "GTN ") @@ -216,22 +218,26 @@ (describe-component component *compiler-trace-output*)) (maybe-mumble "Code ") - (generate-code component)) - - (etypecase object - (fasl-file - (maybe-mumble "FASL") - (fasl-dump-component component *code-vector* *next-location* - *assembler-nodes* (1+ *current-assembler-node*) - *result-fixups* object)) - (core-object - (maybe-mumble "Core" - (make-core-component component *code-vector* *next-location* - *assembler-nodes* (1+ *current-assembler-node*) - *result-fixups* object))) - (null)) - - (compiler-mumble "~%") + (let ((length (generate-code component))) + + (when *compiler-trace-output* + (format *compiler-trace-output* + "~|~%Assembly code for ~S~2%" + component) + (dump-segment *code-segment* *compiler-trace-output*)) + + (etypecase object + (fasl-file + (maybe-mumble "FASL") + (fasl-dump-component component *code-segment* length object)) + (core-object + (maybe-mumble "Core") + (make-core-component component *code-segment* length object)) + (null)) + + (nuke-segment *code-segment*))) + + (compiler-mumble "~&") (undefined-value)) @@ -716,7 +722,9 @@ (cond (*block-compile* (push tll *top-level-lambdas*)) (t (compile-top-level (list tll) object) - (clear-stuff))))) + (clear-stuff)))) + #+new-compiler + (lisp::maybe-gc)) ;;; PROCESS-PROGN -- Internal @@ -1116,7 +1124,8 @@ (pathname file)))) (when output-file - (setq output-file-name (frob output-file "nfasl")) + (setq output-file-name + (frob output-file vm:target-fasl-file-type)) (setq fasl-file (open-fasl-file output-file-name (namestring (first source))))) diff --git a/compiler/vmdef.lisp b/compiler/vmdef.lisp index 373e6a8cd..c481ff7bb 100644 --- a/compiler/vmdef.lisp +++ b/compiler/vmdef.lisp @@ -282,7 +282,7 @@ (setf (svref (sc-load-costs to-sc) num) ',cost))))) (defun ,name ,lambda-list - (assemble (vop-node ,(first lambda-list)) + (assemble (*code-segment* ,(first lambda-list)) ,@body)))) @@ -1209,7 +1209,7 @@ ,@(binds)) (declare (ignore ,@(vop-parse-ignores parse))) ,@(loads) - (assemble (vop-node ,n-vop) + (assemble (*code-segment* ,n-vop) ,@(vop-parse-body parse)) ,@(saves)))))) -- GitLab