Skip to content
Snippets Groups Projects
Commit 8f8522b5 authored by ram's avatar ram
Browse files

Updated to understand function header subtypes.

parent 16466914
No related branches found
No related tags found
No related merge requests found
...@@ -289,7 +289,8 @@ ...@@ -289,7 +289,8 @@
;;; TEST-TYPE-AUX -- Internal. ;;; TEST-TYPE-AUX -- Internal.
;;; ;;;
(defun test-type-aux (reg temp target drop-through not-p lowtags immed hdrs) (defun test-type-aux (reg temp target drop-through not-p lowtags immed hdrs
function-p)
(let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql) (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql)
(member odd-fixnum-type lowtags :test #'eql))) (member odd-fixnum-type lowtags :test #'eql)))
(lowtags (sort (if fixnump (lowtags (sort (if fixnump
...@@ -299,6 +300,9 @@ ...@@ -299,6 +300,9 @@
:test #'eql) :test #'eql)
(copy-list lowtags)) (copy-list lowtags))
#'<)) #'<))
(lowtag (if function-p
vm:function-pointer-type
vm:other-pointer-type))
(hdrs (sort (copy-list hdrs) #'<)) (hdrs (sort (copy-list hdrs) #'<))
(immed (sort (copy-list immed) #'<))) (immed (sort (copy-list immed) #'<)))
(append (append
...@@ -337,15 +341,19 @@ ...@@ -337,15 +341,19 @@
(emit-label ,fall-through)))) (emit-label ,fall-through))))
(gen-range-test temp target drop-through not-p lowtags))) (gen-range-test temp target drop-through not-p lowtags)))
(when hdrs (when hdrs
`((inst c ,temp other-pointer-type) `((inst c ,temp ,lowtag)
(inst bnc :eq ,(if not-p target drop-through)) (inst bnc :eq ,(if not-p target drop-through))
(load-type ,temp ,reg other-pointer-type) (load-type ,temp ,reg ,lowtag)
,@(gen-range-test temp target drop-through not-p ,@(gen-range-test temp target drop-through not-p
hdrs type-separation min-type)))))) hdrs type-separation min-type))))))
(defconstant immediate-types (defconstant immediate-types
(list base-character-type unbound-marker-type)) (list base-character-type unbound-marker-type))
(defconstant function-subtypes
(list funcallable-instance-header-type closure-header-type
function-header-type closure-function-header-type))
;;; TEST-TYPE -- Interface. ;;; TEST-TYPE -- Interface.
;;; ;;;
;;; This is used in type-vops.lisp. ;;; This is used in type-vops.lisp.
...@@ -361,7 +369,8 @@ ...@@ -361,7 +369,8 @@
(lowtags (remove lowtag-limit type-codes :test #'<)) (lowtags (remove lowtag-limit type-codes :test #'<))
(extended (remove lowtag-limit type-codes :test #'>)) (extended (remove lowtag-limit type-codes :test #'>))
(immediates (intersection extended immediate-types :test #'eql)) (immediates (intersection extended immediate-types :test #'eql))
(headers (set-difference extended immediate-types :test #'eql))) (headers (set-difference extended immediate-types :test #'eql))
(function-p nil))
(unless type-codes (unless type-codes
(error "Must supply at least on type for test-type.")) (error "Must supply at least on type for test-type."))
(when (and headers (member other-pointer-type lowtags)) (when (and headers (member other-pointer-type lowtags))
...@@ -372,6 +381,11 @@ ...@@ -372,6 +381,11 @@
(member other-immediate-1-type lowtags))) (member other-immediate-1-type lowtags)))
(warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates) (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
(setf immediates nil)) (setf immediates nil))
(when (intersection headers function-subtypes)
(unless (subsetp headers function-subtypes)
(error "Can't test for mix of function subtypes and normal ~
header types."))
(setq function-p t))
(let ((n-reg (gensym)) (let ((n-reg (gensym))
(n-temp (gensym)) (n-temp (gensym))
(n-target (gensym)) (n-target (gensym))
...@@ -383,13 +397,16 @@ ...@@ -383,13 +397,16 @@
(declare (ignorable ,n-temp)) (declare (ignorable ,n-temp))
,@(if (constantp not-p) ,@(if (constantp not-p)
(test-type-aux n-reg n-temp n-target drop-through (test-type-aux n-reg n-temp n-target drop-through
(eval not-p) lowtags immediates headers) (eval not-p) lowtags immediates headers
function-p)
`((cond (,not-p `((cond (,not-p
,@(test-type-aux n-reg n-temp n-target drop-through t ,@(test-type-aux n-reg n-temp n-target drop-through t
lowtags immediates headers)) lowtags immediates headers
function-p))
(t (t
,@(test-type-aux n-reg n-temp n-target drop-through nil ,@(test-type-aux n-reg n-temp n-target drop-through nil
lowtags immediates headers))))) lowtags immediates headers
function-p)))))
(emit-label ,drop-through))))) (emit-label ,drop-through)))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment