Commit e4fca7e8 authored by Daniel Kochmański's avatar Daniel Kochmański
Browse files

cmp: separate fun/var ir functions from passes

Also provide better load grouping.
parent c8c59167
;;;;
;;;; 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))))
......@@ -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))
......
......@@ -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))
;;;;
;;;; 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