call for functions already inline converted there, but he is not sure
if this has adverse effects elsewhere.
-427: ANY-REG not good for primitive type T
-
- ...which is true, of course, but the following should not complain
- about it (on x86 and x86-64):
-
- (sb-alien:with-alien ((buf (array (sb-alien:signed 8) 16))))
-
- reported by Stelian Ionescu on sbcl-devel.
-
428: TIMER SCHEDULE-STRESS in timer.impure.lisp fails
Failure modes vary. Core problem seems to be (?) recursive entry to
;;;; -*- coding: utf-8; -*-
+changes in sbcl-1.0.20 relative to 1.0.19:
+ * bug fix: fixed #427: unused local aliens no longer cause compiler
+ breakage. (reported by Stelian Ionescu, Andy Hefner and Stanislaw
+ Halik)
+
changes in sbcl-1.0.19 relative to 1.0.18:
* new feature: user-customizable variable SB-EXT:*MUFFLED-WARNINGS*;
warnings that go otherwise unhandled will be muffled if they are
(unless (zerop (rem offset n-word-bytes))
(error "Unaligned instruction? offset=#x~X." offset))
(sb!sys:without-gcing
- (let ((sap (truly-the system-area-pointer
- (%primitive code-instructions code))))
+ (let ((sap (%primitive code-instructions code)))
(ecase kind
(:jmp-hint
(aver (zerop (ldb (byte 2 0) value)))
(unless (zerop (rem offset n-word-bytes))
(error "Unaligned instruction? offset=#x~X." offset))
(sb!sys:without-gcing
- (let* ((sap (truly-the system-area-pointer
- (%primitive sb!kernel::code-instructions code)))
+ (let* ((sap (%primitive sb!kernel::code-instructions code))
(inst (sap-ref-32 sap offset)))
(setf (sap-ref-32 sap offset)
(ecase kind
(unless (zerop (rem offset n-word-bytes))
(error "Unaligned instruction? offset=#x~X." offset))
(sb!sys:without-gcing
- (let ((sap (truly-the system-area-pointer
- (%primitive sb!c::code-instructions code))))
+ (let ((sap (%primitive sb!c::code-instructions code)))
(ecase kind
(:jump
(aver (zerop (ash value -28)))
(unless (zerop (rem offset n-word-bytes))
(error "Unaligned instruction? offset=#x~X." offset))
(sb!sys:without-gcing
- (let ((sap (truly-the system-area-pointer
- (%primitive sb!kernel::code-instructions code))))
+ (let ((sap (%primitive sb!kernel::code-instructions code)))
(ecase kind
(:b
(error "Can't deal with CALL fixups, yet."))
(lambda (obj type size)
(when (eql type code-header-widetag)
(let ((words (truly-the fixnum (%code-code-size obj)))
- (sap (truly-the system-area-pointer
- (%primitive code-instructions obj)))
+ (sap (%primitive code-instructions obj))
(size size))
(declare (fixnum size))
(incf total-bytes size)
(unless (zerop (rem offset n-word-bytes))
(error "Unaligned instruction? offset=#x~X." offset))
(sb!sys:without-gcing
- (let ((sap (truly-the system-area-pointer
- (%primitive sb!kernel::code-instructions code))))
+ (let ((sap (%primitive sb!kernel::code-instructions code)))
(ecase kind
(:call
(error "Can't deal with CALL fixups, yet."))
(/noshow (local-alien-info-force-to-memory-p info))
(/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
(if (local-alien-info-force-to-memory-p info)
- #!+(or x86 x86-64)
- `(truly-the system-area-pointer
- (%primitive alloc-alien-stack-space
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits)))
- #!-(or x86 x86-64)
- `(truly-the system-area-pointer
- (%primitive alloc-number-stack-space
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits)))
- (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
- (alien-rep-type (specifier-type alien-rep-type-spec)))
- (cond ((csubtypep (specifier-type 'system-area-pointer)
- alien-rep-type)
- '(int-sap 0))
- ((ctypep 0 alien-rep-type) 0)
- ((ctypep 0.0f0 alien-rep-type) 0.0f0)
- ((ctypep 0.0d0 alien-rep-type) 0.0d0)
- (t
- (compiler-error
- "Aliens of type ~S cannot be represented immediately."
- (unparse-alien-type alien-type))))))))
+ #!+(or x86 x86-64)
+ `(%primitive alloc-alien-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits))
+ #!-(or x86 x86-64)
+ `(%primitive alloc-number-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits))
+ (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
+ (alien-rep-type (specifier-type alien-rep-type-spec)))
+ (cond ((csubtypep (specifier-type 'system-area-pointer)
+ alien-rep-type)
+ '(int-sap 0))
+ ((ctypep 0 alien-rep-type) 0)
+ ((ctypep 0.0f0 alien-rep-type) 0.0f0)
+ ((ctypep 0.0d0 alien-rep-type) 0.0d0)
+ (t
+ (compiler-error
+ "Aliens of type ~S cannot be represented immediately."
+ (unparse-alien-type alien-type))))))))
(deftransform note-local-alien-type ((info var) * * :important t)
;; FIXME: This test and error occur about a zillion times. They
(ir2-convert-conditional node block (template-or-lose 'if-eq)
test-ref () node t)))
-;;; Return a list of primitive-types that we can pass to
-;;; LVAR-RESULT-TNS describing the result types we want for a
-;;; template call. We duplicate here the determination of output type
-;;; that was done in initially selecting the template, so we know that
-;;; the types we find are allowed by the template output type
-;;; restrictions.
-(defun find-template-result-types (call template rtypes)
- (declare (type combination call)
- (type template template) (list rtypes))
- (declare (ignore template))
- (let* ((dtype (node-derived-type call))
- (type dtype)
- (types (mapcar #'primitive-type
- (if (values-type-p type)
- (append (values-type-required type)
- (values-type-optional type))
- (list type)))))
- (let ((nvals (length rtypes))
- (ntypes (length types)))
- (cond ((< ntypes nvals)
- (append types
- (make-list (- nvals ntypes)
- :initial-element *backend-t-primitive-type*)))
- ((> ntypes nvals)
- (subseq types 0 nvals))
- (t
- types)))))
-
-;;; Return a list of TNs usable in a CALL to TEMPLATE delivering
-;;; values to LVAR. As an efficiency hack, we pick off the common case
-;;; where the LVAR is fixed values and has locations that satisfy the
-;;; result restrictions. This can fail when there is a type check or a
-;;; values count mismatch.
-(defun make-template-result-tns (call lvar template rtypes)
+;;; Return a list of primitive-types that we can pass to LVAR-RESULT-TNS
+;;; describing the result types we want for a template call. We are really
+;;; only interested in the number of results required: in normal case
+;;; TEMPLATE-RESULTS-OK has already checked them.
+(defun find-template-result-types (call rtypes)
+ (let* ((type (node-derived-type call))
+ (types
+ (mapcar #'primitive-type
+ (if (values-type-p type)
+ (append (args-type-required type)
+ (args-type-optional type))
+ (list type))))
+ (primitive-t *backend-t-primitive-type*))
+ (loop for rtype in rtypes
+ for type = (or (pop types) primitive-t)
+ collect type)))
+
+;;; Return a list of TNs usable in a CALL to TEMPLATE delivering values to
+;;; LVAR. As an efficiency hack, we pick off the common case where the LVAR is
+;;; fixed values and has locations that satisfy the result restrictions. This
+;;; can fail when there is a type check or a values count mismatch.
+(defun make-template-result-tns (call lvar rtypes)
(declare (type combination call) (type (or lvar null) lvar)
- (type template template) (list rtypes))
+ (list rtypes))
(let ((2lvar (when lvar (lvar-info lvar))))
(if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed))
(let ((locs (ir2-lvar-locs 2lvar)))
(if (and (= (length rtypes) (length locs))
(do ((loc locs (cdr loc))
- (rtype rtypes (cdr rtype)))
+ (rtypes rtypes (cdr rtypes)))
((null loc) t)
(unless (operand-restriction-ok
- (car rtype)
+ (car rtypes)
(tn-primitive-type (car loc))
:t-ok nil)
(return nil))))
locs
(lvar-result-tns
lvar
- (find-template-result-types call template rtypes))))
+ (find-template-result-types call rtypes))))
(lvar-result-tns
lvar
- (find-template-result-types call template rtypes)))))
+ (find-template-result-types call rtypes)))))
;;; Get the operands into TNs, make TN-REFs for them, and then call
;;; the template emit function.
(if (eq rtypes :conditional)
(ir2-convert-conditional call block template args info-args
(lvar-dest lvar) nil)
- (let* ((results (make-template-result-tns call lvar template rtypes))
+ (let* ((results (make-template-result-tns call lvar rtypes))
(r-refs (reference-tn-list results t)))
(aver (= (length info-args)
(template-info-arg-count template)))
(info (lvar-value info))
(lvar (node-lvar call))
(rtypes (template-result-types template))
- (results (make-template-result-tns call lvar template rtypes))
+ (results (make-template-result-tns call lvar rtypes))
(r-refs (reference-tn-list results t)))
(multiple-value-bind (args info-args)
(reference-args call block (cddr (combination-args call)) template)
(move-lvar-result call block results lvar)))
(values))
+
+(defoptimizer (%%primitive derive-type) ((template info &rest args))
+ (let ((type (template-type (lvar-value template))))
+ (if (fun-type-p type)
+ (fun-type-returns type)
+ *wild-type*)))
\f
;;;; local call
(error ()
:ok)))))
+;;; Unused local alien caused a compiler error
+(with-test (:name unused-local-alien)
+ (let ((fun `(lambda ()
+ (sb-alien:with-alien ((alien1923 (array (sb-alien:unsigned 8) 72)))
+ (values)))))
+ (assert (not (funcall (compile nil fun))))))
+
;;; success
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.19"
+"1.0.19.1"
projects / sbcl.git / commitdiff