From d27f1494e144f67cc16df3602d8bf0fe68f08a74 Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Sat, 23 Jun 2018 20:49:42 +0200 Subject: [PATCH] cmp: fix compile call for closures Signal an error for compilation of cclosures. Allow for compilation of bclosures over macros, functions and variables. Macros are simply added to the compiler environment. For functions and variables we enclose the definition of the closure in appropiate let/flet forms, e.g. for `(lambda () (fun var))' closing over the function `fun' and variable `var': (let ((var ...)) (flet ((fun (x) ...)) (lambda () (fun var)))) Closures over tags and blocks are not implemented and will signal an error during compilation. --- src/cmp/cmpenv-api.lsp | 53 ++++++++++++++++++++++++++++++++++++++++++ src/cmp/cmpmain.lsp | 28 ++++++++++++++-------- 2 files changed, 71 insertions(+), 10 deletions(-) diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index 1892c4b6e..78d8ae89f 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -25,6 +25,54 @@ that are susceptible to be changed by PROCLAIM." (defun cmp-env-copy (&optional (env *cmp-env*)) (cons (car env) (cdr env))) +(defun set-closure-env (definition lexenv &optional (env *cmp-env*)) + "Set up an environment for compilation of closures: Register closed +over macros in the compiler environment and enclose the definition of +the closure in let/flet forms for variables/functions it closes over." + (loop for record in lexenv + do (cond ((not (listp record)) + (multiple-value-bind (record-def record-lexenv) + (function-lambda-expression record) + (cond ((eql (car record-def) 'LAMBDA) + (setf record-def (cdr record-def))) + ((eql (car record-def) 'EXT:LAMBDA-BLOCK) + (setf record-def (cddr record-def))) + (t + (error "~&;;; Error: Not a valid lambda expression: ~s." record-def))) + ;; allow for closures which close over closures. + ;; (first record-def) is the lambda list, (rest + ;; record-def) the definition of the local function + ;; in record + (setf (rest record-def) + (list (set-closure-env (if (= (length record-def) 2) + (second record-def) + `(progn ,@(rest record-def))) + record-lexenv env))) + (setf definition + `(flet ((,(compiled-function-name record) + ,@record-def)) + ,definition)))) + ((and (listp record) (symbolp (car record))) + (cond ((eq (car record) 'si::macro) + (cmp-env-register-macro (cddr record) (cadr record) env)) + ((eq (car record) 'si::symbol-macro) + (cmp-env-register-symbol-macro-function (cddr record) (cadr record) env)) + (t + (setf definition + `(let ((,(car record) ',(cdr record))) + ,definition))) + )) + ;; ((and (integerp (cdr record)) (= (cdr record) 0)) + ;; Tags: We have lost the information, which tag + ;; corresponds to the lex-env record. If we are + ;; compiling a closure over a tag, we will get an + ;; error later on. + ;; ) + ;; (t + ;; Blocks: Not yet implemented + ) + finally (return definition))) + (defmacro cmp-env-variables (&optional (env '*cmp-env*)) `(car ,env)) @@ -102,6 +150,11 @@ that are susceptible to be changed by PROCLAIM." (cmp-env-variables env)) env) +(defun cmp-env-register-symbol-macro-function (name function &optional (env *cmp-env*)) + (push (list name 'si::symbol-macro function) + (cmp-env-variables env)) + env) + (defun cmp-env-register-block (blk &optional (env *cmp-env*)) (push (list :block (blk-name blk) blk) (cmp-env-variables env)) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 736ab4392..e68d936be 100755 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -734,6 +734,7 @@ compiled successfully, returns the pathname of the compiled file" #+dlopen (defun compile (name &optional (def nil supplied-p) &aux form data-pathname + (lexenv nil) (*suppress-compiler-messages* (or *suppress-compiler-messages* (not *compile-verbose*))) (*compiler-in-use* *compiler-in-use*) @@ -761,7 +762,11 @@ after compilation." (when (functionp def) (unless (function-lambda-expression def) (return-from compile def)) - (setf def (function-lambda-expression def))) + (multiple-value-setq (def lexenv) + (function-lambda-expression def)) + (when (eq lexenv t) + (warn "COMPILE can not compile C closures") + (return-from compile (values def t nil)))) (setq form (if name `(setf (fdefinition ',name) #',def) `(set 'GAZONK #',def)))) @@ -777,17 +782,20 @@ after compilation." (t (setq form `(setf (fdefinition ',name) #',form)))) - (let*((*load-time-values* 'values) ;; Only the value is kept - (tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))) - (data-pathname (first tmp-names)) - (c-pathname (compile-file-pathname data-pathname :type :c)) - (h-pathname (compile-file-pathname data-pathname :type :h)) - (o-pathname (compile-file-pathname data-pathname :type :object)) - (so-pathname (compile-file-pathname data-pathname)) - (init-name (compute-init-name so-pathname :kind :fasl)) - (compiler-conditions nil)) + (let* ((*load-time-values* 'values) ;; Only the value is kept + (tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))) + (data-pathname (first tmp-names)) + (c-pathname (compile-file-pathname data-pathname :type :c)) + (h-pathname (compile-file-pathname data-pathname :type :h)) + (o-pathname (compile-file-pathname data-pathname :type :object)) + (so-pathname (compile-file-pathname data-pathname)) + (init-name (compute-init-name so-pathname :kind :fasl)) + (compiler-conditions nil) + (*permanent-data* t) ; needed for literal objects in closures + (*cmp-env-root* *cmp-env-root*)) (with-compiler-env (compiler-conditions) + (setf form (set-closure-env form lexenv *cmp-env-root*)) (print-compiler-info) (data-init) (t1expr form)