mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-26 06:22:33 -08:00
cmp: separate fun/var ir functions from passes
Also provide better load grouping.
This commit is contained in:
Daniel Kochmański
parent
c8c59167d0
commit
e4fca7e8e7
5 changed files with 469 additions and 440 deletions
178
src/cmp/cmpfun.lsp
Normal file
178
src/cmp/cmpfun.lsp
Normal file
|
|
@ -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))))
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
279
src/cmp/cmpvar.lsp
Normal file
279
src/cmp/cmpvar.lsp
Normal file
|
|
@ -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))
|
||||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue