From e4fca7e8e70642c0d565d6b6556db07fcc86b909 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 11 May 2021 11:42:05 +0200 Subject: [PATCH] cmp: separate fun/var ir functions from passes Also provide better load grouping. --- src/cmp/cmpfun.lsp | 178 +++++++++++++++++++++++++ src/cmp/cmppass1-fun.lsp | 164 ----------------------- src/cmp/cmppass1-var.lsp | 267 ------------------------------------- src/cmp/cmpvar.lsp | 279 +++++++++++++++++++++++++++++++++++++++ src/cmp/load.lsp.in | 21 +-- 5 files changed, 469 insertions(+), 440 deletions(-) create mode 100644 src/cmp/cmpfun.lsp create mode 100644 src/cmp/cmpvar.lsp diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp new file mode 100644 index 000000000..c571eeb1a --- /dev/null +++ b/src/cmp/cmpfun.lsp @@ -0,0 +1,178 @@ +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2021, Daniel Kochmański +;;;; +;;;; This program 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. +;;;; + +(in-package #:compiler) + +(defun child-function-p (presumed-parent fun) + (declare (optimize speed)) + (loop for real-parent = (fun-parent fun) + while real-parent + do (if (eq real-parent presumed-parent) + (return t) + (setf fun real-parent)))) + +(defun compute-closure-type (fun) + (declare (si::c-local)) + (let ((lexical-closure-p nil)) + ;; it will have a full closure if it refers external non-global variables + (dolist (var (fun-referenced-vars fun)) + (cond ((global-var-p var)) + ;; ...across CB + ((ref-ref-ccb var) + (return-from compute-closure-type 'CLOSURE)) + (t + (setf lexical-closure-p t)))) + ;; ...or if it directly calls a function + (dolist (f (fun-referenced-funs fun)) + (unless (child-function-p fun f) + ;; .. which has a full closure + (case (fun-closure f) + (CLOSURE (return-from compute-closure-type 'CLOSURE)) + (LEXICAL (setf lexical-closure-p t))))) + ;; ...or the function itself is referred across CB + (when lexical-closure-p + (if (or (fun-ref-ccb fun) + (and (fun-var fun) + (plusp (var-ref (fun-var fun))))) + 'CLOSURE + 'LEXICAL)))) + +(defun update-fun-closure-type-many (function-list) + (do ((finish nil t) + (recompute nil)) + (finish + recompute) + (dolist (f function-list) + (when (update-fun-closure-type f) + (setf recompute t finish nil))))) + +(defun prepend-new (l1 l2) + (loop for f in l1 + do (pushnew f l2)) + l2) + +(defun update-fun-closure-type (fun) + (let ((old-type (fun-closure fun))) + (when (eq old-type 'closure) + (return-from update-fun-closure-type nil)) + ;; This recursive algorithm is guaranteed to stop when functions + ;; do not change. + (let ((new-type (compute-closure-type fun)) + to-be-updated) + ;; Same type + (when (eq new-type old-type) + (return-from update-fun-closure-type nil)) + (when (fun-global fun) + (cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}" + (fun-name fun) (mapcar #'var-name (fun-referenced-vars fun)))) + (setf to-be-updated (append (fun-child-funs fun) (fun-referencing-funs fun))) + (setf (fun-closure fun) new-type) + ;; All external, non-global variables become of type closure + (when (eq new-type 'CLOSURE) + (dolist (var (fun-referenced-vars fun)) + (unless (or (global-var-p var) + (eq (var-kind var) new-type)) + (setf (var-ref-clb var) nil + (var-ref-ccb var) t + (var-kind var) 'CLOSURE + (var-loc var) 'OBJECT + to-be-updated + (prepend-new (var-functions-reading var) + (prepend-new (var-functions-setting var) + to-be-updated))))) + (dolist (f (fun-referenced-funs fun)) + (setf (fun-ref-ccb f) t))) + ;; If the status of some of the children changes, we have + ;; to recompute the closure type. + (when (update-fun-closure-type-many to-be-updated) + (update-fun-closure-type fun)) + t))) + +(defun local-function-ref (fname &optional build-object) + (multiple-value-bind (fun cfb unw) + (cmp-env-search-function fname) + (declare (ignore unw)) + (when fun + (when (functionp fun) + (when build-object + ;; Macro definition appears in #'.... This should not happen. + (cmperr "The name of a macro ~A was found in special form FUNCTION." fname)) + (return-from local-function-ref nil)) + (incf (fun-ref fun)) + (if build-object + (setf (fun-ref-ccb fun) t) + (let ((caller *current-function*)) + (when (and caller + (not (member fun (fun-referenced-funs caller) :test #'eq))) + (push fun (fun-referenced-funs caller)) + (push caller (fun-referencing-funs fun))))) + ;; we introduce a variable to hold the funob + (let ((var (fun-var fun))) + (when (and cfb build-object) + (setf (var-ref-clb var) t) + (when (not (eq (var-kind var) 'CLOSURE)) + (setf (var-kind var) 'LEXICAL))))) + fun)) + +(defun fun-needs-narg (fun) + (not (fun-fixed-narg fun))) + +(defun fun-fixed-narg (fun) + "Returns true if the function has a fixed number of arguments and it is not a closure. +The function thus belongs to the type of functions that ecl_make_cfun accepts." + (let (narg) + (and (not (eq (fun-closure fun) 'CLOSURE)) + (= (fun-minarg fun) (setf narg (fun-maxarg fun))) + (<= narg si::c-arguments-limit) + narg))) + +(defun add-to-fun-referenced-vars (fun var-list) + (loop with new-vars = (fun-referenced-vars fun) + with locals = (fun-local-vars fun) + with change = nil + for v in var-list + when (and (not (member v locals :test #'eq)) + (not (member v new-vars :test #'eq))) + do (setf change t new-vars (cons v new-vars)) + finally (when change + (setf (fun-referenced-vars fun) new-vars) + (return t)))) + +(defun add-to-fun-referenced-funs (fun fun-list) + (loop with new-funs = (fun-referenced-funs fun) + with change = nil + for f in fun-list + when (and (not (eq fun f)) + (not (member f new-funs :test #'eq)) + (not (child-function-p fun f))) + do (setf change t + new-funs (cons f new-funs) + (fun-referencing-funs f) (cons fun (fun-referencing-funs f))) + finally (when change + (setf (fun-referenced-funs fun) new-funs) + (return t)))) + +;;; searches for a (FUNCTION-BLOCK-NAME ...) declaration +(defun function-block-name-declaration (declarations) + (loop for i in declarations + if (and (consp i) (eql (car i) 'si::function-block-name) + (consp (cdr i))) + return (cadr i) + finally (return nil))) + +(defun exported-fname (name) + (let (cname) + (if (and (symbolp name) (setf cname (si:get-sysprop name 'Lfun))) + (values cname t) + (values (next-cfun "L~D~A" name) nil)))) diff --git a/src/cmp/cmppass1-fun.lsp b/src/cmp/cmppass1-fun.lsp index 31ad990b8..a20fe733c 100644 --- a/src/cmp/cmppass1-fun.lsp +++ b/src/cmp/cmppass1-fun.lsp @@ -354,170 +354,6 @@ (handler-case (si::process-lambda-list list 'function) (error (c) (cmperr "Illegal lambda list ~S:~%~A" list c)))) -(defun child-function-p (presumed-parent fun) - (declare (optimize speed)) - (loop for real-parent = (fun-parent fun) - while real-parent - do (if (eq real-parent presumed-parent) - (return t) - (setf fun real-parent)))) - -(defun compute-closure-type (fun) - (declare (si::c-local)) - (let ((lexical-closure-p nil)) - ;; it will have a full closure if it refers external non-global variables - (dolist (var (fun-referenced-vars fun)) - (cond ((global-var-p var)) - ;; ...across CB - ((ref-ref-ccb var) - (return-from compute-closure-type 'CLOSURE)) - (t - (setf lexical-closure-p t)))) - ;; ...or if it directly calls a function - (dolist (f (fun-referenced-funs fun)) - (unless (child-function-p fun f) - ;; .. which has a full closure - (case (fun-closure f) - (CLOSURE (return-from compute-closure-type 'CLOSURE)) - (LEXICAL (setf lexical-closure-p t))))) - ;; ...or the function itself is referred across CB - (when lexical-closure-p - (if (or (fun-ref-ccb fun) - (and (fun-var fun) - (plusp (var-ref (fun-var fun))))) - 'CLOSURE - 'LEXICAL)))) - -(defun update-fun-closure-type-many (function-list) - (do ((finish nil t) - (recompute nil)) - (finish - recompute) - (dolist (f function-list) - (when (update-fun-closure-type f) - (setf recompute t finish nil))))) - -(defun prepend-new (l1 l2) - (loop for f in l1 - do (pushnew f l2)) - l2) - -(defun update-fun-closure-type (fun) - (let ((old-type (fun-closure fun))) - (when (eq old-type 'closure) - (return-from update-fun-closure-type nil)) - ;; This recursive algorithm is guaranteed to stop when functions - ;; do not change. - (let ((new-type (compute-closure-type fun)) - to-be-updated) - ;; Same type - (when (eq new-type old-type) - (return-from update-fun-closure-type nil)) - (when (fun-global fun) - (cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}" - (fun-name fun) (mapcar #'var-name (fun-referenced-vars fun)))) - (setf to-be-updated (append (fun-child-funs fun) (fun-referencing-funs fun))) - (setf (fun-closure fun) new-type) - ;; All external, non-global variables become of type closure - (when (eq new-type 'CLOSURE) - (dolist (var (fun-referenced-vars fun)) - (unless (or (global-var-p var) - (eq (var-kind var) new-type)) - (setf (var-ref-clb var) nil - (var-ref-ccb var) t - (var-kind var) 'CLOSURE - (var-loc var) 'OBJECT - to-be-updated - (prepend-new (var-functions-reading var) - (prepend-new (var-functions-setting var) - to-be-updated))))) - (dolist (f (fun-referenced-funs fun)) - (setf (fun-ref-ccb f) t))) - ;; If the status of some of the children changes, we have - ;; to recompute the closure type. - (when (update-fun-closure-type-many to-be-updated) - (update-fun-closure-type fun)) - t))) - -;;; FIXME these functions doesn't belong to the pass1 module. -(defun local-function-ref (fname &optional build-object) - (multiple-value-bind (fun cfb unw) - (cmp-env-search-function fname) - (declare (ignore unw)) - (when fun - (when (functionp fun) - (when build-object - ;; Macro definition appears in #'.... This should not happen. - (cmperr "The name of a macro ~A was found in special form FUNCTION." fname)) - (return-from local-function-ref nil)) - (incf (fun-ref fun)) - (if build-object - (setf (fun-ref-ccb fun) t) - (let ((caller *current-function*)) - (when (and caller - (not (member fun (fun-referenced-funs caller) :test #'eq))) - (push fun (fun-referenced-funs caller)) - (push caller (fun-referencing-funs fun))))) - ;; we introduce a variable to hold the funob - (let ((var (fun-var fun))) - (when (and cfb build-object) - (setf (var-ref-clb var) t) - (when (not (eq (var-kind var) 'CLOSURE)) - (setf (var-kind var) 'LEXICAL))))) - fun)) - -(defun fun-needs-narg (fun) - (not (fun-fixed-narg fun))) - -(defun fun-fixed-narg (fun) - "Returns true if the function has a fixed number of arguments and it is not a closure. -The function thus belongs to the type of functions that ecl_make_cfun accepts." - (let (narg) - (and (not (eq (fun-closure fun) 'CLOSURE)) - (= (fun-minarg fun) (setf narg (fun-maxarg fun))) - (<= narg si::c-arguments-limit) - narg))) - -(defun add-to-fun-referenced-vars (fun var-list) - (loop with new-vars = (fun-referenced-vars fun) - with locals = (fun-local-vars fun) - with change = nil - for v in var-list - when (and (not (member v locals :test #'eq)) - (not (member v new-vars :test #'eq))) - do (setf change t new-vars (cons v new-vars)) - finally (when change - (setf (fun-referenced-vars fun) new-vars) - (return t)))) - -(defun add-to-fun-referenced-funs (fun fun-list) - (loop with new-funs = (fun-referenced-funs fun) - with change = nil - for f in fun-list - when (and (not (eq fun f)) - (not (member f new-funs :test #'eq)) - (not (child-function-p fun f))) - do (setf change t - new-funs (cons f new-funs) - (fun-referencing-funs f) (cons fun (fun-referencing-funs f))) - finally (when change - (setf (fun-referenced-funs fun) new-funs) - (return t)))) - -;;; searches for a (FUNCTION-BLOCK-NAME ...) declaration -(defun function-block-name-declaration (declarations) - (loop for i in declarations - if (and (consp i) (eql (car i) 'si::function-block-name) - (consp (cdr i))) - return (cadr i) - finally (return nil))) - -(defun exported-fname (name) - (let (cname) - (if (and (symbolp name) (setf cname (si:get-sysprop name 'Lfun))) - (values cname t) - (values (next-cfun "L~D~A" name) nil)))) - (defun lambda-form-allowed-nargs (lambda) (let ((minarg 0) (maxarg call-arguments-limit)) diff --git a/src/cmp/cmppass1-var.lsp b/src/cmp/cmppass1-var.lsp index 22e23b036..485d1d1b2 100644 --- a/src/cmp/cmppass1-var.lsp +++ b/src/cmp/cmppass1-var.lsp @@ -427,270 +427,3 @@ vars (mapcar #'c1vref vars)) (add-to-set-nodes-of-var-list vars (make-c1form* 'MULTIPLE-VALUE-SETQ :args vars value)))))) - - -;;; FIXME this doesn't belong to the pass (should be part of cmpenv). - -(defun read-only-variable-p (v other-decls) - (dolist (i other-decls nil) - (when (and (eq (car i) :READ-ONLY) - (member v (rest i))) - (return t)))) - -(defun env-grows (possibily) - ;; if additional closure variables are introduced and this is not - ;; last form, we must use a new env. - (and possibily - (plusp *env*) - (dolist (exit *unwind-exit*) - (case exit - (RETURN (return NIL)) - (BDS-BIND) - (t (return T)))))) - -;; should check whether a form before var causes a side-effect -;; exactly one occurrence of var is present in forms -(defun replaceable (var form) - (labels ((abort-on-side-effects (form) - (if (eq (c1form-name form) 'VAR) - (when (eq var (first (c1form-args form))) - (return-from replaceable t)) - (when (c1form-side-effects form) - (return-from replaceable nil))))) - (traverse-c1form-tree form #'abort-on-side-effects) - (baboon :format-control "In REPLACEABLE, variable ~A not found. Form:~%~A" - :format-arguments (list (var-name var) *current-form*)))) - -#+not-used -(defun discarded (var form body &aux last) - (labels ((last-form (x &aux (args (c1form-args x))) - (case (c1form-name x) - (PROGN - (last-form (car (last (first args))))) - ((LET LET* FLET LABELS BLOCK CATCH) - (last-form (car (last args)))) - (VAR (c1form-arg 0 x)) - (t x)))) - (and (not (form-causes-side-effect form)) - (or (< (var-ref var) 1) - (and (= (var-ref var) 1) - (eq var (last-form body)) - (eq 'TRASH *destination*)))))) - -(defun nsubst-var (var form) - (when (var-set-nodes var) - (baboon :format-control "Cannot replace a variable that is to be changed")) - (when (var-functions-reading var) - (baboon :format-control "Cannot replace a variable that forms part of a closure")) - (dolist (where (var-read-forms var)) - (unless (and (eql (c1form-name where) 'VAR) - (eql (c1form-arg 0 where) var)) - (baboon :format-control "VAR-READ-NODES are only C1FORMS of type VAR")) - (delete-from-read-nodes var where) - (c1form-replace-with where form)) - (setf (var-ignorable var) 0)) - -#+not-used -(defun member-var (var list) - (let ((kind (var-kind var))) - (if (member kind '(SPECIAL GLOBAL)) - (member var list :test - #'(lambda (v1 v2) - (and (member (var-kind v2) '(SPECIAL GLOBAL)) - (eql (var-name v1) (var-name v2))))) - (member var list)))) - -;;; - -(defun make-var (&rest args) - (let ((var (apply #'%make-var args))) - (unless (member (var-kind var) '(SPECIAL GLOBAL)) - (when *current-function* - (push var (fun-local-vars *current-function*)))) - var)) - -(defun make-lcl-var (&key rep-type (type 'T)) - (unless rep-type - (setq rep-type (if type (lisp-type->rep-type type) :object))) - (unless type - (setq type 'T)) - (make-var :kind rep-type :type type :loc (next-lcl))) - -(defun make-temp-var (&optional (type 'T)) - (make-var :kind :object :type type :loc `(TEMP ,(next-temp)))) - -(defun var-referenced-in-form-list (var form-list) - (loop for f in form-list - thereis (var-referenced-in-form var f))) - -(defun var-changed-in-form-list (var form-list) - (loop for f in form-list - thereis (var-changed-in-form var f))) - -;;; FIXME! VAR-REFERENCED-IN-FORM and VAR-CHANGED-IN-FORM are too -;;; pessimistic. One should check whether the functions reading/setting the -;;; variable are actually called from the given node. The problem arises when -;;; we create a closure of a function, as in -;;; -;;; (let* ((a 1) (b #'(lambda () (incf a)))) ...) -;;; -;;; To know whether A is changed or read, we would have to track where B is -;;; actually used. - -(defun var-referenced-in-form (var form) - (declare (type var var)) - (or (find-form-in-node-list form (var-read-nodes var)) - (var-functions-reading var))) - -(defun var-changed-in-form (var form) - (declare (type var var)) - (or (find-form-in-node-list form (var-set-nodes var)) - (let ((kind (var-kind var))) - (if (or (eq kind 'SPECIAL) (eq kind 'GLOBAL)) - (c1form-sp-change form) - (var-functions-setting var))))) - -(defun update-variable-type (var orig-type) - ;; FIXME! Refuse to update type of variables that are modified - (when (var-set-nodes var) - (return-from update-variable-type)) - (let ((type (type-and (var-type var) orig-type))) - (if (null type) - (cmpwarn "Variable assigned a value incompatible with its type declaration.~%Variable: ~A~%Expected type: ~A~%Value type: ~A" - (var-name var) - (var-type var) - orig-type) - (loop for form in (var-read-forms var) - when (and (eq (c1form-name form) 'VAR) - (eq var (c1form-arg 0 form))) - do (setf (c1form-type form) (type-and type (c1form-primary-type form))) - finally (setf (var-type var) type))))) - -(defun var-read-forms (var) - (mapcar #'first (var-read-nodes var))) - -(defun assert-var-ref-value (var) - (when *debug-compiler* - (unless (let ((ref (var-ref var))) - (or (> ref (/ most-positive-fixnum 2)) - (= (var-ref var) (+ (length (var-read-nodes var)) - (length (var-set-nodes var)))))) - (baboon :format-control "Number of references in VAR ~A unequal to references list" - :format-arguments (list var))))) - -(defun assert-var-not-ignored (var) - (when (let ((x (var-ignorable var))) (and x (minusp x))) - (cmpwarn-style "Variable ~A, declared as IGNORE, found in a lisp form." - (var-name var)) - (setf (var-ignorable var) nil))) - -(defun delete-from-read-nodes (var form) - (assert-var-ref-value var) - (setf (var-ref var) (1- (var-ref var)) - (var-read-nodes var) (delete-form-from-node-list form (var-read-nodes var)))) - -(defun add-to-read-nodes (var form) - (assert-var-ref-value var) - (assert-var-not-ignored var) - (setf (var-ref var) (1+ (var-ref var)) - (var-read-nodes var) (add-form-to-node-list form (var-read-nodes var))) - (when *current-function* - (unless (eq *current-function* (var-function var)) - (pushnew *current-function* (var-functions-reading var)) - (pushnew var (fun-referenced-vars *current-function*)))) - form) - -(defun add-to-set-nodes (var form) - (assert-var-ref-value var) - (assert-var-not-ignored var) - (setf (var-ref var) (1+ (var-ref var)) - (var-set-nodes var) (add-form-to-node-list form (var-set-nodes var))) - ;;(push form (var-read-nodes var)) - (when *current-function* - (unless (eq *current-function* (var-function var)) - (pushnew *current-function* (var-functions-setting var)) - (pushnew var (fun-referenced-vars *current-function*)))) - form) - -(defun add-to-set-nodes-of-var-list (var-list form) - (dolist (v var-list) - (add-to-set-nodes v form)) - form) - -;;; 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 -;;; that the variable has a value. - -;;; Bootstrap problem: proclaim needs this function: -;;; -;;; Check if a variable has been declared as a special variable with a global -;;; value. - -(defun check-global (name) - (member name *global-vars*)) - -(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*))) - ;; Fixme! Revise the declamation code to ensure whether - ;; 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))))) - -(defun variable-type-in-env (name &optional (env *cmp-env*)) - (let ((var (cmp-env-search-var name))) - (cond ((var-p var) - (var-type var)) - ((si:get-sysprop name 'CMP-TYPE)) - (t)))) - -(defun var-rep-type (var) - (case (var-kind var) - ((LEXICAL CLOSURE SPECIAL GLOBAL) :object) - (t (var-kind var)))) - -(defun check-vref (var) - (when (eq (var-kind var) 'LEXICAL) - (when (and (zerop (var-ref var)) ;;; This field may be -1 (IGNORE). Beppe - (not (var-ignorable var))) - (cmpwarn-style "The variable ~s is not used." (var-name var))) - (when (not (var-ref-clb var)) - ;; if the variable can be stored locally, set it var-kind to its type - (setf (var-kind var) - (if (plusp (var-ref var)) - (lisp-type->rep-type (var-type var)) - :OBJECT))))) - -(defun push-vars (v) - (setf (var-index v) (length (cmp-env-variables))) - (cmp-env-register-var v)) - -(defun unboxed (var) - (not (eq (var-rep-type var) :object))) - -(defun local (var) - (and (not (member (var-kind var) '(LEXICAL CLOSURE SPECIAL GLOBAL))) - (var-kind var))) - -(defun global-var-p (var) - (let ((kind (var-kind var))) - (or (eq kind 'global) - (eq kind 'special)))) - -(defun useful-var-p (var) - (or (plusp (var-ref var)) - (global-var-p var))) - -(defun si::register-global (name) - (pushnew name *global-vars*) - (values)) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp new file mode 100644 index 000000000..94c1b2427 --- /dev/null +++ b/src/cmp/cmpvar.lsp @@ -0,0 +1,279 @@ +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2021, Daniel Kochmański +;;;; +;;;; This program 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. +;;;; + +(in-package #:compiler) + +(defun read-only-variable-p (v other-decls) + (dolist (i other-decls nil) + (when (and (eq (car i) :READ-ONLY) + (member v (rest i))) + (return t)))) + +(defun env-grows (possibily) + ;; if additional closure variables are introduced and this is not + ;; last form, we must use a new env. + (and possibily + (plusp *env*) + (dolist (exit *unwind-exit*) + (case exit + (RETURN (return NIL)) + (BDS-BIND) + (t (return T)))))) + +;; should check whether a form before var causes a side-effect +;; exactly one occurrence of var is present in forms +(defun replaceable (var form) + (labels ((abort-on-side-effects (form) + (if (eq (c1form-name form) 'VAR) + (when (eq var (first (c1form-args form))) + (return-from replaceable t)) + (when (c1form-side-effects form) + (return-from replaceable nil))))) + (traverse-c1form-tree form #'abort-on-side-effects) + (baboon :format-control "In REPLACEABLE, variable ~A not found. Form:~%~A" + :format-arguments (list (var-name var) *current-form*)))) + +#+not-used +(defun discarded (var form body &aux last) + (labels ((last-form (x &aux (args (c1form-args x))) + (case (c1form-name x) + (PROGN + (last-form (car (last (first args))))) + ((LET LET* FLET LABELS BLOCK CATCH) + (last-form (car (last args)))) + (VAR (c1form-arg 0 x)) + (t x)))) + (and (not (form-causes-side-effect form)) + (or (< (var-ref var) 1) + (and (= (var-ref var) 1) + (eq var (last-form body)) + (eq 'TRASH *destination*)))))) + +(defun nsubst-var (var form) + (when (var-set-nodes var) + (baboon :format-control "Cannot replace a variable that is to be changed")) + (when (var-functions-reading var) + (baboon :format-control "Cannot replace a variable that forms part of a closure")) + (dolist (where (var-read-forms var)) + (unless (and (eql (c1form-name where) 'VAR) + (eql (c1form-arg 0 where) var)) + (baboon :format-control "VAR-READ-NODES are only C1FORMS of type VAR")) + (delete-from-read-nodes var where) + (c1form-replace-with where form)) + (setf (var-ignorable var) 0)) + +#+not-used +(defun member-var (var list) + (let ((kind (var-kind var))) + (if (member kind '(SPECIAL GLOBAL)) + (member var list :test + #'(lambda (v1 v2) + (and (member (var-kind v2) '(SPECIAL GLOBAL)) + (eql (var-name v1) (var-name v2))))) + (member var list)))) + +;;; + +(defun make-var (&rest args) + (let ((var (apply #'%make-var args))) + (unless (member (var-kind var) '(SPECIAL GLOBAL)) + (when *current-function* + (push var (fun-local-vars *current-function*)))) + var)) + +(defun make-lcl-var (&key rep-type (type 'T)) + (unless rep-type + (setq rep-type (if type (lisp-type->rep-type type) :object))) + (unless type + (setq type 'T)) + (make-var :kind rep-type :type type :loc (next-lcl))) + +(defun make-temp-var (&optional (type 'T)) + (make-var :kind :object :type type :loc `(TEMP ,(next-temp)))) + +(defun var-referenced-in-form-list (var form-list) + (loop for f in form-list + thereis (var-referenced-in-form var f))) + +(defun var-changed-in-form-list (var form-list) + (loop for f in form-list + thereis (var-changed-in-form var f))) + +;;; FIXME! VAR-REFERENCED-IN-FORM and VAR-CHANGED-IN-FORM are too +;;; pessimistic. One should check whether the functions reading/setting the +;;; variable are actually called from the given node. The problem arises when +;;; we create a closure of a function, as in +;;; +;;; (let* ((a 1) (b #'(lambda () (incf a)))) ...) +;;; +;;; To know whether A is changed or read, we would have to track where B is +;;; actually used. + +(defun var-referenced-in-form (var form) + (declare (type var var)) + (or (find-form-in-node-list form (var-read-nodes var)) + (var-functions-reading var))) + +(defun var-changed-in-form (var form) + (declare (type var var)) + (or (find-form-in-node-list form (var-set-nodes var)) + (let ((kind (var-kind var))) + (if (or (eq kind 'SPECIAL) (eq kind 'GLOBAL)) + (c1form-sp-change form) + (var-functions-setting var))))) + +(defun update-variable-type (var orig-type) + ;; FIXME! Refuse to update type of variables that are modified + (when (var-set-nodes var) + (return-from update-variable-type)) + (let ((type (type-and (var-type var) orig-type))) + (if (null type) + (cmpwarn "Variable assigned a value incompatible with its type declaration.~%Variable: ~A~%Expected type: ~A~%Value type: ~A" + (var-name var) + (var-type var) + orig-type) + (loop for form in (var-read-forms var) + when (and (eq (c1form-name form) 'VAR) + (eq var (c1form-arg 0 form))) + do (setf (c1form-type form) (type-and type (c1form-primary-type form))) + finally (setf (var-type var) type))))) + +(defun var-read-forms (var) + (mapcar #'first (var-read-nodes var))) + +(defun assert-var-ref-value (var) + (when *debug-compiler* + (unless (let ((ref (var-ref var))) + (or (> ref (/ most-positive-fixnum 2)) + (= (var-ref var) (+ (length (var-read-nodes var)) + (length (var-set-nodes var)))))) + (baboon :format-control "Number of references in VAR ~A unequal to references list" + :format-arguments (list var))))) + +(defun assert-var-not-ignored (var) + (when (let ((x (var-ignorable var))) (and x (minusp x))) + (cmpwarn-style "Variable ~A, declared as IGNORE, found in a lisp form." + (var-name var)) + (setf (var-ignorable var) nil))) + +(defun delete-from-read-nodes (var form) + (assert-var-ref-value var) + (setf (var-ref var) (1- (var-ref var)) + (var-read-nodes var) (delete-form-from-node-list form (var-read-nodes var)))) + +(defun add-to-read-nodes (var form) + (assert-var-ref-value var) + (assert-var-not-ignored var) + (setf (var-ref var) (1+ (var-ref var)) + (var-read-nodes var) (add-form-to-node-list form (var-read-nodes var))) + (when *current-function* + (unless (eq *current-function* (var-function var)) + (pushnew *current-function* (var-functions-reading var)) + (pushnew var (fun-referenced-vars *current-function*)))) + form) + +(defun add-to-set-nodes (var form) + (assert-var-ref-value var) + (assert-var-not-ignored var) + (setf (var-ref var) (1+ (var-ref var)) + (var-set-nodes var) (add-form-to-node-list form (var-set-nodes var))) + ;;(push form (var-read-nodes var)) + (when *current-function* + (unless (eq *current-function* (var-function var)) + (pushnew *current-function* (var-functions-setting var)) + (pushnew var (fun-referenced-vars *current-function*)))) + form) + +(defun add-to-set-nodes-of-var-list (var-list form) + (dolist (v var-list) + (add-to-set-nodes v form)) + form) + +;;; 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 +;;; that the variable has a value. + +;;; Bootstrap problem: proclaim needs this function: +;;; +;;; Check if a variable has been declared as a special variable with a global +;;; value. + +(defun check-global (name) + (member name *global-vars*)) + +(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*))) + ;; Fixme! Revise the declamation code to ensure whether + ;; 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))))) + +(defun variable-type-in-env (name &optional (env *cmp-env*)) + (let ((var (cmp-env-search-var name))) + (cond ((var-p var) + (var-type var)) + ((si:get-sysprop name 'CMP-TYPE)) + (t)))) + +(defun var-rep-type (var) + (case (var-kind var) + ((LEXICAL CLOSURE SPECIAL GLOBAL) :object) + (t (var-kind var)))) + +(defun check-vref (var) + (when (eq (var-kind var) 'LEXICAL) + (when (and (zerop (var-ref var)) ;;; This field may be -1 (IGNORE). Beppe + (not (var-ignorable var))) + (cmpwarn-style "The variable ~s is not used." (var-name var))) + (when (not (var-ref-clb var)) + ;; if the variable can be stored locally, set it var-kind to its type + (setf (var-kind var) + (if (plusp (var-ref var)) + (lisp-type->rep-type (var-type var)) + :OBJECT))))) + +(defun push-vars (v) + (setf (var-index v) (length (cmp-env-variables))) + (cmp-env-register-var v)) + +(defun unboxed (var) + (not (eq (var-rep-type var) :object))) + +(defun local (var) + (and (not (member (var-kind var) '(LEXICAL CLOSURE SPECIAL GLOBAL))) + (var-kind var))) + +(defun global-var-p (var) + (let ((kind (var-kind var))) + (or (eq kind 'global) + (eq kind 'special)))) + +(defun useful-var-p (var) + (or (plusp (var-ref var)) + (global-var-p var))) + +(defun si::register-global (name) + (pushnew name *global-vars*) + (values)) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index fcc080afa..c87349140 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -3,19 +3,10 @@ (defconstant +cmp-module-files+ '("src:cmp;cmppackage.lsp" - "src:cmp;cmptypes.lsp" "src:cmp;cmpglobals.lsp" "build:cmp;cmpdefs.lsp" "src:cmp;cmpmac.lsp" "src:cmp;cmputil.lsp" - "src:cmp;cmpform.lsp" - "src:cmp;cmptables.lsp" - "src:cmp;cmpinline.lsp" - ;; Types - "src:cmp;cmptype-arith.lsp" - "src:cmp;cmptype-prop.lsp" - "src:cmp;cmptype.lsp" - "src:cmp;cmptype-assert.lsp" ;; Environment "src:cmp;cmpenv-api.lsp" "src:cmp;cmpenv-fun.lsp" @@ -23,6 +14,18 @@ "src:cmp;cmpenv-proclaim.lsp" "src:cmp;cmpenv-declaim.lsp" "src:cmp;cmppolicy.lsp" + ;; Internal representation + "src:cmp;cmptypes.lsp" + "src:cmp;cmpform.lsp" + "src:cmp;cmpvar.lsp" + "src:cmp;cmpfun.lsp" + "src:cmp;cmptables.lsp" + "src:cmp;cmpinline.lsp" + ;; Types + "src:cmp;cmptype-arith.lsp" + "src:cmp;cmptype-prop.lsp" + "src:cmp;cmptype.lsp" + "src:cmp;cmptype-assert.lsp" ;; Abstract C machine "src:cmp;cmpc-machine.lsp" "src:cmp;cmpc-wt.lsp"