From ceddb1559be75f884ffde95adf946d8bb8ca26ce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 15 Nov 2023 10:27:55 +0100 Subject: [PATCH 01/49] core: add a macro ecl_frs_pop_n --- src/h/stacks.h | 1 + 1 file changed, 1 insertion(+) diff --git a/src/h/stacks.h b/src/h/stacks.h index 761740f67..602c93e54 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -312,6 +312,7 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); ecl_enable_interrupts_env(env) #define ecl_frs_pop(env) ((env)->frs_top--) +#define ecl_frs_pop_n(env,n) ((env)->frs_top-=n) /******************* * ARGUMENTS STACK From 5aa1a52db21bea9100264cbd79c873325f621014 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 6 Nov 2023 17:30:18 +0100 Subject: [PATCH 02/49] bytecmp: remove unused defines --- src/c/compiler.d | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 24bd2cb5c..b5a681980 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -31,9 +31,6 @@ /********************* EXPORTS *********************/ -#define REGISTER_SPECIALS 1 -#define IGNORE_DECLARATIONS 0 - /* Flags for the compilation routines: */ /* + Push the output of this form */ #define FLAG_PUSH 1 @@ -51,8 +48,6 @@ #define FLAG_LOAD 32 #define FLAG_COMPILE 64 -#define ENV_RECORD_LOCATION(r) CADDDR(r) - #define ECL_SPECIAL_VAR_REF -2 #define ECL_UNDEFINED_VAR_REF -1 @@ -350,9 +345,7 @@ static int c_register_constant(cl_env_ptr env, cl_object c) { int n = c_search_constant(env, c); - return (n < 0)? - asm_constant(env, c) : - n; + return (n < 0) ? asm_constant(env, c) : n; } static void From 5bf5ec4f805ac721de971722b27caea05d88b43b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 8 Nov 2023 14:51:47 +0100 Subject: [PATCH 03/49] bytecmp: fix outdated comments --- src/c/interpreter.d | 15 ++++++++------- src/h/bytecodes.h | 17 +++++++---------- 2 files changed, 15 insertions(+), 17 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 06b17e301..04a318d13 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -188,7 +188,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) VAR is the name of the variable for readability purposes. */ CASE(OP_VAR); { - int lex_env_index; + cl_fixnum lex_env_index; GET_OPARG(lex_env_index, vector); reg0 = ecl_lex_env_get_var(lex_env, lex_env_index); THREAD_NEXT; @@ -258,7 +258,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) } /* OP_PUSH - Pushes the object in VALUES(0). + Pushes the object in REG0. */ CASE(OP_PUSH); { ECL_STACK_PUSH(the_env, reg0); @@ -439,8 +439,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) THREAD_NEXT; } /* OP_POPREQ - Checks the arguments list. If there are remaining arguments, - REG0 = T and the value is on the stack, otherwise REG0 = NIL. + Checks the arguments list. + If there are remaining arguments, REG0 = ARG, otherwise signal an error. */ CASE(OP_POPREQ); { if (ecl_unlikely(frame_index >= frame->frame.size)) { @@ -450,8 +450,9 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) THREAD_NEXT; } /* OP_POPOPT - Checks the arguments list. If there are remaining arguments, - REG0 = T and the value is on the stack, otherwise REG0 = NIL. + Checks the arguments list. + If there are remaining arguments, REG0 = T and the value is on the stack, + otherwise REG0 = NIL. */ CASE(OP_POPOPT); { if (frame_index >= frame->frame.size) { @@ -463,7 +464,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) THREAD_NEXT; } /* OP_NOMORE - No more arguments. + Asserts that there are no more arguments in the frame. */ CASE(OP_NOMORE); { if (ecl_unlikely(frame_index < frame->frame.size)) diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 235a1a97f..d9ec2820e 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -1,16 +1,13 @@ /* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ /* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ -/********************************************************************** - *** - *** IMPORTANT: ANY CHANGE IN THIS FILE MUST BE MATCHED BY - *** APPROPRIATE CHANGES IN THE INTERPRETER AND COMPILER - *** IN PARTICULAR, IT MAY HURT THE THREADED INTERPRETER - *** CODE. - **********************************************************************/ -/* - * See ecl/src/c/interpreter.d for a detailed explanation of all opcodes - */ +/* ----------------------------------------------------------------------------- + *** IMPORTANT: ANY CHANGE IN THIS FILE MUST BE MATCHED BY APPROPRIATE CHANGES + *** IN THE INTERPRETER AND COMPILER IN PARTICULAR, IT MAY HURT THE THREADED + *** INTERPRETER CODE. + ----------------------------------------------------------------------------- */ + +/* See ecl/src/c/interpreter.d for a detailed explanation of all opcodes. */ enum { OP_NOP, OP_QUOTE, From be68897012771ccd5e54b778bb9bc62573b24e7b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 10 Nov 2023 08:46:29 +0100 Subject: [PATCH 04/49] cmp: defpackage uses strings instead of uninterned symbols --- src/cmp/cmppackage.lsp | 81 +++++++++++++++++++++--------------------- 1 file changed, 40 insertions(+), 41 deletions(-) diff --git a/src/cmp/cmppackage.lsp b/src/cmp/cmppackage.lsp index c04e8f213..7b11df5c7 100644 --- a/src/cmp/cmppackage.lsp +++ b/src/cmp/cmppackage.lsp @@ -3,55 +3,54 @@ ;;;; ;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2023, 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. -;;;; -;;;; CMPPACKAGE -- Package definitions and exported symbols +;;;; See the file 'LICENSE' for the copyright details. ;;;; -(defpackage #:c - (:nicknames #:compiler) - (:use #:cl) - (:import-from #:ext #:install-c-compiler) +;;;; CMPPACKAGE -- Package definitions and exported symbols + +(defpackage "C" + (:nicknames "ECL-CMP" "COMPILER") + (:local-nicknames ("OP" "ECL-CMP/OP")) + (:use "CL") + (:import-from "EXT" "INSTALL-C-COMPILER") (:export ;; Flags controlling the compiler behavior. - #:*compiler-break-enable* - #:*compile-print* - #:*compile-to-linking-call* - #:*compile-verbose* - #:*compiler-features* - #:*cc* - #:*cc-optimize* - #:*user-cc-flags* - #:*user-ld-flags* ; deprecated - #:*user-linker-flags* - #:*user-linker-libs* - #:*suppress-compiler-messages* + "*COMPILER-BREAK-ENABLE*" + "*COMPILE-PRINT*" + "*COMPILE-TO-LINKING-CALL*" + "*COMPILE-VERBOSE*" + "*COMPILER-FEATURES*" + "*CC*" + "*CC-OPTIMIZE*" + "*USER-CC-FLAGS*" + "*USER-LD-FLAGS*" ; deprecated + "*USER-LINKER-FLAGS*" + "*USER-LINKER-LIBS*" + "*SUPPRESS-COMPILER-MESSAGES*" ;; Build targets. BUILD-ECL is not defined, preasumbly it was meant ;; for cross compilation. - #:build-ecl - #:build-program - #:build-fasl - #:build-static-library - #:build-shared-library + "BUILD-ECL" + "BUILD-PROGRAM" + "BUILD-FASL" + "BUILD-STATIC-LIBRARY" + "BUILD-SHARED-LIBRARY" ;; Conditions (and their accessors). - #:compiler-warning - #:compiler-note - #:compiler-message - #:compiler-error - #:compiler-fatal-error - #:compiler-internal-error - #:compiler-undefined-variable - #:compiler-message-file - #:compiler-message-file-position - #:compiler-message-form + "COMPILER-WARNING" + "COMPILER-NOTE" + "COMPILER-MESSAGE" + "COMPILER-ERROR" + "COMPILER-FATAL-ERROR" + "COMPILER-INTERNAL-ERROR" + "COMPILER-UNDEFINED-VARIABLE" + "COMPILER-MESSAGE-FILE" + "COMPILER-MESSAGE-FILE-POSITION" + "COMPILER-MESSAGE-FORM" ;; Other operators. - #:install-c-compiler - #:update-compiler-features)) + "INSTALL-C-COMPILER" + "UPDATE-COMPILER-FEATURES")) + + (ext:package-lock '#:cl nil) From fa9a985b08b6fa8c2a0ed2fed7e5c011e3b5944e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 10 Nov 2023 08:54:25 +0100 Subject: [PATCH 05/49] cmp: cosmetic changes --- src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp | 2 +- src/cmp/cmpbackend-cxx/cmpc-util.lsp | 3 ++ src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 44 +++++++++++++------------ src/cmp/cmpvar.lsp | 26 --------------- 4 files changed, 27 insertions(+), 48 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp index 7174e3613..5dfa12ce5 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp @@ -51,7 +51,7 @@ (let ((var (c1form-arg 0 form)) (value-type (c1form-primary-type form))) (if (var-changed-in-form-list var rest-forms) - (let* ((temp (make-inline-temp-var value-type (var-rep-type var)))) + (let ((temp (make-inline-temp-var value-type (var-rep-type var)))) (let ((*destination* temp)) (set-loc var)) (list value-type temp)) (list value-type var)))) diff --git a/src/cmp/cmpbackend-cxx/cmpc-util.lsp b/src/cmp/cmpbackend-cxx/cmpc-util.lsp index b976064bd..aeff11dd6 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-util.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-util.lsp @@ -149,6 +149,9 @@ (let ((code (incf *next-cfun*))) (format nil prefix code (lisp-to-c-name lisp-name)))) +;;; (CAR label) is a an unique id of the label in the compilation unit. +;;; (CDR label) is a flag signaling whether the label is referenced. + (defun next-label () (cons (incf *last-label*) nil)) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index 14c555f41..6171f4beb 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -114,7 +114,7 @@ (wt-nl-h "#define ECL_DEFINE_SETF_FUNCTIONS ") (loop for (name setf-vv name-vv) in *setf-definitions* - do (wt-h #\\ #\Newline setf-vv "=ecl_setf_definition(" name-vv ",ECL_T);")) + do (wt-h #\\ #\Newline setf-vv "=ecl_setf_definition(" name-vv ",ECL_T);")) (wt-nl-h "#ifdef __cplusplus") (wt-nl-h "}") @@ -226,21 +226,24 @@ (defun t2load-time-value (c1form vv-loc form) (declare (ignore c1form)) - (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) + (let* ((*exit* (next-label)) + (*unwind-exit* (list *exit*)) (*destination* vv-loc)) (c2expr form) (wt-label *exit*))) (defun t2make-form (c1form vv-loc form) (declare (ignore c1form)) - (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) + (let* ((*exit* (next-label)) + (*unwind-exit* (list *exit*)) (*destination* vv-loc)) (c2expr form) (wt-label *exit*))) (defun t2init-form (c1form vv-loc form) (declare (ignore c1form vv-loc)) - (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) + (let* ((*exit* (next-label)) + (*unwind-exit* (list *exit*)) (*destination* 'TRASH)) (c2expr form) (wt-label *exit*))) @@ -265,21 +268,20 @@ #-:msvc ;; FIXME! Problem with initialization of statically defined vectors (let* ((filtered-locations '()) (filtered-codes '())) - ;; Filter out variables that we know how to store in the - ;; debug information table. This excludes among other things - ;; closures and special variables. + ;; Filter out variables that we know how to store in the debug information + ;; table. This excludes among other things closures and special variables. (loop for var in var-locations for name = (let ((*package* (find-package "KEYWORD"))) (format nil "\"~S\"" (var-name var))) for code = (locative-type-from-var-kind (var-kind var)) for loc = (var-loc var) when (and code (consp loc) (eq (first loc) 'LCL)) - do (progn - (push (cons name code) filtered-codes) - (push loc filtered-locations))) - ;; Generate two tables, a static one with information about the - ;; variables, including name and type, and dynamic one, which is - ;; a vector of pointer to the variables. + do (progn + (push (cons name code) filtered-codes) + (push loc filtered-locations))) + ;; Generate two tables, a static one with information about the variables, + ;; including name and type, and dynamic one, which is a vector of pointer to + ;; the variables. (when filtered-codes (setf *ihs-used-p* t) (wt-nl "static const struct ecl_var_debug_info _ecl_descriptors[]={") @@ -345,8 +347,8 @@ (defun t3local-fun-body (fun) (let ((string (make-array 2048 :element-type 'character - :adjustable t - :fill-pointer 0))) + :adjustable t + :fill-pointer 0))) (with-output-to-string (*compiler-output1* string) (let ((lambda-expr (fun-lambda fun))) (c2lambda-expr (c1form-arg 0 lambda-expr) @@ -375,9 +377,9 @@ (volatile (c1form-volatile* lambda-expr)) (lambda-list (c1form-arg 0 lambda-expr)) (requireds (loop - repeat si::c-arguments-limit - for arg in (car lambda-list) - collect (next-lcl (var-name arg)))) + repeat si::c-arguments-limit + for arg in (car lambda-list) + collect (next-lcl (var-name arg)))) (narg (fun-needs-narg fun))) (let ((cmp-env (c1form-env lambda-expr))) (wt-comment-nl "optimize speed ~D, debug ~D, space ~D, safety ~D " @@ -401,9 +403,9 @@ (wt comma "volatile cl_object *lex" n) (setf comma ", ")) (loop for lcl in (setf (fun-required-lcls fun) requireds) - do (wt-h comma "cl_object " volatile) - (wt comma "cl_object " volatile lcl) - (setf comma ", ")) + do (wt-h comma "cl_object " volatile) + (wt comma "cl_object " volatile lcl) + (setf comma ", ")) (when narg (wt-h ", ...") (wt ", ...")) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index f7bbfc09a..323bc0d25 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -27,22 +27,6 @@ (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)))) - (VARIABLE (c1form-arg 0 x)) - (t x)))) - (and (not (c1form-side-effects 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")) @@ -56,16 +40,6 @@ (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) From 44f33cb25148a7ce5ede5429f9625445ccbdfe2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Nov 2023 11:55:17 +0100 Subject: [PATCH 06/49] cmp: cleanup of predicates loc-with-*-p We first explicitly test for an ATOM and after that we use CASE. --- src/cmp/cmplocs.lsp | 48 +++++++++++++++++++++------------------------ 1 file changed, 22 insertions(+), 26 deletions(-) diff --git a/src/cmp/cmplocs.lsp b/src/cmp/cmplocs.lsp index bb247b857..e69736b2c 100644 --- a/src/cmp/cmplocs.lsp +++ b/src/cmp/cmplocs.lsp @@ -85,34 +85,30 @@ (otherwise :object))))) (defun loc-with-side-effects-p (loc &aux name) - (cond ((var-p loc) - (and (global-var-p loc) - (policy-global-var-checking))) - ((atom loc) - nil) - ((member (setf name (first loc)) '(CALL CALL-NORMAL CALL-INDIRECT CALL-STACK) - :test #'eq) - t) - ((eq name 'cl:THE) - (loc-with-side-effects-p (third loc))) - ((eq name 'cl:FDEFINITION) - (policy-global-function-checking)) - ((eq name 'ffi:C-INLINE) - (or (eq (sixth loc) 'cl:VALUES) ;; Uses VALUES - (fifth loc))))) ;; or side effects + (when (atom loc) + (return-from loc-with-side-effects-p + (and (var-p loc) + (global-var-p loc) + (policy-global-var-checking)))) + (case (first loc) + ((CALL CALL-NORMAL CALL-INDIRECT CALL-STACK) T) + (CL:THE (loc-with-side-effects-p (third loc))) + (CL:FDEFINITION (policy-global-function-checking)) + ;; Uses VALUES or has side effects. + (FFI:C-INLINE (or (eq (sixth loc) 'CL:VALUES) (fifth loc))) + (otherwise NIL))) (defun loc-refers-to-special-p (loc) - (cond ((var-p loc) - (member (var-kind loc) '(SPECIAL GLOBAL))) - ((atom loc) - nil) - ((eq (first loc) 'THE) - (loc-refers-to-special-p (third loc))) - ((eq (setf loc (first loc)) 'BIND) - t) - ((eq loc 'ffi:C-INLINE) - t) ; We do not know, so guess yes - (t nil))) + (when (atom loc) + (return-from loc-refers-to-special-p + (and (var-p loc) + (member (var-kind loc) '(SPECIAL GLOBAL))))) + (case (first loc) + (CL:THE (loc-refers-to-special-p (third loc))) + (BIND T) + ;; We do not know, so guess yes. + (FFI:C-INLINE T) + (otherwise NIL))) ;;; Valid locations are: ;;; NIL From 3f95f8857354030de144e0a5f1489c85cb5de9b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 10 Nov 2023 09:31:52 +0100 Subject: [PATCH 07/49] cmp: rename C?VAR to C?VARIABLE --- src/cmp/cmpbackend-cxx/cmppass2-var.lsp | 2 +- src/cmp/cmppass1-eval.lsp | 4 ++-- src/cmp/cmppass1-var.lsp | 2 +- src/cmp/cmptables.lsp | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp index e9cd97f5e..f2def11d9 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp @@ -137,7 +137,7 @@ (unwind-exit (precise-loc-type loc (c1form-primary-type c1form)))) ;;; When LOC is not NIL, then the variable is a constant. -(defun c2var (c1form var loc) +(defun c2variable (c1form var loc) (unwind-exit (precise-loc-type (if (and loc (not (numberp (vv-location loc)))) loc diff --git a/src/cmp/cmppass1-eval.lsp b/src/cmp/cmppass1-eval.lsp index 67d4dafbb..a9fea825f 100644 --- a/src/cmp/cmppass1-eval.lsp +++ b/src/cmp/cmppass1-eval.lsp @@ -26,9 +26,9 @@ (make-c1form* 'LOCATION :type (object-type form) :args (add-symbol form))) ((constantp form *cmp-env*) - (c1var form (c1constant-symbol-value form (symbol-value form)))) + (c1variable form (c1constant-symbol-value form (symbol-value form)))) (t - (c1var form nil)))) + (c1variable form nil)))) ((consp form) (cmpck (not (si:proper-list-p form)) "Improper list found in lisp form~%~A" form) diff --git a/src/cmp/cmppass1-var.lsp b/src/cmp/cmppass1-var.lsp index ecfa14519..b71cd0477 100644 --- a/src/cmp/cmppass1-var.lsp +++ b/src/cmp/cmppass1-var.lsp @@ -243,7 +243,7 @@ :ref 0))))) ;;; When LOC is not NIL then we deal with a constant. -(defun c1var (name loc) +(defun c1variable (name loc) (let* ((var (c1vref name)) (output (make-c1form* 'VARIABLE :type (var-type var) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 6072ed6b8..151d6eba3 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -224,7 +224,7 @@ (cl:tagbody . c2tagbody) (cl:go . c2go) - (variable . c2var) + (variable . c2variable) (location . c2location) (cl:setq . c2setq) (cl:progv . c2progv) From b228ae7867a63d942034cc508c12ea084700cef3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Nov 2023 14:05:11 +0100 Subject: [PATCH 08/49] cmp: cleanup: c2mvb: don't create unused local variable --- src/cmp/cmpbackend-cxx/cmppass2-var.lsp | 21 +++++++-------------- 1 file changed, 7 insertions(+), 14 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp index f2def11d9..19aa0ae16 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp @@ -94,16 +94,13 @@ (*lcl* *lcl*) (labels nil) (env-grows nil) - (nr (make-lcl-var :type :int)) (*inline-blocks* 0) min-values max-values) - (declare (ignore nr)) - ;; 1) Retrieve the number of output values + ;; 1) Retrieve the number of output values. (multiple-value-setq (min-values max-values) (c1form-values-number init-form)) - - ;; 2) For all variables which are not special and do not belong to - ;; a closure, make a local C variable. + ;; 2) For all variables which are not special and do not belong to a + ;; closure, make a local C variable. (dolist (var vars) (declare (type var var)) (let ((kind (local var))) @@ -114,22 +111,18 @@ (wt-nl (rep-type->c-name kind) " " *volatile* var ";") (wt-comment (var-name var))) (unless env-grows (setq env-grows (var-ref-ccb var)))))) - ;; 3) If there are closure variables, set up an environment. (when (setq env-grows (env-grows env-grows)) (let ((env-lvl *env-lvl*)) (maybe-open-inline-block) (wt-nl "volatile cl_object env" (incf *env-lvl*) " = env" env-lvl ";"))) - - ;; 4) Assign the values to the variables, compiling the form - ;; and binding the variables in the process. + ;; 4) Assign the values to the variables, compiling the form and binding the + ;; variables in the process. (do-m-v-setq vars init-form t) - - ;; 5) Compile the body. If there are bindings of special variables, - ;; these bindings are undone here. + ;; 5) Compile the body. If there are bindings of special variables, these + ;; bindings are undone here. (c2expr body) - ;; 6) Close the C expression. (close-inline-blocks))) From ec2a74b3002ffecf73ed30fbd7ec6c72bfcf3d48 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 6 Nov 2023 12:37:52 +0100 Subject: [PATCH 09/49] cmp: remove obsolete specialized c1form named CL:RPLACD This c1form is not created nor handled in the compiler anymore. --- src/cmp/cmptables.lsp | 1 - 1 file changed, 1 deletion(-) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 151d6eba3..b9ffbc93d 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -36,7 +36,6 @@ (CL:FUNCTION fname :single-valued) (LOCALS local-fun-list body labels-p :pure) ;; Specialized accessors - (CL:RPLACD (dest-c1form value-c1form) :side-effects) (SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure) (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects) ;; Control structures From e287445b98601746774fe044d569e5cc9c6f933f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 6 Nov 2023 15:46:27 +0100 Subject: [PATCH 10/49] cmp: exit manager: remove obsolete tags and fix typos - remove tags number and jump (unknown purpose) - update the comment to include RETURN-{LONG-FLOAT,C?FLOAT} - fix typos where RETURN-CSFLOAT was repeated thrice --- src/cmp/cmpbackend-cxx/cmppass2-exit.lsp | 25 ++++++++++-------------- 1 file changed, 10 insertions(+), 15 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp index 8ef8d7d18..b86146b0b 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp @@ -18,8 +18,6 @@ ;;; UNWIND-EXIT TAGS PURPOSE ;;; -;;; number -> unknown purpose -;;; JUMP -> unknown purpose ;;; FRAME -> ecl_frs_push() ;;; IHS -> ihs push ;;; IHS-ENV -> ihs push @@ -28,10 +26,11 @@ ;;; (LCL n) -> n local variables ;;; (STACK n) -> n elements pushed in stack ;;; TAIL-RECURSION-MARK -> TTL: label created -;;; RETURN* -> outermost location +;;; RETURN -> outermost location (*) ;;; -;;; (*) also RETURN-FIXNUM, -CHARACTER, -SINGLE-FLOAT -;;; -DOUBLE-FLOAT, -OBJECT. +;;; (*) also RETURN-{FIXNUM,CHARACTER,OBJECT} +;;; RETURN-{SINGLE-FLOAT,DOUBLE-FLOAT,LONG-FLOAT} +;;; RETURN-{CSFLOAT,CDFLOAT,CLFLOAT} ;;; (defun unwind-bds (bds-lcl bds-bind stack-frame ihs-p) (declare (fixnum bds-bind)) @@ -102,18 +101,18 @@ (t (set-loc loc) (unwind-bds bds-lcl bds-bind stack-frame ihs-p))) - (when jump-p (wt-nl) (wt-go *exit*)) + (when jump-p + (wt-nl) + (wt-go *exit*)) (return)) (t (setq jump-p t)))) - ((numberp ue) - (baboon-unwind-exit ue) - (setq bds-lcl ue bds-bind 0)) (t (case ue (IHS (setf ihs-p ue)) (IHS-ENV (setf ihs-p (or ihs-p ue))) (BDS-BIND (incf bds-bind)) (RETURN - (unless (eq *exit* 'RETURN) (baboon-unwind-exit ue)) + (unless (eq *exit* 'RETURN) + (baboon-unwind-exit ue)) ;; *destination* must be either RETURN or TRASH. (cond ((eq loc 'VALUES) ;; from multiple-value-prog1 or values @@ -131,7 +130,7 @@ (return)) ((RETURN-FIXNUM RETURN-CHARACTER RETURN-OBJECT RETURN-DOUBLE-FLOAT RETURN-SINGLE-FLOAT RETURN-LONG-FLOAT - RETURN-CSFLOAT RETURN-CSFLOAT RETURN-CSFLOAT) + RETURN-CSFLOAT RETURN-CDFLOAT RETURN-CLFLOAT) (when (eq *exit* ue) ;; *destination* must be RETURN-FIXNUM (setq loc (list 'COERCE-LOC @@ -161,7 +160,6 @@ (setq loc *destination*)) (wt-nl "ecl_frs_pop(cl_env_copy);")) (TAIL-RECURSION-MARK) - (JUMP (setq jump-p t)) (t (baboon-unwind-exit ue)))))) ;;; Never reached ) @@ -186,13 +184,10 @@ ((consp ue) (when (eq (first ue) 'STACK) (setf stack-frame (second ue)))) - ((numberp ue) - (setq bds-lcl ue bds-bind 0)) ((eq ue 'BDS-BIND) (incf bds-bind)) ((eq ue 'FRAME) (wt-nl "ecl_frs_pop(cl_env_copy);")) - ((eq ue 'JUMP)) ((eq ue 'IHS-ENV) (setf ihs-p ue)) (t (baboon-unwind-exit ue))) From 6722d4b9da31be051f71636b621749917d5c00a9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 7 Nov 2023 11:26:28 +0100 Subject: [PATCH 11/49] cmp: cxx: move the cxx code generator to cmppass2-top --- src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp | 28 +-------------------- src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 30 +++++++++++++++++++++++ 2 files changed, 31 insertions(+), 27 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp b/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp index ff12e25f6..043755393 100644 --- a/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp +++ b/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp @@ -528,33 +528,7 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS ") -;;; Code generation - -(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name source) - (with-cxx-env () - ;; After this step we still can add new objects, but objects that are - ;; already stored in VV or VVtemp must not change the location. - (optimize-cxx-data *referenced-objects*) - (setq *compiler-phase* 't2) - (with-open-file (*compiler-output1* c-pathname :direction :output - :if-does-not-exist :create - :if-exists :supersede) - (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) - #-ecl-min - (multiple-value-bind (second minute hour day month year) - (get-decoded-time) - (declare (ignore second)) - (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute) - (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type))) - (wt-comment-nl "Source: ~A" source) - (with-open-file (*compiler-output2* h-pathname :direction :output - :if-does-not-exist :create - :if-exists :supersede) - (wt-nl1 "#include " *cmpinclude*) - (ctop-write init-name h-pathname data-pathname) - (terpri *compiler-output1*) - (terpri *compiler-output2*))) - (data-c-dump data-pathname))) +;;; Code assembly (defun compiler-pass/assemble-cxx (input-file output-file &key diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index 6171f4beb..48d28f3c1 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -1,6 +1,36 @@ (in-package #:compiler) + +(defun wt-print-header (source) + (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) + #-ecl-min + (multiple-value-bind (second minute hour day month year) + (get-decoded-time) + (declare (ignore second)) + (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute) + (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type))) + (wt-comment-nl "Source: ~A" source)) + +(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name source) + (with-cxx-env () + ;; After this step we still can add new objects, but objects that are + ;; already stored in VV or VVtemp must not change the location. + (optimize-cxx-data *referenced-objects*) + (setq *compiler-phase* 't2) + (with-open-file (*compiler-output1* c-pathname :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (with-open-file (*compiler-output2* h-pathname :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (wt-print-header source) + (wt-nl1 "#include " *cmpinclude*) + (ctop-write init-name h-pathname data-pathname) + (terpri *compiler-output1*) + (terpri *compiler-output2*))) + (data-c-dump data-pathname))) + ;;;; CMPTOP -- Compiler top-level. (defun t2expr (form) From e536bc56ab0dfef8356f9de4cab080eb8eca9a41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 7 Nov 2023 13:58:16 +0100 Subject: [PATCH 12/49] cmp: cxx: don't waste space when printing comments We make the line length 80ch and print comment immedietely after "/* ". --- src/cmp/cmpbackend-cxx/cmpc-wt.lsp | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-wt.lsp b/src/cmp/cmpbackend-cxx/cmpc-wt.lsp index 85b01f027..3a3bc3699 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-wt.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-wt.lsp @@ -127,7 +127,7 @@ (if single-line (progn (fresh-line stream) - (princ "/* " stream)) + (princ "/* " stream)) (format stream "~50T/* ")) (let* ((l (1- (length text)))) (declare (fixnum l)) @@ -144,8 +144,7 @@ (t (princ c stream))))) (princ (schar text l) stream)) - (format stream "~70T*/") - ) + (format stream "~78T*/")) (defun do-wt-comment (message-or-format args single-line-p) (unless (and (symbolp message-or-format) (not (symbol-package message-or-format))) From b9301789d02520588f1b0f28d019d4c33a75079e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 7 Nov 2023 15:15:33 +0100 Subject: [PATCH 13/49] cmp: add a new utility cl:emptyp for collections --- src/cmp/cmputil.lsp | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 6040d189a..31741c87c 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -489,3 +489,9 @@ comparing circular objects." (defun same-fname-p (name1 name2) (equal name1 name2)) + +(defun emptyp (item) + (etypecase item + (list (null item)) + (vector (zerop (length item))) + (hash-table (zerop (hash-table-count item))))) From b7ad56faffaf9e1f9337e488a8395e587761d744 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 10 Nov 2023 08:44:18 +0100 Subject: [PATCH 14/49] cmp: cleanup: remove a misleading comment for VAR-LOC In the past VAR-LOC in the first pass could have a value 'CLB to indicate, that it can't be allocated on the C stack. But somewhere along the way the structure gained a separate slot REF-CLB that indicates that and VAR-LOC in the 1st pass is /always/ OBJECT. Update comments to reflect that fact and remove no-op assignments. --- src/cmp/cmpfun.lsp | 1 - src/cmp/cmppass1-var.lsp | 3 +-- src/cmp/cmprefs.lsp | 9 +-------- 3 files changed, 2 insertions(+), 11 deletions(-) diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index 0f13def22..0b0459fb4 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -86,7 +86,6 @@ (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) diff --git a/src/cmp/cmppass1-var.lsp b/src/cmp/cmppass1-var.lsp index b71cd0477..bf573576f 100644 --- a/src/cmp/cmppass1-var.lsp +++ b/src/cmp/cmppass1-var.lsp @@ -271,8 +271,7 @@ ((CLOSURE)) ((LEXICAL) (when cfb - (setf (var-ref-clb var) t - (var-loc var) 'OBJECT))) + (setf (var-ref-clb var) t))) (t (when cfb (cmperr "Variable ~A declared of C type cannot be referenced across function boundaries." diff --git a/src/cmp/cmprefs.lsp b/src/cmp/cmprefs.lsp index 008261956..b10bdeb69 100644 --- a/src/cmp/cmprefs.lsp +++ b/src/cmp/cmprefs.lsp @@ -49,14 +49,7 @@ (functions-setting nil) (functions-reading nil) ;;; Functions in which the variable has been modified or read. - (loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can - ;;; be allocated on the c-stack: OBJECT means - ;;; the variable is declared as OBJECT, and CLB means - ;;; the variable is referenced across Level Boundary and thus - ;;; cannot be allocated on the C stack. Note that OBJECT is - ;;; set during variable binding and CLB is set when the - ;;; variable is used later, and therefore CLB may supersede - ;;; OBJECT. + (loc 'OBJECT) ;;; During Pass 1: OBJECT ;;; During Pass 2: ;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT: ;;; the cvar for the C variable that holds the value. From 746f853b70f5b05ba8eb141a825167f1b0b30389 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 10 Nov 2023 11:27:39 +0100 Subject: [PATCH 15/49] cmp: remove unused mechanism for "sharing" function bodies --- src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 35 +++++++++++-------------- src/cmp/cmprefs.lsp | 2 -- 2 files changed, 15 insertions(+), 22 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index 48d28f3c1..83718ccc8 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -359,21 +359,20 @@ (*opened-c-braces* 0) (*tail-recursion-info* fun) (*volatile* (c1form-volatile* lambda-expr))) - ;; Function declaration. Returns NIL if this function needs no body. - (when (t3local-fun-declaration fun) - (wt-nl-open-brace) - (let ((body (t3local-fun-body fun))) - (wt-function-locals (fun-closure fun)) - (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") - (when (eq (fun-closure fun) 'CLOSURE) - (wt-nl "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;")) - (wt-nl "cl_object " *volatile* "value0;") - (when (policy-check-stack-overflow) - (wt-nl "ecl_cs_check(cl_env_copy,value0);")) - (when (eq (fun-closure fun) 'CLOSURE) - (t3local-fun-closure-scan fun)) - (write-sequence body *compiler-output1*) - (wt-nl-close-many-braces 0))))) + (t3local-fun-declaration fun) + (wt-nl-open-brace) + (let ((body (t3local-fun-body fun))) + (wt-function-locals (fun-closure fun)) + (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") + (when (eq (fun-closure fun) 'CLOSURE) + (wt-nl "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;")) + (wt-nl "cl_object " *volatile* "value0;") + (when (policy-check-stack-overflow) + (wt-nl "ecl_cs_check(cl_env_copy,value0);")) + (when (eq (fun-closure fun) 'CLOSURE) + (t3local-fun-closure-scan fun)) + (write-sequence body *compiler-output1*) + (wt-nl-close-many-braces 0)))) (defun t3local-fun-body (fun) (let ((string (make-array 2048 :element-type 'character @@ -399,9 +398,6 @@ ((eq (fun-closure fun) 'CLOSURE) "closure ~a") (t "local function ~a")) (or (fun-name fun) (fun-description fun) 'CLOSURE)) - (when (fun-shares-with fun) - (wt-comment-nl "... shares definition with ~a" (fun-name (fun-shares-with fun))) - (return-from t3local-fun-declaration nil)) (let* ((comma "") (lambda-expr (fun-lambda fun)) (volatile (c1form-volatile* lambda-expr)) @@ -440,8 +436,7 @@ (wt-h ", ...") (wt ", ...")) (wt-h ");") - (wt ")")) - t) + (wt ")"))) (defun fun-closure-variables (fun) (sort (remove-if diff --git a/src/cmp/cmprefs.lsp b/src/cmp/cmprefs.lsp index b10bdeb69..909a65021 100644 --- a/src/cmp/cmprefs.lsp +++ b/src/cmp/cmprefs.lsp @@ -115,8 +115,6 @@ (no-entry nil) ;;; NIL if declared as C-LOCAL. Then we create no ;;; function object and the C function is called ;;; directly - (shares-with nil) ;;; T if this function shares the C code with another one. - ;;; In that case we need not emit this one. closure ;;; During Pass2, T if env is used inside the function var ;;; the variable holding the funob description ;;; Text for the object, in case NAME == NIL. From e54b944e7a8fe9093011acde701487bd9934664e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 10 Nov 2023 12:36:40 +0100 Subject: [PATCH 16/49] cmp: don't refer to module functions as local-funs It is a historical baggage from before FSET. Functions stored in *local-funs* are both local and global, so sipmly rename it to *functions*. --- src/cmp/cmpbackend-cxx/cmpc-util.lsp | 4 +- src/cmp/cmpbackend-cxx/cmppass2-fun.lsp | 62 ++++++++++++------------- src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 43 +++++++++-------- src/cmp/cmpfun.lsp | 3 ++ src/cmp/cmpglobals.lsp | 2 + src/cmp/cmpmain.lsp | 8 ++-- src/cmp/cmppass1-fun.lsp | 3 +- src/cmp/cmppass1-top.lsp | 6 +-- 8 files changed, 65 insertions(+), 66 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-util.lsp b/src/cmp/cmpbackend-cxx/cmpc-util.lsp index aeff11dd6..480075f92 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-util.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-util.lsp @@ -9,7 +9,7 @@ (defvar *inline-blocks* 0) (defvar *opened-c-braces* 0) -(defvar *emitted-local-funs* nil) +(defvar *emitted-functions* nil) (defvar *inline-information* nil) ;;; Compiled code uses the following kinds of variables: @@ -61,7 +61,6 @@ ;;; C forms to find out (SETF fname) locations (defvar *setf-definitions*) ; holds { name fun-vv name-vv }* (defvar *global-cfuns-array*) ; holds { fun-vv fname-loc fun }* -(defvar *local-funs*) ; holds { fun }* ;;; T/NIL flag to determine whether one may generate lisp constant values as C ;;; structs. @@ -100,7 +99,6 @@ (make-inline-information *machine*))) (*setf-definitions* nil) (*global-cfuns-array* nil) - (*local-funs* nil) (*static-constants* nil) (*optimizable-constants* (make-optimizable-constants *machine*)) (*permanent-objects* (make-array 128 :adjustable t :fill-pointer 0)) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp index f6615f7a7..062e450e2 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp @@ -16,47 +16,47 @@ (defun c2locals (c1form funs body labels ;; labels is T when deriving from labels &aux - (*env* *env*) - (*inline-blocks* 0) - (*env-lvl* *env-lvl*)) + (*env* *env*) + (*inline-blocks* 0) + (*env-lvl* *env-lvl*)) (declare (ignore c1form labels)) ;; create location for each function which is returned, ;; either in lexical: (loop with env-grows = nil - with closed-vars = '() - for fun in funs - for var = (fun-var fun) - when (plusp (var-ref var)) - do (case (var-kind var) - ((lexical closure) - (push var closed-vars) - (unless env-grows - (setq env-grows (var-ref-ccb var)))) - (otherwise - (maybe-open-inline-block) - (bind (next-lcl) var) - (wt-nl "cl_object " *volatile* var ";"))) - finally - ;; if we have closed variables - (when (env-grows env-grows) - (maybe-open-inline-block) - (let ((env-lvl *env-lvl*)) - (wt "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";"))) - ;; bind closed locations because of possible circularities - (loop for var in closed-vars - do (bind *vv-nil* var))) + with closed-vars = '() + for fun in funs + for var = (fun-var fun) + when (plusp (var-ref var)) + do (case (var-kind var) + ((lexical closure) + (push var closed-vars) + (unless env-grows + (setq env-grows (var-ref-ccb var)))) + (otherwise + (maybe-open-inline-block) + (bind (next-lcl) var) + (wt-nl "cl_object " *volatile* var ";"))) + finally + ;; if we have closed variables + (when (env-grows env-grows) + (maybe-open-inline-block) + (let ((env-lvl *env-lvl*)) + (wt "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";"))) + ;; bind closed locations because of possible circularities + (loop for var in closed-vars + do (bind *vv-nil* var))) ;; create the functions: - (mapc #'new-local funs) + (map nil #'update-function-env funs) ;; - then assign to it (loop for fun in funs - for var = (fun-var fun) - when (plusp (var-ref var)) - do (set-var (list 'MAKE-CCLOSURE fun) var)) + for var = (fun-var fun) + when (plusp (var-ref var)) + do (set-var (list 'MAKE-CCLOSURE fun) var)) (c2expr body) (close-inline-blocks)) ;;; Mechanism for sharing code. -(defun new-local (fun) +(defun update-function-env (fun) (declare (type fun fun)) (case (fun-closure fun) (CLOSURE @@ -71,7 +71,7 @@ (otherwise (setf (fun-level fun) 0 (fun-env fun) 0))) - (push fun *local-funs*)) + (register-function fun)) #| Steps: 1. defun creates declarations for requireds + va_alist diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index 83718ccc8..3b8fcfecf 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -44,20 +44,20 @@ (apply def form (c1form-args form))) (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form)))) -(defun emit-local-funs () +(defun emit-functions () (declare (si::c-local)) ;; Local functions and closure functions (do ((*compile-time-too* nil) (*compile-toplevel* nil)) - ;; repeat until t3local-fun generates no more - ((eq *emitted-local-funs* *local-funs*)) - ;; scan *local-funs* backwards - (do ((lfs *local-funs* (cdr lfs))) - ((eq (cdr lfs) *emitted-local-funs*) - (setq *emitted-local-funs* lfs) - (locally (declare (notinline t3local-fun)) + ;; repeat until t3function generates no more + ((eq *emitted-functions* *functions*)) + ;; scan *functions* backwards + (do ((lfs *functions* (cdr lfs))) + ((eq (cdr lfs) *emitted-functions*) + (setq *emitted-functions* lfs) + (locally (declare (notinline t3function)) ;; so disassemble can redefine it - (t3local-fun (first lfs))))))) + (t3function (first lfs))))))) (defun ctop-write (name h-pathname data-pathname &aux def top-output-string @@ -81,7 +81,7 @@ (*aux-closure* nil) (c-output-file *compiler-output1*) (*compiler-output1* (make-string-output-stream)) - (*emitted-local-funs* nil) + (*emitted-functions* nil) (*compiler-declared-globals* (make-hash-table))) (wt-nl "#include \"" (brief-namestring data-pathname) "\"") (wt-nl "#ifdef __cplusplus") @@ -201,7 +201,7 @@ (wt-nl-close-brace)) (write-sequence body *compiler-output1*))) (let ((*compiler-output1* c-output-file)) - (emit-local-funs)))) + (emit-functions)))) (defun t2compiler-let (c1form symbols values body) (declare (ignore c1form)) @@ -335,7 +335,7 @@ (defun pop-debug-lexical-env () (wt-nl "ihs.lex_env = _ecl_debug_env;")) -(defun t3local-fun (fun) +(defun t3function (fun) (declare (type fun fun)) ;; Compiler note about compiling this function @@ -359,9 +359,9 @@ (*opened-c-braces* 0) (*tail-recursion-info* fun) (*volatile* (c1form-volatile* lambda-expr))) - (t3local-fun-declaration fun) + (t3function-declaration fun) (wt-nl-open-brace) - (let ((body (t3local-fun-body fun))) + (let ((body (t3function-body fun))) (wt-function-locals (fun-closure fun)) (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") (when (eq (fun-closure fun) 'CLOSURE) @@ -370,11 +370,11 @@ (when (policy-check-stack-overflow) (wt-nl "ecl_cs_check(cl_env_copy,value0);")) (when (eq (fun-closure fun) 'CLOSURE) - (t3local-fun-closure-scan fun)) + (t3function-closure-scan fun)) (write-sequence body *compiler-output1*) (wt-nl-close-many-braces 0)))) -(defun t3local-fun-body (fun) +(defun t3function-body (fun) (let ((string (make-array 2048 :element-type 'character :adjustable t :fill-pointer 0))) @@ -392,7 +392,7 @@ (fun-keyword-type-check-forms fun)))) string)) -(defun t3local-fun-declaration (fun) +(defun t3function-declaration (fun) (declare (type fun fun)) (wt-comment-nl (cond ((fun-global fun) "function definition for ~a") ((eq (fun-closure fun) 'CLOSURE) "closure ~a") @@ -461,7 +461,7 @@ (fun-level fun) 0)) -(defun t3local-fun-closure-scan (fun) +(defun t3function-closure-scan (fun) (let ((clv-used (fun-closure-variables fun))) (wt-nl "/* Scanning closure data ... */") (do ((n (1- (fun-env fun)) (1- n)) @@ -511,10 +511,9 @@ (defun c2fset (c1form fun fname macro pprint c1forms) (declare (ignore pprint)) (when (fun-no-entry fun) - (wt-nl "(void)0; " - (format nil "/* No entry created for ~A */" (fun-name fun))) + (wt-nl "(void)0; " (format nil "/* No entry created for ~A */" (fun-name fun))) ;; FIXME! Look at C2LOCALS! - (new-local fun) + (update-function-env fun) (return-from c2fset)) (unless (and (not (fun-closure fun)) (eq *destination* 'TRASH)) @@ -524,7 +523,7 @@ (loc (data-empty-loc*))) (push (list loc fname fun) *global-cfuns-array*) ;; FIXME! Look at C2LOCALS! - (new-local fun) + (update-function-env fun) (if macro (wt-nl "ecl_cmp_defmacro(" loc ");") (wt-nl "ecl_cmp_defun(" loc ");")) diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index 0b0459fb4..c467ffdce 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -14,6 +14,9 @@ (in-package #:compiler) +(defun register-function (fun) + (push fun *functions*)) + (defun child-function-p (presumed-parent fun) (declare (optimize speed)) (loop for real-parent = (fun-parent fun) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 526f4ec59..878f46b50 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -65,6 +65,7 @@ running the compiler. It may be updated by running ") ;;; List of callbacks to be generated ;;; (defvar *callbacks* nil) +(defvar *functions* nil) ;;; --cmpc-machine.lsp, cmpffi.lsp --- (defvar *machine* nil) @@ -238,6 +239,7 @@ be deleted if they have been opened with LoadLibrary.") (*compiler-in-use* t) (*compiler-phase* 't1) (*callbacks* nil) + (*functions* nil) (*cmp-env-root* (copy-tree *cmp-env-root*)) (*cmp-env* nil) (*load-objects* (make-hash-table :size 128 :test #'equal)) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index e5ee240e0..f7000b155 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -284,7 +284,7 @@ from the C language code. NIL means \"do not create the file\"." (*compiler-output2* (if h-file (open h-file :direction :output :external-format :default) null-stream)) - (t3local-fun (symbol-function 'T3LOCAL-FUN)) + (t3function (symbol-function 'T3FUNCTION)) (compiler-conditions nil) (*cmp-env-root* *cmp-env-root*)) (with-compiler-env (compiler-conditions) @@ -292,10 +292,10 @@ from the C language code. NIL means \"do not create the file\"." (setf disassembled-form (set-closure-env disassembled-form lexenv *cmp-env-root*)) (unwind-protect (progn - (setf (symbol-function 'T3LOCAL-FUN) + (setf (symbol-function 'T3FUNCTION) #'(lambda (&rest args) (let ((*compiler-output1* *standard-output*)) - (apply t3local-fun args)))) + (apply t3function args)))) (compiler-pass1 disassembled-form) (compiler-pass/propagate-types) (optimize-cxx-data *referenced-objects*) @@ -304,7 +304,7 @@ from the C language code. NIL means \"do not create the file\"." (if data-file data-file "")) (when data-file (data-c-dump data-file))) - (setf (symbol-function 'T3LOCAL-FUN) t3local-fun) + (setf (symbol-function 'T3FUNCTION) t3function) (when h-file (close *compiler-output2*)))))) nil) diff --git a/src/cmp/cmppass1-fun.lsp b/src/cmp/cmppass1-fun.lsp index 768665b25..efc1ce341 100644 --- a/src/cmp/cmppass1-fun.lsp +++ b/src/cmp/cmppass1-fun.lsp @@ -49,8 +49,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) - local-funs)))) + (push (c1compile-function (rest def) :fun fun) local-funs)))) ;; When we are in a LABELs form, we have to propagate the external ;; variables from one function to the other functions that use it. diff --git a/src/cmp/cmppass1-top.lsp b/src/cmp/cmppass1-top.lsp index 387df0fc9..16be12acc 100644 --- a/src/cmp/cmppass1-top.lsp +++ b/src/cmp/cmppass1-top.lsp @@ -180,12 +180,10 @@ (every #'global-var-p (fun-referenced-vars fun-object)) ;; Referencing the function variable (eq (c1form-name form) 'VARIABLE) - (eq (c1form-arg 0 form) - (fun-var fun-object))) + (eq (c1form-arg 0 form) (fun-var fun-object))) (when (fun-no-entry fun-object) (when macro - (cmperr "Declaration C-LOCAL used in macro ~a" - (fun-name fun-object))) + (cmperr "Declaration C-LOCAL used in macro ~a." fname)) (return-from c1fset (make-c1form* 'SI:FSET :args fun-object nil nil nil nil))) (when (and (typep macro 'boolean) From 3f2f93541133f456a193521e8cd7b05aa9f84e3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 10 Nov 2023 13:35:30 +0100 Subject: [PATCH 17/49] cmp: minor changes to emit-functions --- src/cmp/cmpbackend-cxx/cmppass2-fun.lsp | 1 - src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 23 ++++++++++------------- src/cmp/cmppass1-top.lsp | 12 ++++++++---- 3 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp index 062e450e2..93a4366d8 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp @@ -55,7 +55,6 @@ (c2expr body) (close-inline-blocks)) -;;; Mechanism for sharing code. (defun update-function-env (fun) (declare (type fun fun)) (case (fun-closure fun) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index 3b8fcfecf..7205f0ce6 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -44,11 +44,12 @@ (apply def form (c1form-args form))) (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form)))) -(defun emit-functions () +(defun emit-functions (*compiler-output1*) (declare (si::c-local)) ;; Local functions and closure functions (do ((*compile-time-too* nil) - (*compile-toplevel* nil)) + (*compile-toplevel* nil) + (*emitted-functions* nil)) ;; repeat until t3function generates no more ((eq *emitted-functions* *functions*)) ;; scan *functions* backwards @@ -81,7 +82,6 @@ (*aux-closure* nil) (c-output-file *compiler-output1*) (*compiler-output1* (make-string-output-stream)) - (*emitted-functions* nil) (*compiler-declared-globals* (make-hash-table))) (wt-nl "#include \"" (brief-namestring data-pathname) "\"") (wt-nl "#ifdef __cplusplus") @@ -115,16 +115,15 @@ ;; With this we ensure creating a constant with the tag ;; and the initialization file (wt-nl "Cblock->cblock.data_text = (const cl_object *)\"" (init-name-tag name) "\";") - (wt-nl "VVtemp = Cblock->cblock.temp_data;") - (wt-nl "ECL_DEFINE_SETF_FUNCTIONS") - (dolist (form *make-forms*) - (emit-toplevel-form form c-output-file)) + (emit-toplevel-form form)) (dolist (form *top-level-forms*) - (emit-toplevel-form form c-output-file)) - + (emit-toplevel-form form)) + ;; We process top-level forms before functions to update their + ;; environments. Then we emit functions before top level forms. + (emit-functions c-output-file) (wt-nl-close-many-braces 0) (setq top-output-string (get-output-stream-string *compiler-output1*))) @@ -170,7 +169,7 @@ (wt-nl top-output-string)) -(defun emit-toplevel-form (form c-output-file) +(defun emit-toplevel-form (form) (declare (si::c-local)) (let ((*ihs-used-p* nil) (*max-lex* 0) @@ -199,9 +198,7 @@ (wt-function-locals) (write-sequence body *compiler-output1*) (wt-nl-close-brace)) - (write-sequence body *compiler-output1*))) - (let ((*compiler-output1* c-output-file)) - (emit-functions)))) + (write-sequence body *compiler-output1*))))) (defun t2compiler-let (c1form symbols values body) (declare (ignore c1form)) diff --git a/src/cmp/cmppass1-top.lsp b/src/cmp/cmppass1-top.lsp index 16be12acc..6fca19982 100644 --- a/src/cmp/cmppass1-top.lsp +++ b/src/cmp/cmppass1-top.lsp @@ -141,7 +141,7 @@ (setf loc (add-object (cmp-eval form))))) (make-c1form* 'LOCATION :type t :args loc))) -;;; ---------------------------------------------------------------------- +;;; ---------------------------------------------------------------------------- ;;; Optimizer for FSET. Removes the need for a special handling of DEFUN as a ;;; toplevel form and also allows optimizing calls to DEFUN or DEFMACRO which ;;; are not toplevel, but which create no closures. @@ -152,9 +152,13 @@ ;;; the compiler we do not know whether a function is a closure, hence the need ;;; for a c2fset. ;;; -;;; We optimize (SYS:FSET #'(LAMBDA ...) ..) and also, accidentally, -;;; (SYS:FSET (FLET ((FOO ...)) #'FOO) ...) which is to what LAMBDA gets -;;; translated in c1function. +;;; We optimize: +;;; +;;; (SYS:FSET NAME #'(LAMBDA ...) ...) +;;; +;;; where LAMBDA is expanded by C1FUNCTION to: +;;; +;;; (SYS:FSET NAME (FLET ((FOO ...)) #'FOO)) ;;; (defun t1fset (args) (let ((form `(si::fset ,@args))) From af3d3a00c86876b35f754f504edfe4357bd3cbf7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 10 Nov 2023 14:37:29 +0100 Subject: [PATCH 18/49] cmp: with-compiler-env: handle COMPILER-INTERNAL-ERROR first We've handled COMPILER-ERROR before COMPILER-INTERNAL-ERROR, but the latter is a subclass of the former, so it was never triggered. --- src/cmp/cmputil.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 31741c87c..38782729a 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -70,8 +70,8 @@ (restart-case (handler-bind ((compiler-note #'handle-compiler-note) (warning #'handle-compiler-warning) - (compiler-error #'handle-compiler-error) (compiler-internal-error #'handle-compiler-internal-error) + (compiler-error #'handle-compiler-error) (serious-condition #'handle-compiler-internal-error)) (mp:with-lock (mp:+load-compile-lock+) (let ,+init-env-form+ From cd936a36f48bbc25b6b97250dc1624856f23dba3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 12 Nov 2023 10:37:15 +0100 Subject: [PATCH 19/49] cmp: update *destinations* description and remove dead code --- src/cmp/cmpbackend-cxx/cmppass2-eval.lsp | 8 -------- src/cmp/cmpglobals.lsp | 6 +++--- src/cmp/cmplocs.lsp | 10 +++++----- 3 files changed, 8 insertions(+), 16 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp index b46cd206f..08b8d9c26 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp @@ -211,14 +211,6 @@ (defun c2values (c1form forms) (declare (ignore c1form)) - (when (and (eq *destination* 'RETURN-OBJECT) - (rest forms) - (consp *current-form*) - (eq 'cl:DEFUN (first *current-form*))) - (cmpwarn "Trying to return multiple values. ~ - ~%;But ~a was proclaimed to have single value.~ - ~%;Only first one will be assured." - (second *current-form*))) (cond ;; When the values are not going to be used, then just ;; process each form separately. diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 878f46b50..73cc7627b 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -124,10 +124,10 @@ variable, block, tag or function object at the end.") only be altered by DECLAIM forms and it is used to initialize the value of *CMP-ENV*.") -;;; --cmplog.lsp-- +;;; --cmplocs.lsp-- ;;; -;;; Destination of output of different forms. See cmploc.lsp for types -;;; of destinations. +;;; Destination of output of different forms. See cmplocs.lsp for types of +;;; destinations. ;;; (defvar *destination*) diff --git a/src/cmp/cmplocs.lsp b/src/cmp/cmplocs.lsp index e69736b2c..04b82c9dd 100644 --- a/src/cmp/cmplocs.lsp +++ b/src/cmp/cmplocs.lsp @@ -140,13 +140,13 @@ ;;; Valid *DESTINATION* locations are: ;;; -;;; VALUE0 -;;; RETURN Object returned from current function. +;;; var-object Variable +;;; loc-object VV Location ;;; TRASH Value may be thrown away. +;;; RETURN Object returned from current function. ;;; VALUES Values vector. -;;; var-object -;;; ( LCL lcl ) -;;; ( LEX lex-address ) +;;; VALUE0 +;;; ( VALUE i ) Nth value ;;; ( BIND var alternative ) Alternative is optional ;;; ( JUMP-TRUE label ) ;;; ( JUMP-FALSE label ) From 7541d813ead3982e74298ff3e976709940fcf305 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 12 Nov 2023 11:06:17 +0100 Subject: [PATCH 20/49] cmp: improve code locality in cmppass2-var --- src/cmp/cmpbackend-cxx/cmppass2-loc.lsp | 16 ------------- src/cmp/cmpbackend-cxx/cmppass2-var.lsp | 30 ++++++++++++++++++------- 2 files changed, 22 insertions(+), 24 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp index 9a45ff098..e8c06b211 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp @@ -37,22 +37,6 @@ (t (unknown-location 'wt-loc loc)))) -(defun wt-lcl (lcl) - (unless (numberp lcl) - (baboon :format-control "wt-lcl: ~s NaN" - :format-arguments (list lcl))) - (wt "v" lcl)) - -(defun wt-lcl-loc (lcl &optional type name) - (declare (ignore type)) - (unless (numberp lcl) - (baboon :format-control "wt-lcl-loc: ~s NaN" - :format-arguments (list lcl))) - (wt "v" lcl name)) - -(defun wt-temp (temp) - (wt "T" temp)) - (defun wt-fixnum (value &optional vv) (declare (ignore vv)) (princ value *compiler-output1*) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp index 19aa0ae16..fdb4f4f61 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp @@ -20,12 +20,11 @@ (local var)) (let ((var1 (c1form-arg 0 form))) (declare (type var var1)) - (when (and ;; Fixme! We should be able to replace variable - ;; even if they are referenced across functions. - ;; We just need to keep track of their uses. - (local var1) - (eq (unboxed var) (unboxed var1)) - (not (var-changed-in-form-list var1 rest-forms))) + ;; FIXME We should be able to replace variable even if they are referenced + ;; across functions. We just need to keep track of their uses. + (when (and (local var1) + (eq (unboxed var) (unboxed var1)) + (not (var-changed-in-form-list var1 rest-forms))) (cmpdebug "Replacing variable ~a by its value" (var-name var)) (nsubst-var var form) t)))) @@ -354,8 +353,7 @@ (if (safe-compile) (wt "ecl_cmp_symbol_value(cl_env_copy," var-loc ")") (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")"))) - (t (wt var-loc)) - ))) + (t (wt var-loc))))) (defun set-var (loc var &aux (var-loc (var-loc var))) ; ccb (unless (var-p var) @@ -382,10 +380,26 @@ (wt #\;)) )) +(defun wt-lcl (lcl) + (unless (numberp lcl) + (baboon :format-control "wt-lcl: ~s NaN" + :format-arguments (list lcl))) + (wt "v" lcl)) + +(defun wt-lcl-loc (lcl &optional type name) + (declare (ignore type)) + (unless (numberp lcl) + (baboon :format-control "wt-lcl-loc: ~s NaN" + :format-arguments (list lcl))) + (wt "v" lcl name)) + (defun wt-lex (lex) (if (consp lex) (wt "lex" (car lex) "[" (cdr lex) "]") (wt-lcl lex))) +(defun wt-temp (temp) + (wt "T" temp)) + ;;; reference to variable of inner closure. (defun wt-env (clv) (wt "ECL_CONS_CAR(CLV" clv ")")) From 0041e7d8dab2732d7e7bd08f2edf8e244486ac2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Nov 2023 13:12:26 +0100 Subject: [PATCH 21/49] cmp: use correctly with-exit-label Previusly we've duplicated some code with regard to this macro, most notably we've bound *exit* separately to label instead of passing it as a first arg. --- src/cmp/cmpbackend-cxx/cmpc-util.lsp | 1 + src/cmp/cmpbackend-cxx/cmppass2-call.lsp | 10 +++----- src/cmp/cmpbackend-cxx/cmppass2-cont.lsp | 5 ++-- src/cmp/cmpbackend-cxx/cmppass2-eval.lsp | 10 +++----- src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 32 +++++++++--------------- 5 files changed, 23 insertions(+), 35 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-util.lsp b/src/cmp/cmpbackend-cxx/cmpc-util.lsp index 480075f92..24f6ae7fa 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-util.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-util.lsp @@ -93,6 +93,7 @@ (*max-temp* 0) (*next-cfun* 0) (*last-label* 0) + (*unwind-exit* nil) (*inline-information* (ext:if-let ((r (machine-inline-information *machine*))) (si:copy-hash-table r) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp index e444642c1..9298bc394 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp @@ -101,12 +101,10 @@ (tail-recursion-possible) (inline-possible (fun-name fun)) (= (length args) (length (rest *tail-recursion-info*)))) - (let* ((*destination* 'TRASH) - (*exit* (next-label)) - (*unwind-exit* (cons *exit* *unwind-exit*))) - (c2psetq nil ;; We do not provide any C2FORM - (cdr *tail-recursion-info*) args) - (wt-label *exit*)) + (with-exit-label (*exit*) + (let ((*destination* 'TRASH)) + ;; We do not provide any C2FORM. + (c2psetq nil (cdr *tail-recursion-info*) args))) (unwind-no-exit 'TAIL-RECURSION-MARK) (wt-nl "goto TTL;") (cmpdebug "Tail-recursive call of ~s was replaced by iteration." diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp index 2141be826..9f76b69d4 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp @@ -164,9 +164,8 @@ (wt-nl "if (__ecl_frs_push_result) {") (wt-comment "BEGIN CATCH ~A" code) (with-indentation - (with-exit-label (label) - (let ((*exit* label)) - (unwind-exit 'VALUES)))) + (with-exit-label (*exit*) + (unwind-exit 'VALUES))) (wt-nl "} else {") (with-indentation (c2expr* body))))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp index 08b8d9c26..c9015e5dc 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp @@ -26,12 +26,10 @@ ;; other expressions will follow this one. We must thus create ;; a possible label so that the compiled forms exit right at ;; the point where the next form will be compiled. - (with-exit-label (label) - (let* ((*exit* label) - (*unwind-exit* (cons *exit* *unwind-exit*)) - ;;(*lex* *lex*) - (*lcl* *lcl*) - (*temp* *temp*)) + (with-exit-label (*exit*) + (let (;;(*lex* *lex*) + (*lcl* *lcl*) + (*temp* *temp*)) (c2expr form)))) (defun c2progn (c1form forms) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index 7205f0ce6..dfdbe3594 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -245,35 +245,27 @@ (defun t2ordinary (c1form form) (declare (ignore c1form)) - (let* ((*exit* (next-label)) - (*unwind-exit* (list *exit*)) - (*destination* 'TRASH)) - (c2expr form) - (wt-label *exit*))) + (with-exit-label (*exit*) + (let ((*destination* 'TRASH)) + (c2expr form)))) (defun t2load-time-value (c1form vv-loc form) (declare (ignore c1form)) - (let* ((*exit* (next-label)) - (*unwind-exit* (list *exit*)) - (*destination* vv-loc)) - (c2expr form) - (wt-label *exit*))) + (with-exit-label (*exit*) + (let ((*destination* vv-loc)) + (c2expr form)))) (defun t2make-form (c1form vv-loc form) (declare (ignore c1form)) - (let* ((*exit* (next-label)) - (*unwind-exit* (list *exit*)) - (*destination* vv-loc)) - (c2expr form) - (wt-label *exit*))) + (with-exit-label (*exit*) + (let ((*destination* vv-loc)) + (c2expr form)))) (defun t2init-form (c1form vv-loc form) (declare (ignore c1form vv-loc)) - (let* ((*exit* (next-label)) - (*unwind-exit* (list *exit*)) - (*destination* 'TRASH)) - (c2expr form) - (wt-label *exit*))) + (with-exit-label (*exit*) + (let ((*destination* 'TRASH)) + (c2expr form)))) (defun locative-type-from-var-kind (kind) (cdr (assoc kind From 51da30dd61cbe0da4c260e17bfd42c9cb0ea08de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Nov 2023 16:41:14 +0100 Subject: [PATCH 22/49] cmp: move build-debug-lexical-env to cmppass2-var --- src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 59 ------------------------- src/cmp/cmpbackend-cxx/cmppass2-var.lsp | 57 ++++++++++++++++++++++++ 2 files changed, 57 insertions(+), 59 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index dfdbe3594..43d11390b 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -267,71 +267,12 @@ (let ((*destination* 'TRASH)) (c2expr form)))) -(defun locative-type-from-var-kind (kind) - (cdr (assoc kind - '((:object . "_ecl_object_loc") - (:fixnum . "_ecl_fixnum_loc") - (:char . "_ecl_base_char_loc") - (:float . "_ecl_float_loc") - (:double . "_ecl_double_loc") - (:long-double . "_ecl_long_double_loc") - #+complex-float (:csfloat . "_ecl_csfloat_loc") - #+complex-float (:cdfloat . "_ecl_cdfloat_loc") - #+complex-float (:clfloat . "_ecl_clfloat_loc") - #+sse2 (:int-sse-pack . "_ecl_int_sse_pack_loc") - #+sse2 (:float-sse-pack . "_ecl_float_sse_pack_loc") - #+sse2 (:double-sse-pack . "_ecl_double_sse_pack_loc") - ((special global closure lexical) . NIL))))) - -(defun build-debug-lexical-env (var-locations &optional first) - #-:msvc ;; FIXME! Problem with initialization of statically defined vectors - (let* ((filtered-locations '()) - (filtered-codes '())) - ;; Filter out variables that we know how to store in the debug information - ;; table. This excludes among other things closures and special variables. - (loop for var in var-locations - for name = (let ((*package* (find-package "KEYWORD"))) - (format nil "\"~S\"" (var-name var))) - for code = (locative-type-from-var-kind (var-kind var)) - for loc = (var-loc var) - when (and code (consp loc) (eq (first loc) 'LCL)) - do (progn - (push (cons name code) filtered-codes) - (push loc filtered-locations))) - ;; Generate two tables, a static one with information about the variables, - ;; including name and type, and dynamic one, which is a vector of pointer to - ;; the variables. - (when filtered-codes - (setf *ihs-used-p* t) - (wt-nl "static const struct ecl_var_debug_info _ecl_descriptors[]={") - (loop for (name . code) in filtered-codes - for i from 0 - do (wt-nl (if (zerop i) "{" ",{") name "," code "}")) - (wt "};") - (wt-nl "const cl_index _ecl_debug_info_raw[]={") - (wt-nl (if first "(cl_index)(ECL_NIL)," "(cl_index)(_ecl_debug_env),") - "(cl_index)(_ecl_descriptors)") - (loop for var-loc in filtered-locations - do (wt ",(cl_index)(&" var-loc ")")) - (wt "};") - (wt-nl "ecl_def_ct_vector(_ecl_debug_env,ecl_aet_index,_ecl_debug_info_raw," - (+ 2 (length filtered-locations)) - ",,);") - (unless first - (wt-nl "ihs.lex_env = _ecl_debug_env;"))) - filtered-codes)) - -(defun pop-debug-lexical-env () - (wt-nl "ihs.lex_env = _ecl_debug_env;")) - (defun t3function (fun) (declare (type fun fun)) - ;; Compiler note about compiling this function (when *compile-print* (ext:when-let ((name (or (fun-name fun) (fun-description fun)))) (format t "~&;;; Emitting code for ~s.~%" name))) - (let* ((lambda-expr (fun-lambda fun)) (*cmp-env* (c1form-env lambda-expr)) (*lcl* 0) (*temp* 0) (*max-temp* 0) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp index fdb4f4f61..967dae1d0 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp @@ -29,6 +29,63 @@ (nsubst-var var form) t)))) +(defun locative-type-from-var-kind (kind) + (cdr (assoc kind + '((:object . "_ecl_object_loc") + (:fixnum . "_ecl_fixnum_loc") + (:char . "_ecl_base_char_loc") + (:float . "_ecl_float_loc") + (:double . "_ecl_double_loc") + (:long-double . "_ecl_long_double_loc") + #+complex-float (:csfloat . "_ecl_csfloat_loc") + #+complex-float (:cdfloat . "_ecl_cdfloat_loc") + #+complex-float (:clfloat . "_ecl_clfloat_loc") + #+sse2 (:int-sse-pack . "_ecl_int_sse_pack_loc") + #+sse2 (:float-sse-pack . "_ecl_float_sse_pack_loc") + #+sse2 (:double-sse-pack . "_ecl_double_sse_pack_loc") + ((special global closure lexical) . NIL))))) + +(defun build-debug-lexical-env (var-locations &optional first) + #-:msvc ;; FIXME! Problem with initialization of statically defined vectors + (let* ((filtered-locations '()) + (filtered-codes '())) + ;; Filter out variables that we know how to store in the debug information + ;; table. This excludes among other things closures and special variables. + (loop for var in var-locations + for name = (let ((*package* (find-package "KEYWORD"))) + (format nil "\"~S\"" (var-name var))) + for code = (locative-type-from-var-kind (var-kind var)) + for loc = (var-loc var) + when (and code (consp loc) (eq (first loc) 'LCL)) + do (progn + (push (cons name code) filtered-codes) + (push loc filtered-locations))) + ;; Generate two tables, a static one with information about the variables, + ;; including name and type, and dynamic one, which is a vector of pointer to + ;; the variables. + (when filtered-codes + (setf *ihs-used-p* t) + (wt-nl "static const struct ecl_var_debug_info _ecl_descriptors[]={") + (loop for (name . code) in filtered-codes + for i from 0 + do (wt-nl (if (zerop i) "{" ",{") name "," code "}")) + (wt "};") + (wt-nl "const cl_index _ecl_debug_info_raw[]={") + (wt-nl (if first "(cl_index)(ECL_NIL)," "(cl_index)(_ecl_debug_env),") + "(cl_index)(_ecl_descriptors)") + (loop for var-loc in filtered-locations + do (wt ",(cl_index)(&" var-loc ")")) + (wt "};") + (wt-nl "ecl_def_ct_vector(_ecl_debug_env,ecl_aet_index,_ecl_debug_info_raw," + (+ 2 (length filtered-locations)) + ",,);") + (unless first + (wt-nl "ihs.lex_env = _ecl_debug_env;"))) + filtered-codes)) + +(defun pop-debug-lexical-env () + (wt-nl "ihs.lex_env = _ecl_debug_env;")) + (defun c2let* (c1form vars forms body &aux (*volatile* (c1form-volatile* c1form)) From cebb13f979534d6c3044d93120f02add01e49035 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Nov 2023 17:12:12 +0100 Subject: [PATCH 23/49] cmp: don't allow for t2expr arguments not being c1forms. --- src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index 43d11390b..aa4316e00 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -34,15 +34,15 @@ ;;;; CMPTOP -- Compiler top-level. (defun t2expr (form) - (when form - (ext:if-let ((def (gethash (c1form-name form) *t2-dispatch-table*))) - (let ((*compile-file-truename* (c1form-file form)) - (*compile-file-position* (c1form-file-position form)) - (*current-toplevel-form* (c1form-form form)) - (*current-form* (c1form-form form)) - (*cmp-env* (c1form-env form))) - (apply def form (c1form-args form))) - (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form)))) + (check-type form c1form) + (ext:if-let ((def (gethash (c1form-name form) *t2-dispatch-table*))) + (let ((*compile-file-truename* (c1form-file form)) + (*compile-file-position* (c1form-file-position form)) + (*current-toplevel-form* (c1form-form form)) + (*current-form* (c1form-form form)) + (*cmp-env* (c1form-env form))) + (apply def form (c1form-args form))) + (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form))) (defun emit-functions (*compiler-output1*) (declare (si::c-local)) From 255e22951980c150f77caa1cf276d7891840b748 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Nov 2023 18:18:52 +0100 Subject: [PATCH 24/49] cmp: factor out wt-install-function from c2fset --- src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 32 +++++++++++++------------ 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index aa4316e00..f94d908f2 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -434,28 +434,30 @@ cfun (fun-file-position fun)))) (format stream "~%};"))))) +(defun wt-install-function (fname fun macro-p) + (let ((*inline-blocks* 0) + (loc (data-empty-loc*))) + (push (list loc fname fun) *global-cfuns-array*) + ;; FIXME! Look at C2LOCALS! + (update-function-env fun) + (if macro-p + (wt-nl "ecl_cmp_defmacro(" loc ");") + (wt-nl "ecl_cmp_defun(" loc ");")) + (wt-comment (loc-immediate-value fname)) + (close-inline-blocks))) + (defun t2fset (c1form &rest args) (declare (ignore args)) - (t2ordinary nil c1form)) + (t2ordinary c1form c1form)) -(defun c2fset (c1form fun fname macro pprint c1forms) +(defun c2fset (c1form fun fname macro-p pprint c1forms) (declare (ignore pprint)) (when (fun-no-entry fun) (wt-nl "(void)0; " (format nil "/* No entry created for ~A */" (fun-name fun))) ;; FIXME! Look at C2LOCALS! (update-function-env fun) (return-from c2fset)) - (unless (and (not (fun-closure fun)) - (eq *destination* 'TRASH)) - (return-from c2fset + (if (and (not (fun-closure fun)) + (eq *destination* 'TRASH)) + (wt-install-function fname fun macro-p) (c2call-global c1form 'SI:FSET c1forms))) - (let ((*inline-blocks* 0) - (loc (data-empty-loc*))) - (push (list loc fname fun) *global-cfuns-array*) - ;; FIXME! Look at C2LOCALS! - (update-function-env fun) - (if macro - (wt-nl "ecl_cmp_defmacro(" loc ");") - (wt-nl "ecl_cmp_defun(" loc ");")) - (wt-comment (loc-immediate-value fname)) - (close-inline-blocks))) From 97411d9e32975fd63bd1f7e5a925c33a4f483f11 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Nov 2023 21:00:15 +0100 Subject: [PATCH 25/49] cmp: unwind-exit: remove unused optional argument We move jump-p flag to aux variables. --- src/cmp/cmpbackend-cxx/cmppass2-exit.lsp | 2 +- src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp | 2 +- src/cmp/cmpbackend-cxx/cmppass2-fun.lsp | 3 +-- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp index b86146b0b..f77f4de66 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp @@ -60,7 +60,7 @@ (wt-nl "ihs.lex_env = _ecl_debug_env;"))) some)) -(defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil)) +(defun unwind-exit (loc &aux (jump-p nil) (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil)) (declare (fixnum bds-bind)) (when (consp *destination*) (case (car *destination*) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp index 01342c6b5..144636513 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp @@ -57,7 +57,7 @@ ) (t (c2expr* form))) - finally (unwind-exit nil))) + finally (unwind-exit *vv-nil*))) (defun c2c-inline (c1form arguments &rest rest) (declare (ignore c1form)) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp index 93a4366d8..a4976c695 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp @@ -20,8 +20,7 @@ (*inline-blocks* 0) (*env-lvl* *env-lvl*)) (declare (ignore c1form labels)) - ;; create location for each function which is returned, - ;; either in lexical: + ;; create location for each function which is returned, either in lexical: (loop with env-grows = nil with closed-vars = '() for fun in funs From 77f0810d22dd1813db2fa83046a41dcd96f48f94 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 14 Nov 2023 11:09:48 +0100 Subject: [PATCH 26/49] cmp: c2catch uses GENSYM instead of incrementing *last-label* The assigned "code" is only part of the comment, so it is clearly not the label. --- src/cmp/cmpbackend-cxx/cmppass2-cont.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp index 9f76b69d4..4aa709087 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp @@ -146,7 +146,7 @@ (defun c2catch (c1form tag body) (declare (ignore c1form)) (let* ((new-destination (tmp-destination *destination*)) - (code (incf *last-label*))) + (code (gensym "CATCH"))) (let ((*destination* 'VALUE0)) (c2expr* tag)) (let* ((*destination* new-destination) From c879cb16c09598384fe8642b3dda292db6a02d6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 14 Nov 2023 12:12:17 +0100 Subject: [PATCH 27/49] cmp: make LABEL an instance (not a cons) --- src/cmp/cmpbackend-cxx/cmpc-util.lsp | 28 +++---- src/cmp/cmpbackend-cxx/cmpc-wt.lsp | 8 +- src/cmp/cmpbackend-cxx/cmppass2-call.lsp | 4 +- src/cmp/cmpbackend-cxx/cmppass2-cont.lsp | 6 +- src/cmp/cmpbackend-cxx/cmppass2-exit.lsp | 95 ++++++++++++------------ 5 files changed, 72 insertions(+), 69 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-util.lsp b/src/cmp/cmpbackend-cxx/cmpc-util.lsp index 24f6ae7fa..ed3c1b1b2 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-util.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-util.lsp @@ -44,17 +44,16 @@ ;;; --cmpexit.lsp-- ;;; -;;; *last-label* holds the label# of the last used label. ;;; *exit* holds an 'exit', which is -;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM, +;; LABEL instance or one of RETURNs (i.e. RETURN, RETURN-FIXNUM, ;; RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, ;; RETURN-CSFLOAT, RETURN-CDFLOAT, RETURN-CLFLOAT or RETURN-OBJECT). ;;; *unwind-exit* holds a list consisting of: -;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME, +;; LABEL instance, one of RETURNs, TAIL-RECURSION-MARK, FRAME, ;; JUMP, BDS-BIND (each pushed for a single special binding), or a ;; LCL (which holds the bind stack pointer used to unbind). ;;; -(defvar *last-label* 0) + (defvar *exit*) (defvar *unwind-exit*) @@ -148,25 +147,26 @@ (let ((code (incf *next-cfun*))) (format nil prefix code (lisp-to-c-name lisp-name)))) -;;; (CAR label) is a an unique id of the label in the compilation unit. -;;; (CDR label) is a flag signaling whether the label is referenced. + +;;; *LAST-LABEL* holds the label# of the last used label. This is used by the +;;; code generator to avoid duplicated labels in the same scope. -(defun next-label () - (cons (incf *last-label*) nil)) +(defvar *last-label* 0) -(defun next-label* () - (cons (incf *last-label*) t)) +(defstruct (label (:predicate labelp)) + id + used-p) -(defun labelp (x) - (and (consp x) (integerp (si:cons-car x)))) +(defun next-label (used-p) + (make-label :id (incf *last-label*) :used-p used-p)) (defun maybe-next-label () (if (labelp *exit*) *exit* - (next-label))) + (next-label nil))) (defmacro with-exit-label ((label) &body body) - `(let* ((,label (next-label)) + `(let* ((,label (next-label nil)) (*unwind-exit* (cons ,label *unwind-exit*))) ,@body (wt-label ,label))) diff --git a/src/cmp/cmpbackend-cxx/cmpc-wt.lsp b/src/cmp/cmpbackend-cxx/cmpc-wt.lsp index 3a3bc3699..3efd1f76d 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-wt.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-wt.lsp @@ -111,12 +111,12 @@ ;;; (defun wt-go (label) - (setf (cdr label) t - label (car label)) - (wt "goto L" label ";")) + (setf (label-used-p label) t) + (wt "goto L" (label-id label) ";")) (defun wt-label (label) - (when (cdr label) (wt-nl1 "L" (car label) ":;"))) + (when (label-used-p label) + (wt-nl1 "L" (label-id label) ":;"))) ;;; ;;; C/C++ COMMENTS diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp index 9298bc394..7f22f9261 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp @@ -84,9 +84,9 @@ (baboon :format-control "tail-recursion-possible: should never return.")) (cond ((eq ue 'TAIL-RECURSION-MARK) (return t)) - ((or (numberp ue) (eq ue 'BDS-BIND) (eq ue 'FRAME)) + ((or (eq ue 'BDS-BIND) (eq ue 'FRAME)) (return nil)) - ((or (consp ue) (eq ue 'JUMP) (eq ue 'IHS-ENV))) + ((or (consp ue) (labelp ue) (eq ue 'IHS-ENV))) (t (baboon :format-control "tail-recursion-possible: unexpected situation."))))) (defun last-call-p () diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp index 4aa709087..9678cf318 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp @@ -66,7 +66,7 @@ (dolist (x body (c2tagbody-body body)) ;; Allocate labels. (when (and (tag-p x) (plusp (tag-ref x))) - (setf (tag-label x) (next-label*)) + (setf (tag-label x) (next-label t)) (setf (tag-unwind-exit x) *unwind-exit*))) ;; some tag used non locally or inside an unwind-protect (let ((*unwind-exit* (cons 'FRAME *unwind-exit*)) @@ -90,7 +90,7 @@ ;; Allocate labels. (dolist (tag body) (when (and (tag-p tag) (plusp (tag-ref tag))) - (setf (tag-label tag) (next-label)) + (setf (tag-label tag) (next-label nil)) (setf (tag-unwind-exit tag) *unwind-exit*) (wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))") (wt-go (tag-label tag)))) @@ -116,7 +116,7 @@ (let* ((next-form (second l)) (*exit* (if (tag-p next-form) (tag-label next-form) - (next-label))) + (next-label nil))) (*unwind-exit* (cons *exit* *unwind-exit*)) (*destination* 'TRASH)) (c2expr this-form) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp index f77f4de66..51fbde887 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp @@ -22,7 +22,7 @@ ;;; IHS -> ihs push ;;; IHS-ENV -> ihs push ;;; BDS-BIND -> binding of 1 special variable -;;; (number . {T|NIL}) -> label +;;; #