diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index d9b675f20..075005ac7 100644 --- a/src/cmp/cmpform.lsp +++ b/src/cmp/cmpform.lsp @@ -24,73 +24,6 @@ ;;; lambda-list = (requireds optionals rest key-flag keywords allow-other-keys) ;;; -(eval-when (:compile-toplevel :execute) -(defconstant +all-c1-forms+ - '((LOCATION loc :pure :single-valued) - (VAR var :single-valued) - (SETQ var value-c1form :side-effects) - (PSETQ var-list value-c1form-list :side-effects) - (BLOCK blk-var progn-c1form :pure) - (PROGN body :pure) - (PROGV symbols values form :side-effects) - (TAGBODY tag-var tag-body :pure) - (RETURN-FROM blk-var return-type value variable-or-nil :side-effects) - (FUNCALL fun-value (arg-value*) :side-effects) - (CALL-LOCAL obj-fun (arg-value*) :side-effects) - (CALL-GLOBAL fun-name (arg-value*)) - (CATCH catch-value body :side-effects) - (UNWIND-PROTECT protected-c1form body :side-effects) - (THROW catch-value output-value :side-effects) - (GO tag-var return-type :side-effects) - (C-INLINE (arg-c1form*) - (arg-type-symbol*) - output-rep-type - c-expression-string - side-effects-p - one-liner-p) - (LOCALS local-fun-list body labels-p :pure) - (IF fmla-c1form true-c1form false-c1form :pure) - (FMLA-NOT fmla-c1form :pure) - (FMLA-AND * :pure) - (FMLA-OR * :pure) - (LAMBDA lambda-list doc body-c1form) - (LET* vars-list var-init-c1form-list decl-body-c1form :pure) - (VALUES values-c1form-list :pure) - (MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects) - (MULTIPLE-VALUE-BIND vars-list init-c1form body :pure) - (COMPILER-LET symbols values body) - (FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued) - (RPLACD (dest-c1form value-c1form) :side-effects) - - (SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure) - (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects) - - (WITH-STACK body :side-effects) - (STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects) - - (ORDINARY c1form :pure) - (LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued) - (SI:FSET function-object vv-loc macro-p pprint-p lambda-form - :side-effects) - (MAKE-FORM vv-loc value-c1form :side-effects) - (INIT-FORM vv-loc value-c1form :side-effects)))) - -(defconstant +c1-form-hash+ - #.(loop with hash = (make-hash-table :size 128 :test #'eq) - for (name . rest) in +all-c1-forms+ - for length = (if (member '* rest) nil (length rest)) - for side-effects = (if (member :side-effects rest) - (progn (and length (decf length)) t) - nil) - for movable = (if (member :pure rest) - (progn (and length (decf length)) t) - nil) - for single-valued = (if (member :single-valued rest) - (progn (and length (decf length)) t) - nil) - do (setf (gethash name hash) (list length side-effects movable single-valued)) - finally (return hash))) - (defun print-c1form (form stream) (format stream "#
" (c1form-name form) (si:pointer form))) diff --git a/src/cmp/cmpopt-type.lsp b/src/cmp/cmpopt-type.lsp index 54630f516..7e522d509 100644 --- a/src/cmp/cmpopt-type.lsp +++ b/src/cmp/cmpopt-type.lsp @@ -14,32 +14,6 @@ (in-package "COMPILER") -(defun compute-c1form-type (form) - (let ((form (c1expr form))) - (prog1 (c1form-primary-type form) - (delete-c1forms form)))) - -(defun safe-type<= (t1 t2) - (multiple-value-bind (subtypep known-typep) - (subtypep t1 t2) - (and subtypep known-typep))) - -(defun c1compiler-typecase (args) - (let* ((expr-type (compute-c1form-type (pop args))) - (match (find expr-type args :test #'safe-type<= :key #'first))) - (if match - (c1progn (rest match)) - (c1nil)))) - -(defun c1compiler-typecases (args) - (let* ((all-types (mapcar #'compute-c1form-type (pop args))) - (match (find all-types args - :test #'(lambda (s1 s2) (every #'safe-typep<= s1 s2)) - :key #'first))) - (if match - (c1progn (rest match)) - (c1nil)))) - (define-compiler-macro dotimes ((variable limit &rest output) &body body) (multiple-value-bind (declarations body) (si:process-declarations body nil) @@ -50,7 +24,7 @@ `(block nil (let ((,%limit ,limit)) (declare (:read-only ,%limit)) - (ext:compiler-typecase ,limit + (ext:compiler-typecase ,%limit (fixnum (let ((,variable 0)) (declare (fixnum ,variable) ,@declarations) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 9b08e3567..6b032c671 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -234,6 +234,16 @@ of the occurrences in those lists." (defun p1progn (c1form assumptions forms) (p1propagate-list forms assumptions)) +(defun p1compiler-typecase (c1form assumptions variable expressions) + (let ((var-type (var-type variable))) + (loop with output-type = t + for (a-type c1form) in expressions + for c1form-type = (p1propagate c1form assumptions) + when (or (member a-type '(t otherwise)) + (subtypep var-type a-type)) + do (setf output-type c1form-type) + finally (return (values output-type assumptions))))) + (defun p1progv (c1form assumptions variables values body) (let (type) (multiple-value-setq (type assumptions) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 3785b4213..3b46da477 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -13,6 +13,74 @@ (in-package "COMPILER") +(eval-when (:compile-toplevel :execute) +(defconstant +all-c1-forms+ + '((LOCATION loc :pure :single-valued) + (VAR var :single-valued) + (SETQ var value-c1form :side-effects) + (PSETQ var-list value-c1form-list :side-effects) + (BLOCK blk-var progn-c1form :pure) + (PROGN body :pure) + (PROGV symbols values form :side-effects) + (TAGBODY tag-var tag-body :pure) + (RETURN-FROM blk-var return-type value variable-or-nil :side-effects) + (FUNCALL fun-value (arg-value*) :side-effects) + (CALL-LOCAL obj-fun (arg-value*) :side-effects) + (CALL-GLOBAL fun-name (arg-value*)) + (CATCH catch-value body :side-effects) + (UNWIND-PROTECT protected-c1form body :side-effects) + (THROW catch-value output-value :side-effects) + (GO tag-var return-type :side-effects) + (C-INLINE (arg-c1form*) + (arg-type-symbol*) + output-rep-type + c-expression-string + side-effects-p + one-liner-p) + (LOCALS local-fun-list body labels-p :pure) + (IF fmla-c1form true-c1form false-c1form :pure) + (FMLA-NOT fmla-c1form :pure) + (FMLA-AND * :pure) + (FMLA-OR * :pure) + (LAMBDA lambda-list doc body-c1form) + (LET* vars-list var-init-c1form-list decl-body-c1form :pure) + (VALUES values-c1form-list :pure) + (MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects) + (MULTIPLE-VALUE-BIND vars-list init-c1form body :pure) + (COMPILER-LET symbols values body) + (FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued) + (RPLACD (dest-c1form value-c1form) :side-effects) + + (SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure) + (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects) + + (WITH-STACK body :side-effects) + (STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects) + + (ORDINARY c1form :pure) + (LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued) + (SI:FSET function-object vv-loc macro-p pprint-p lambda-form + :side-effects) + (MAKE-FORM vv-loc value-c1form :side-effects) + (INIT-FORM vv-loc value-c1form :side-effects) + (EXT:COMPILER-TYPECASE var expressions)))) + +(defconstant +c1-form-hash+ + #.(loop with hash = (make-hash-table :size 128 :test #'eq) + for (name . rest) in +all-c1-forms+ + for length = (if (member '* rest) nil (length rest)) + for side-effects = (if (member :side-effects rest) + (progn (and length (decf length)) t) + nil) + for movable = (if (member :pure rest) + (progn (and length (decf length)) t) + nil) + for single-valued = (if (member :single-valued rest) + (progn (and length (decf length)) t) + nil) + do (setf (gethash name hash) (list length side-effects movable single-valued)) + finally (return hash))) + (defconstant +c1-dispatch-alist+ '((block . c1block) ; c1special (return-from . c1return-from) ; c1special @@ -46,7 +114,6 @@ (multiple-value-bind . c1multiple-value-bind) ; c1 (ext:compiler-typecase . c1compiler-typecase) ; c1special - (c::compiler-typecases . c1compiler-typecases) ; c1special (quote . c1quote) ; c1special (function . c1function) ; c1special @@ -178,6 +245,8 @@ (sys:structure-ref . c2structure-ref) ; c2 (sys:structure-set . c2structure-set) ; c2 + + (ext:compiler-typecase . c2compiler-typecase) )) (defconstant +t2-dispatch-alist+ @@ -226,6 +295,7 @@ (c::with-stack . p1with-stack) (c::stack-push-values . p1stack-push-values) (sys::structure-set . p1structure-set) + (ext:compiler-typecase . p1compiler-typecase) ; c1special )) (defun make-dispatch-table (alist) diff --git a/src/cmp/cmptype-assert.lsp b/src/cmp/cmptype-assert.lsp index b86e318dc..d148183c9 100644 --- a/src/cmp/cmptype-assert.lsp +++ b/src/cmp/cmptype-assert.lsp @@ -13,81 +13,101 @@ (in-package "COMPILER") -(defmacro unlikely (bool) - `(ffi:c-inline (,bool) (:bool) :bool "ecl_unlikely(#0)" - :one-liner t :side-effects nil)) +(defun c1compiler-typecase (args) + (let* ((var-name (pop args)) + (var (c1vref var-name)) + (expressions (loop for (type . forms) in args + collect (list type (c1progn forms))))) + (make-c1form* 'EXT:COMPILER-TYPECASE + :type 't + :args var expressions))) -(defun expand-type-assertion (value type env) - (if (not (symbolp value)) - (with-clean-symbols (%value) - `(let ((%value ,value)) - (declare (:read-only %value)) - ,(expand-type-assertions '%value type env))) - (case type - (cons - `(ffi:c-inline (,value) (:object) :void - "@0;if (ecl_unlikely(ATOM(#0))) FEtype_error_cons(#0);" - :one-liner nil)) - (array - `(ffi:c-inline (,value) (:object) :void - "if (ecl_unlikely(!ECL_ARRAYP(#0))) FEtype_error_array(#0);" - :one-liner nil)) - (list - `(ffi:c-inline (,value) (:object) :void - "if (ecl_unlikely(!ECL_LISTP(#0))) FEtype_error_list(#0);" - :one-liner nil)) - (sequence - `(ffi:c-inline (,value) (:object) :void - "if (ecl_unlikely(!(ECL_LISTP(#0) || ECL_VECTORP(#0)))) +(defun c2compiler-typecase (var expressions) + (loop with var-type = (var-type var) + for (type form) in expressions + when (or (member type '(t otherwise)) + (subtypep var-type type)) + return (c2expr form))) + +(defun variable-or-constant-p (value env) + (or (when (symbolp value) (known-variable-p value env)) + (constantp value env))) + +(defun simple-type-assertion (value type env) + (case type + (cons + `(ffi:c-inline (,value) (:object) :void + "@0;if (ecl_unlikely(ATOM(#0))) FEtype_error_cons(#0);" + :one-liner nil)) + (array + `(ffi:c-inline (,value) (:object) :void + "if (ecl_unlikely(!ECL_ARRAYP(#0))) FEtype_error_array(#0);" + :one-liner nil)) + (list + `(ffi:c-inline (,value) (:object) :void + "if (ecl_unlikely(!ECL_LISTP(#0))) FEtype_error_list(#0);" + :one-liner nil)) + (sequence + `(ffi:c-inline (,value) (:object) :void + "if (ecl_unlikely(!(ECL_LISTP(#0) || ECL_VECTORP(#0)))) FEtype_error_sequence(#0);" - :one-liner nil)) - (otherwise - `(ffi:c-inline - ((typep ,value ',type) ',type ,value) - (:bool :object :object) :void - "if (ecl_unlikely(!(#0))) - FEwrong_type_argument(#1,#2);" :one-liner nil) - #+(or) - `(if (unlikely (not (typep ,value ',type))) - (compiler-type-error ,value ,type)))))) + :one-liner nil)) + (otherwise + `(ffi:c-inline + ((typep ,value ',type) ',type ,value) + (:bool :object :object) :void + "if (ecl_unlikely(!(#0))) + FEwrong_type_argument(#1,#2);" :one-liner nil)))) + +(defun expand-type-assertion (value type env compulsory) + (cond ((constantp value env) + ;; For constant values, we simply verify the assertion directly + (unless (typep (cmp-eval value env) type) + (cmpwarning "Failed type assertion for value ~A and type ~A" + value type)) + t) + ((or (not (symbolp value)) + (special-variable-p value) + (symbol-macro-p value)) + ;; If multiple references to the value cost time and space, + ;; or may cause side effects, we save it. + (with-clean-symbols (%value) + `(let* ((%value ,value)) + (declare (:read-only %value)) + ,(expand-type-assertion '%value type env compulsory)))) + (compulsory + ;; The check has to be produced, independent of the declared + ;; value of the variable (for instance, in LAMBDA arguments). + (simple-type-assertion value type env)) + (t + ;; We may rely on the compiler to choose the appropriate + ;; branch once type propagation has happened. + `(ext:compiler-typecase ,value + (,type) + (t ,(simple-type-assertion value type env)))))) (defmacro optional-type-assertion (&whole whole value type &environment env) "Generates a type check on an expression, ensuring that it is satisfied." (when (policy-type-assertions env) (cmpnote "Checking type ~A for expression~&~A" type value) - (expand-type-assertion value type env))) + (expand-type-assertion value type env nil))) (defmacro type-assertion (&whole whole value type &environment env) "Generates a type check on an expression, ensuring that it is satisfied." (cmpnote "Checking type ~A for expression~&~A" type value) - (expand-type-assertion value type env)) + (expand-type-assertion value type env t)) (defmacro checked-value (&whole whole value type &environment env) - (if (policy-type-assertions env) - (with-clean-symbols (%value) - `(let* ((%value ,value)) - ,(expand-type-assertion '%value type env) - (the ,type %value))) - value)) + (cond ((not (policy-type-assertions env)) + `(the ,type ,value)) + ((or (constantp value type) + (and (symbolp value) (local-variable-p value env))) + `(progn + ,(expand-type-assertion value type env nil) + (the ,type ,value))) + (t + (with-clean-symbols (%checked-value) + `(let* ((%checked-value ,value)) + ,(expand-type-assertion '%checked-value type env nil) + (the ,type ,value)))))) -(defmacro compiler-type-error (value type &environment env) - (case type - (cons - `(ffi:c-inline (,value) (:object) :void - "FEtype_error_cons(#0);" - :one-liner t)) - (array - `(ffi:c-inline (,value) (:object) :void - "FEtype_error_array(#0);" - :one-liner t)) - (list - `(ffi:c-inline (,value) (:object) :void - "FEtype_error_list(#0);" - :one-liner t)) - (sequence - `(ffi:c-inline (,value) (:object) :void - "FEtype_error_sequence(#0);" - :one-liner t)) - (otherwise - `(ffi:c-inline (',type ,value) (:object :object) :void - "FEwrong_type_argument(#0,#1);")))) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 3eb40f72f..77fb1cffa 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -138,6 +138,7 @@ (member name *global-vars* :test #'eq :key #'var-name)) (defun special-variable-p (name) + "Return true if NAME is associated to a special variable in the lexical environment." (or (si::specialp name) (check-global name) (let ((v (cmp-env-search-var name *cmp-env-root*))) @@ -145,6 +146,14 @@ ;; we also have to consider 'GLOBAL here. (and v (eq (var-kind v) 'SPECIAL))))) +(defun local-variable-p (name &optional (env *cmp-env*)) + (let ((record (cmp-env-search-var name env))) + (and record (var-p record)))) + +(defun symbol-macro-p (name &optional (env *cmp-env*)) + (let ((record (cmp-env-search-var name env))) + (and record (not (var-p record))))) + ;;; ;;; Check if the symbol has a symbol macro ;;;