X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Faliencomp.lisp;h=36226af6afeae31291c8b07bb21abe0ce604e2e0;hb=e0aff99a73d836da0dad4602e5559595fbe5ba5c;hp=3635cb4c16437a247eca371451bb0180502a816d;hpb=70c6facc145eaf5ca368528b04df63f730746b1f;p=sbcl.git diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 3635cb4..36226af 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -190,6 +190,8 @@ (abort-ir1-transform "too many indices for pointer deref: ~W" (length indices))) (let ((element-type (alien-pointer-type-to alien-type))) + (unless element-type + (give-up-ir1-transform "unable to open code deref of wild pointer type")) (if indices (let ((bits (alien-type-bits element-type)) (alignment (alien-type-alignment element-type))) @@ -337,9 +339,12 @@ ;;;; support for local (stack or register) aliens -(deftransform make-local-alien ((info) * * :important t) +(defun alien-info-constant-or-abort (info) (unless (constant-lvar-p info) - (abort-ir1-transform "Local alien info isn't constant?")) + (abort-ir1-transform "Local alien info isn't constant?"))) + +(deftransform make-local-alien ((info) * * :important t) + (alien-info-constant-or-abort info) (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info)) (bits (alien-type-bits alien-type))) @@ -371,10 +376,7 @@ (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 - ;; could be factored into a function. - (unless (constant-lvar-p info) - (abort-ir1-transform "Local alien info isn't constant?")) + (alien-info-constant-or-abort info) (let ((info (lvar-value info))) (/noshow "in DEFTRANSFORM NOTE-LOCAL-ALIEN-TYPE" info) (/noshow (local-alien-info-force-to-memory-p info)) @@ -389,8 +391,7 @@ nil) (deftransform local-alien ((info var) * * :important t) - (unless (constant-lvar-p info) - (abort-ir1-transform "Local alien info isn't constant?")) + (alien-info-constant-or-abort info) (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (/noshow "in DEFTRANSFORM LOCAL-ALIEN" info alien-type) @@ -400,14 +401,12 @@ `(naturalize var ',alien-type)))) (deftransform %local-alien-forced-to-memory-p ((info) * * :important t) - (unless (constant-lvar-p info) - (abort-ir1-transform "Local alien info isn't constant?")) + (alien-info-constant-or-abort info) (let ((info (lvar-value info))) (local-alien-info-force-to-memory-p info))) (deftransform %set-local-alien ((info var value) * * :important t) - (unless (constant-lvar-p info) - (abort-ir1-transform "Local alien info isn't constant?")) + (alien-info-constant-or-abort info) (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (if (local-alien-info-force-to-memory-p info) @@ -422,8 +421,7 @@ *wild-type*)) (deftransform %local-alien-addr ((info var) * * :important t) - (unless (constant-lvar-p info) - (abort-ir1-transform "Local alien info isn't constant?")) + (alien-info-constant-or-abort info) (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (/noshow "in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN") @@ -432,8 +430,7 @@ (error "This shouldn't happen.")))) (deftransform dispose-local-alien ((info var) * * :important t) - (unless (constant-lvar-p info) - (abort-ir1-transform "Local alien info isn't constant?")) + (alien-info-constant-or-abort info) (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) (if (local-alien-info-force-to-memory-p info) @@ -621,14 +618,16 @@ (declaim (inline invoke-with-saved-fp-and-pc)) #!+:c-stack-is-control-stack (defun invoke-with-saved-fp-and-pc (fn) - (let* ((fp-and-pc (multiple-value-bind (fp pc) - (%caller-frame-and-pc) - (cons fp pc))) - (*saved-fp-and-pcs* (if (boundp '*saved-fp-and-pcs*) - (cons fp-and-pc *saved-fp-and-pcs*) - (list fp-and-pc)))) - (declare (truly-dynamic-extent fp-and-pc *saved-fp-and-pcs*)) - (funcall fn))) + (declare #-sb-xc-host (muffle-conditions compiler-note) + (optimize (speed 3))) + (let* ((fp-and-pc (cons (%caller-frame) + (sap-int (%caller-pc))))) + (declare (truly-dynamic-extent fp-and-pc)) + (let ((*saved-fp-and-pcs* (if (boundp '*saved-fp-and-pcs*) + (cons fp-and-pc *saved-fp-and-pcs*) + (list fp-and-pc)))) + (declare (truly-dynamic-extent *saved-fp-and-pcs*)) + (funcall fn)))) (defun find-saved-fp-and-pc (fp) (when (boundp '*saved-fp-and-pcs*) @@ -640,7 +639,7 @@ (int-sap (get-lisp-obj-address (car x))) fp) (return (values (car x) (cdr x))))))) -(deftransform alien-funcall ((function &rest args) * * :important t) +(deftransform alien-funcall ((function &rest args) * * :node node :important t) (let ((type (lvar-type function))) (unless (alien-type-type-p type) (give-up-ir1-transform "can't tell function type at compile time")) @@ -698,9 +697,11 @@ ;; to it later regardless of how the foreign stack looks ;; like. #!+:c-stack-is-control-stack - (setf body `(invoke-with-saved-fp-and-pc (lambda () ,body))) + (when (policy node (= 3 alien-funcall-saves-fp-and-pc)) + (setf body `(invoke-with-saved-fp-and-pc (lambda () ,body)))) (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body) `(lambda (function ,@(params)) + (declare (optimize (let-conversion 3))) ,body))))))) (defoptimizer (%alien-funcall derive-type) ((function type &rest args)) @@ -712,7 +713,8 @@ (error "Something is broken.")) (values-specifier-type (compute-alien-rep-type - (alien-fun-type-result-type type))))) + (alien-fun-type-result-type type) + :result)))) (defoptimizer (%alien-funcall ltn-annotate) ((function type &rest args) node ltn-policy)