diff --git a/src/new-cmp/cmplam.lsp b/src/new-cmp/cmplam.lsp index 59d3cd9a0..6fc3029e4 100644 --- a/src/new-cmp/cmplam.lsp +++ b/src/new-cmp/cmplam.lsp @@ -275,7 +275,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (c1debug-env-close block-name)))) (let* ((bound-variables (set-difference new-variables requireds)) - (non-special-bound-variables (remove-if #'global bound-variables))) + (non-special-bound-variables (remove-if #'global-var-p bound-variables))) (setq compiled-body (nconc (c1bind non-special-bound-variables) compiled-body body diff --git a/src/new-cmp/cmppass.lsp b/src/new-cmp/cmppass.lsp new file mode 100644 index 000000000..5acf51a2a --- /dev/null +++ b/src/new-cmp/cmppass.lsp @@ -0,0 +1,145 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; CMPPASS Optimization passes +;;;; +;;;; Copyright (c) 2009, Juan Jose Garcia Ripoll. +;;;; +;;;; ECL is free software; you can redistribute it and/or modify it +;;;; under the terms of the GNU Library General Public License as +;;;; published by the Free Software Foundation; either version 2 of +;;;; the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ALL C1FORMS +;;; +;;; BIND (var1 ... varN) +;;; BIND-REQUIREDS ((var1 . arg1-loc) ... (varN . argN-loc)) +;;; BIND-SPECIAL destination value-loc +;;; CALL-LOCAL destination fun (arg1 ... argN) +;;; CALL-GLOBAL destination fun (arg1 ... argN) +;;; C-INLINE +;;; DEBUG-ENV-OPEN fun-name +;;; DEBUG-ENV-PUSH-VARS (var1 ... varN) +;;; DEBUG-ENV-POP-VARS (var1 ... varN) close-block +;;; DEBUG-ENV-CLOSE fun-name +;;; DO-FLET/LABELS (fun1 ... funN) +;;; FRAME-ID frame-var +;;; FRAME-JMP-NEXT frame-var +;;; FRAME-POP frame-var +;;; FRAME-SAVE-NEXT frame-var +;;; FRAME-SET id-loc no-label +;;; FUNCALL destination (arg1 ... argN) +;;; FUNCTION-PROLOGUE fun +;;; FUNCTION-EPILOGUE fun +;;; GO tag +;;; JMP tag +;;; PROGV ndx-loc (var1-loc ... varN-loc) values-loc +;;; PROGV-EXIT ndx-loc +;;; SET destination source +;;; SET-MV (dest-loc1 ... dest-locN) min-args max-args +;;; SI:STRUCTURE-REF +;;; SI:STRUCTURE-SET +;;; STACK-FRAME-OPEN frame-var +;;; STACK-FRAME-PUSH frame-var value-loc +;;; STACK-FRAME-PUSH-VALUES frame-var +;;; STACK-FRAME-POP-VALUES frame-var +;;; STACK-FRAME-APPLY frame-var fun-loc +;;; STACK-FRAME-CLOSE frame-var +;;; RETURN-FROM block-id-var block-name +;;; THROW tag-loc +;;; UNBIND (var1 ... varN) +;;; VALUES (value1-loc ... valueN-loc) +;;; VARARGS-BIND nargs-loc varargs-loc min max nkeys check +;;; VARARGS-POP dest-loc nargs-loc varargs-loc +;;; VARARGS-REST dest-loc nargs-loc varargs-loc nkeys +;;; keys-list-loc allow-other-keys +;;; VARARGS-UNBIND nargs-loc varargs-loc min max nkeys check +;;; + +(in-package "COMPILER") + +(defun execute-pass (pass) + (cmpnote "Executing pass ~A" pass) + (loop with pending = (list *top-level-forms*) + for *current-function* = (pop pending) + for f = *current-function* + while f + do (cmpnote "Applying pass ~A on function ~A" pass f) + do (setf (fun-lambda f) (funcall pass f (fun-lambda f))) + do (setf pending (append (fun-child-funs f) pending)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; DELETE UNUSED FORMS +;;; + +(defun pass-delete-no-side-effects (function forms) + "Going backwards, we examime forms that cause no side effects and whose +output value is not used." + (nreverse (delete-if #'delete-if-no-side-effects + (nreverse forms)))) + +(defun delete-if-no-side-effects (form) + (pprint-c1form form) + (when (c1form-p form) + (case (c1form-name form) + ((LOCATION VAR SYS:STRUCTURE-REF #+clos SYS:INSTANCE-REF) + t) + ((BIND UNBIND) + (every #'unused-variable-p (c1form-arg 0 form))) + (CALL-GLOBAL + (let* ((form-args (c1form-args form)) + (destination (first form-args)) + (fname (second form-args)) + (args (third form-args))) + (cond ((function-may-have-side-effects fname) + nil) + ((unused-destination destination) + (loop for i in args do (eliminate-from-read-nodes i form)) + (eliminate-from-set-nodes destination form) + t) + (t nil)))) + (SET + (let* ((destination (c1form-arg 0 form)) + (source (c1form-arg 1 form))) + (when (unused-destination destination) + (eliminate-from-set-nodes destination form) + (eliminate-from-read-nodes destination form) + (eliminate-from-set-nodes source form) + (eliminate-from-read-nodes source form) + t))) + (t nil)))) + +(defun unused-destination (dest) + (when (var-p dest) + (print (var-read-nodes dest))) + (or (eq dest 'trash) + (and (var-p dest) + (unused-variable-p dest)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; DELETE UNUSED BINDINGS +;;; + +(defun pass-delete-unused-bindings (function forms) + "We eliminate all unused variables, including their bindings. Empty BIND/UNBIND +forms are also suppressed." + (labels ((unused-variable-binding-p (v) + (unused-variable-p (if (consp v) (car v) v))) + (unused-bindings (form) + (and (c1form-p form) + (member (c1form-name form) '(BIND UNBIND BIND-REQUIREDS)) + (let ((new-args (delete-if #'unused-variable-binding-p + (c1form-arg 0 form)))) + (setf (c1form-args form) (list new-args)) + (null new-args))))) + (delete-if #'unused-bindings forms) + (setf (fun-local-vars fun) + (delete #'unused-variable-p (fun-local-vars fun)) + (fun-referred-vars fun) + (delete #'unused-variable-p (fun-referred-vars fun))))) + diff --git a/src/new-cmp/cmptop.lsp b/src/new-cmp/cmptop.lsp index 19e7c9820..d2be7de4c 100644 --- a/src/new-cmp/cmptop.lsp +++ b/src/new-cmp/cmptop.lsp @@ -147,6 +147,10 @@ (setq *compiler-phase* 't2) + ;; Optimization passes + (execute-pass 'pass-delete-no-side-effects) + (execute-pass 'pass-delete-unused-bindings) + ;; Emit entry function (let ((*compile-to-linking-call* nil)) (t3local-fun *top-level-forms*)) diff --git a/src/new-cmp/cmpvar.lsp b/src/new-cmp/cmpvar.lsp index f5ab13c7d..f16317ec6 100644 --- a/src/new-cmp/cmpvar.lsp +++ b/src/new-cmp/cmpvar.lsp @@ -83,6 +83,14 @@ (add-to-set-nodes v forms)) forms) +(defun eliminate-from-read-nodes (var form) + (when (var-p var) + (setf (var-read-nodes var) (delete form (var-read-nodes var))))) + +(defun eliminate-from-set-nodes (var form) + (when (var-p var) + (setf (var-set-nodes var) (delete form (var-set-nodes var))))) + ;;; A special binding creates a var object with the kind field SPECIAL, ;;; whereas a special declaration without binding creates a var object with ;;; the kind field GLOBAL. Thus a reference to GLOBAL may need to make sure @@ -169,7 +177,9 @@ ;; symbol-macrolet (baboon)) (t - (when (and maybe-drop-ref (or (local var) (not (policy-global-var-checking)))) + (when (and maybe-drop-ref + (not (and (global-var-p var) + (policy-global-var-checking)))) (return-from c1vref nil)) (when (minusp (var-ref var)) ; IGNORE. (cmpwarn-style "The ignored variable ~s is used." name) @@ -183,17 +193,15 @@ (var-loc var) 'OBJECT)))) var)))) -(defun unboxed (var) - (not (eq (var-rep-type var) :object))) - (defun global-var-p (var) (and (var-p var) (member (var-kind var) '(SPECIAL GLOBAL) :test #'eq))) -(defun local (var) - (let ((kind (var-kind var))) - (unless (member kind '(LEXICAL CLOSURE SPECIAL GLOBAL REPLACED DISCARDED)) - kind))) +(defun local-var-p (var) + (and (var-p var) + (let ((kind (var-kind var))) + (unless (member kind '(LEXICAL CLOSURE SPECIAL GLOBAL REPLACED DISCARDED)) + kind)))) (defun wt-var (var &aux (var-loc (var-loc var))) ; ccb (declare (type var var)) diff --git a/src/new-cmp/load.lsp.in b/src/new-cmp/load.lsp.in index bd8f43f0c..35260aa53 100644 --- a/src/new-cmp/load.lsp.in +++ b/src/new-cmp/load.lsp.in @@ -40,6 +40,7 @@ "src:new-cmp;cmpclos.lsp" "src:new-cmp;cmpstructures.lsp" "src:new-cmp;cmparray.lsp" + "src:new-cmp;cmppass.lsp" "src:new-cmp;cmpmain.lsp")) (let ((si::*keep-documentation* nil))