Commit 7ec2f4a9 authored by Daniel Kochmański's avatar Daniel Kochmański

Major cleanup for environment mark interpretation

Code was previously written with an assumption, that we know whenever function
crosses lexical for closure boundaries before it is compiled (and env-mark for
such boundries was LB and CB appropriately). Later it has changed, but code was
ready to work with LB and CB marks.

Fix these parts of code and replace it with a single mark ECI:FUNCTION. Also
replace CL:UNWIND-PROTECT boundry mark with ECI:UNWIND-PROTECT so we are less
dependent on use-ing CL package. Adjust comments to have this change.
parent 82efbab4
......@@ -16,14 +16,13 @@
(in-package "COMPILER")
;;; A dummy variable is created to hold the block identifier. When a
;;; reference to the block (via return-from) is found, the var-ref
;;; count for that variable is incremented only if the reference
;;; appears across a boundary (CB, LB or UNWIND-PROTECT), while the
;;; blk-ref is always incremented. Therefore blk-ref represents
;;; whether the block is used at all and var-ref for the dummy
;;; variable represents whether a block identifier must be created and
;;; stored in such variable.
;;; A dummy variable is created to hold the block identifier. When a reference
;;; to the block (via `return-from') is found, the `var-ref' count for that
;;; variable is incremented only if the reference appears across a boundary
;;; (`ECI:FUNCTION' or `ECI:UNWIND-PROTECT'), while the `blk-ref' is always
;;; incremented. Therefore `blk-ref' represents whether the block is used at
;;; all and `var-ref' for the dummy variable represents whether a block
;;; identifier must be created and stored in such variable.
(defun c1block (args)
(check-args-number 'BLOCK args 1)
......@@ -38,8 +37,6 @@
(when (or (var-ref-ccb blk-var) (var-ref-clb blk-var))
(incf *setjmps*))
(if (plusp (blk-ref blk))
;; FIXME! By simplifying the type of a BLOCK form so much (it is
;; either NIL or T), we lose a lot of information.
(make-c1form* 'BLOCK
:local-vars (list blk-var)
:type (values-type-or (blk-type blk) (c1form-type body))
......@@ -78,22 +75,20 @@
(let ((name (first args)))
(unless (symbolp name)
(cmperr "The block name ~s is not a symbol." name))
(multiple-value-bind (blk ccb clb unw)
(multiple-value-bind (blk cfb unw)
(cmp-env-search-block name)
(unless blk
(cmperr "The block ~s is undefined." name))
(let* ((val (c1expr (second args)))
(var (blk-var blk))
(type T))
(cond (ccb (setf type 'CCB
(var-ref-ccb var) T))
(clb (setf type 'CLB
(cond (cfb (setf type 'CLB
(var-ref-clb var) T))
(unw (setf type 'UNWIND-PROTECT)))
(incf (blk-ref blk))
(setf (blk-type blk) (values-type-or (blk-type blk) (c1form-type val)))
(let ((output (make-c1form* 'RETURN-FROM :type 'T :args blk type val)))
(when (or ccb clb unw)
(when (or cfb unw)
(add-to-read-nodes var output))
output)))))
......
......@@ -59,7 +59,7 @@
(c1expr (first args)))
(T
(incf *setjmps*)
(let ((form (let ((*cmp-env* (cmp-env-mark 'UNWIND-PROTECT)))
(let ((form (let ((*cmp-env* (cmp-env-mark 'ECI:UNWIND-PROTECT)))
(c1expr (first args)))))
(make-c1form* 'UNWIND-PROTECT :type (c1form-type form) :sp-change t
:args form (c1progn (rest args)))))))
......
......@@ -117,16 +117,13 @@ that are susceptible to be changed by PROCLAIM."
env)
(defun cmp-env-search-function (name &optional (env *cmp-env*))
(let ((ccb nil)
(clb nil)
(let ((cfb nil)
(unw nil)
(found nil))
(dolist (record (cmp-env-functions env))
(cond ((eq record 'CB)
(setf ccb t))
((eq record 'LB)
(setf clb t))
((eq record 'UNWIND-PROTECT)
(cond ((eq record 'ECI:FUNCTION)
(setf cfb t))
((eq record 'ECI:UNWIND-PROTECT)
(setf unw t))
((atom record)
(baboon :format-control "Uknown record found in environment~%~S"
......@@ -135,19 +132,16 @@ that are susceptible to be changed by PROCLAIM."
((equal (first record) name)
(setf found (first (last record)))
(return))))
(values found ccb clb unw)))
(values found cfb unw)))
(defun cmp-env-search-variables (type name env)
(let ((ccb nil)
(clb nil)
(let ((cfb nil)
(unw nil)
(found nil))
(dolist (record (cmp-env-variables env))
(cond ((eq record 'CB)
(setf ccb t))
((eq record 'LB)
(setf clb t))
((eq record 'UNWIND-PROTECT)
(cond ((eq record 'ECI:FUNCTION)
(setf cfb t))
((eq record 'ECI:UNWIND-PROTECT)
(setf unw t))
((atom record)
(baboon :format-control "Uknown record found in environment~%~S"
......@@ -168,7 +162,7 @@ that are susceptible to be changed by PROCLAIM."
(t
(setf found record)
(return))))
(values (first (last found)) ccb clb unw)))
(values (first (last found)) cfb unw)))
(defun cmp-env-search-block (name &optional (env *cmp-env*))
(cmp-env-search-variables :block name env))
......
......@@ -51,7 +51,7 @@
(dolist (def (nreverse defs))
(let ((fun (first def)))
;; The closure type will be fixed later on by COMPUTE-...
(push (c1compile-function (rest def) :fun fun :CB/LB 'LB)
(push (c1compile-function (rest def) :fun fun)
local-funs))))
;; When we are in a LABELs form, we have to propagate the external
......@@ -255,7 +255,7 @@
(c1locally (cdr args))))
(defun local-function-ref (fname &optional build-object)
(multiple-value-bind (fun ccb clb unw)
(multiple-value-bind (fun cfb unw)
(cmp-env-search-function fname)
(declare (ignore unw))
(when fun
......@@ -274,13 +274,9 @@
(push caller (fun-referencing-funs fun)))))
;; we introduce a variable to hold the funob
(let ((var (fun-var fun)))
(cond (ccb (when build-object
(setf (var-ref-ccb var) t
(var-kind var) 'CLOSURE))
(setf (fun-ref-ccb fun) t))
(clb (when build-object
(setf (var-ref-clb var) t
(var-kind var) 'LEXICAL))))))
(when (and cfb build-object)
(setf (var-ref-clb var) t
(var-kind var) 'LEXICAL))))
fun))
(defun c2call-local (c1form fun args)
......
......@@ -165,21 +165,22 @@ variable-record = (:block block-name) |
(:function function-name) |
(var-name {:special | nil} bound-p) |
(symbol si::symbol-macro macro-function) |
CB | LB | UNWIND-PROTECT
macro-record = (function-name function) |
(macro-name si::macro macro-function)
CB | LB | UNWIND-PROTECT
A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A
MACRO-FUNCTION is a function that provides us with the expansion
for that local macro or symbol macro. BOUND-P is true when the
variable has been bound by an enclosing form, while it is NIL if
the variable-record corresponds just to a special declaration.
CB, LB and UNWIND-PROTECT are only used by the C compiler and
they denote closure, lexical environment and unwind-protect
boundaries. Note that compared with the bytecodes compiler, these
records contain an additional variable, block, tag or function
object at the end.")
ECI:FUNCTION |
ECI:UNWIND-PROTECT
macro-record = (function-name function) |
(macro-name si::macro macro-function)
ECI:FUNCTION |
ECI:UNWIND-PROTECT
A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A MACRO-FUNCTION
is a function that provides us with the expansion for that local macro or symbol
macro. BOUND-P is true when the variable has been bound by an enclosing form,
while it is NIL if the variable-record corresponds just to a special
declaration. ECI:FUNCTION and ECI:UNWIND-PROTECT are only used by the C
compiler and they denote function and unwind-protect boundaries. Note that
compared with the bytecodes compiler, these records contain an additional
variable, block, tag or function object at the end.")
(defvar *cmp-env-root*
(cons nil (list (list '#:no-macro 'si::macro (constantly nil))))
......
......@@ -97,8 +97,8 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(setf (fun-referenced-funs fun) new-funs)
(return t))))
(defun c1compile-function (lambda-list-and-body &key (fun (make-fun))
(name (fun-name fun)) (CB/LB 'CB))
(defun c1compile-function (lambda-list-and-body
&key (fun (make-fun)) (name (fun-name fun)))
(let ((lambda (if name
`(ext:lambda-block ,name ,@lambda-list-and-body)
`(lambda ,@lambda-list-and-body))))
......@@ -108,7 +108,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(when *current-function*
(push fun (fun-child-funs *current-function*)))
(let* ((*current-function* fun)
(*cmp-env* (setf (fun-cmp-env fun) (cmp-env-mark CB/LB)))
(*cmp-env* (setf (fun-cmp-env fun) (cmp-env-mark 'ECI:FUNCTION)))
(setjmps *setjmps*)
(decl (si::process-declarations (rest lambda-list-and-body)))
(global (and *use-c-global*
......
......@@ -14,7 +14,9 @@
;;;; CMPPACKAGE -- Package definitions and exported symbols
;;;;
(ext:package-lock "CL" nil)
(defpackage #:ecl-cmp-internals
(:export #:unwind-protect
#:function))
(defpackage "C"
(:nicknames "COMPILER")
......@@ -50,3 +52,6 @@
(:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO"
"*COMPILER-CONSTANTS*" "REGISTER-GLOBAL" "CMP-ENV-REGISTER-MACROLET"
"COMPILER-LET"))
(ext:package-lock "CL" nil)
(ext:add-package-local-nickname "ECI" '#:ecl-cmp-internals '#:compiler)
......@@ -192,19 +192,17 @@
(let ((name (first args)))
(unless (or (symbolp name) (integerp name))
(cmperr "The tag name ~s is not a symbol nor an integer." name))
(multiple-value-bind (tag ccb clb unw)
(multiple-value-bind (tag cfb unw)
(cmp-env-search-tag name)
(unless tag
(cmperr "Undefined tag ~A" name))
(let ((var (tag-var tag)))
(cond (ccb (setf (var-ref-ccb var) t
(var-kind var) 'CLOSURE))
(clb (setf (var-ref-clb var) t
(cond (cfb (setf (var-ref-clb var) t
(var-kind var) 'LEXICAL))
(unw (unless (var-kind var)
(setf (var-kind var) :OBJECT))))
(incf (tag-ref tag))
(add-to-read-nodes var (make-c1form* 'GO :args tag (or ccb clb unw)))))))
(add-to-read-nodes var (make-c1form* 'GO :args tag (or cfb unw)))))))
(defun c2go (c1form tag nonlocal)
(declare (ignore c1form))
......
......@@ -102,7 +102,7 @@
;;; looking at the info-referenced-vars and info-local-referenced of its body.
;;; A LISP_CFUN or LISP_CLOSURE must be created when the function is returned.
;;; The LISP funob may then be referenced locally or across LB or CB:
;;; The LISP funob may then be referenced locally or across a function boundary:
;;; (flet ((foo (z) (bar z))) (list #'foo)))
;;; (flet ((foo (z) z)) (flet ((bar () #'foo)) (bar)))
;;; (flet ((foo (z) (bar z))) #'(lambda () #'foo)))
......
......@@ -152,8 +152,7 @@
(and record (not (var-p record)))))
(defun variable-type-in-env (name &optional (env *cmp-env*))
(multiple-value-bind (var ccb clb unw)
(cmp-env-search-var name)
(let ((var (cmp-env-search-var name)))
(cond ((var-p var)
(var-type var))
((si:get-sysprop name 'CMP-TYPE))
......@@ -228,7 +227,7 @@
;;; ( var-object ) Beppe(ccb) ccb-reference )
(defun c1vref (name)
(multiple-value-bind (var ccb clb unw)
(multiple-value-bind (var cfb unw)
(cmp-env-search-var name)
(cond ((null var)
(c1make-global-variable name :warn t
......@@ -242,14 +241,10 @@
((SPECIAL GLOBAL))
((CLOSURE))
((LEXICAL)
(cond (ccb (setf (var-ref-clb var) nil ; replace a previous 'CLB
(var-ref-ccb var) t
(var-kind var) 'CLOSURE
(var-loc var) 'OBJECT))
(clb (setf (var-ref-clb var) t
(var-loc var) 'OBJECT))))
(setf (var-ref-clb var) t
(var-loc var) 'OBJECT))
(t
(when (or clb ccb)
(when cfb
(cmperr "Variable ~A declared of C type cannot be referenced across function boundaries."
(var-name var)))))
var))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment