diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 2ad95220f..54f0b133b 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -86,7 +86,10 @@ (pop arg-types) (pop args)))) (setq forms (nreverse fl)))) - (make-c1form* 'CALL-LOCAL :sp-change t :type return-type + (make-c1form* 'CALL-LOCAL + :sp-change t ; conservative estimate + :side-effects t ; conservative estimate + :type return-type :args fun forms))))) (defun c1call-global (fname args) @@ -104,6 +107,7 @@ (return-type (propagate-types fname forms))) (make-c1form* 'CALL-GLOBAL :sp-change (function-may-change-sp fname) + :side-effects (function-may-have-side-effects fname) :type return-type :args fname forms ;; loc and type are filled by c2expr diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index 12661b076..d06b757c6 100644 --- a/src/cmp/cmpform.lsp +++ b/src/cmp/cmpform.lsp @@ -28,27 +28,27 @@ (defconstant +all-c1-forms+ '((LOCATION loc) (VAR var) - (SETQ var value-c1form) - (PSETQ var-list value-c1form-list) + (SETQ var value-c1form :side-effects) + (PSETQ var-list value-c1form-list :side-effects) (BLOCK blk-var progn-c1form) (PROGN body) - (PROGV symbols values form) + (PROGV symbols values form :side-effects) (TAGBODY tag-var tag-body) - (DECL-BODY declaration-list progn-c1form) - (RETURN-FROM blk-var return-type value) - (FUNCALL fun-value (arg-value*)) - (CALL-LOCAL obj-fun (arg-value*)) + (RETURN-FROM blk-var return-type value :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) - (UNWIND-PROTECT protected-c1form body) - (THROW catch-value output-value) - (GO tag-var return-type) + (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) + one-liner-p + :side-effects) (LOCALS local-fun-list body labels-p) (IF fmla-c1form true-c1form false-c1form) (FMLA-NOT fmla-c1form) @@ -57,39 +57,37 @@ (LAMBDA lambda-list doc body-c1form) (LET vars-list var-init-c1form-list decl-body-c1form) (LET* vars-list var-init-c1form-list decl-body-c1form) - (FLET local-funs body-c1form let/labels) - (LABELS local-funs body-c1form let/labels) (VALUES values-c1form-list) - (MULTIPLE-VALUE-SETQ vars-list values-c1form-list) + (MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects) (MULTIPLE-VALUE-BIND vars-list init-c1form body) (COMPILER-LET symbols values body) (FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object) - (C2PRINC object-string-or-char stream-var stream-c1form) - (RPLACA (dest-c1form value-c1form)) - (RPLACD (dest-c1form value-c1form)) + (C2PRINC object-string-or-char stream-var stream-c1form :side-effects) + (RPLACA (dest-c1form value-c1form) :side-effects) + (RPLACD (dest-c1form value-c1form) :side-effects) (MEMBER!2 fun-symbol args-c1form-list) (ASSOC!2 fun-symbol args-c1form-list) (SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL)) - (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form) - (SI:FSET fun-object fun-name macro-p pprint-p unoptimized-c1form) + (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects) - (WITH-STACK body) - (STACK-PUSH-VALUES value-c1form push-statement-c1form) + (WITH-STACK body :side-effects) + (STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects) (ORDINARY c1form) (LOAD-TIME-VALUE dest-loc value-c1form) - (FSET function-object vv-loc macro-p pprint-p lambda-form) - (MAKE-FORM vv-loc value-c1form) - (INIT-FORM vv-loc value-c1form)))) + (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 :no-side-effects rest) - (progn (decf length) nil) - t) + for side-effects = (if (member :side-effects rest) + (progn (decf length) t) + nil) do (setf (gethash name hash) (list length side-effects)) finally (return hash))) @@ -135,10 +133,13 @@ (labels ((add-info-loop (form dependents) (loop for subform in dependents when (c1form-p subform) - do (when (c1form-sp-change subform) - (setf (c1form-sp-change form) t - (c1form-side-effects form) t)) - and do (setf (c1form-parent subform) form) + do (progn + (when (c1form-sp-change subform) + (setf (c1form-sp-change form) t + (c1form-side-effects form) t)) + (when (c1form-side-effects subform) + (setf (c1form-side-effects form) t)) + (setf (c1form-parent subform) form)) when (consp subform) do (add-info-loop form subform)))) (let ((record (gethash (c1form-name form) +c1-form-hash+))) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index 3767f3ad8..eca75fc94 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -306,21 +306,12 @@ (dotimes (i *inline-blocks*) (declare (fixnum i)) (wt #\}))) (defun form-causes-side-effect (form) - (case (c1form-name form) - ((LOCATION VAR SYS:STRUCTURE-REF #+clos SYS:INSTANCE-REF) - nil) - (CALL-GLOBAL - (let ((fname (c1form-arg 0 form)) - (args (c1form-arg 1 form))) - (or (function-may-have-side-effects fname) - (args-cause-side-effect args)))) - (t t))) + (c1form-side-effects form)) (defun args-cause-side-effect (forms) - (some #'form-causes-side-effect forms)) + (some #'c1form-side-effects forms)) (defun function-may-have-side-effects (fname) - (declare (si::c-local)) (not (get-sysprop fname 'no-side-effects))) (defun function-may-change-sp (fname)