From f074f1087b62eec59e58661ad57080b6a5ccacc7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 30 Nov 2023 18:24:41 +0100 Subject: [PATCH 01/24] cmp: cleanup: remove unused function --- src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp index 846033d49..2be583e1b 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp @@ -160,11 +160,6 @@ for form = (first form-list) collect (emit-inline-form form (rest form-list)))) -(defun destination-type () - (rep-type->lisp-type (loc-representation-type *destination*)) - ;;(loc-type *destination*) -) - (defun maybe-open-inline-block () (unless (plusp *inline-blocks*) (open-inline-block))) From b3e85f1014204d25336f970913dc1b605b36e7b9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 30 Nov 2023 15:15:19 +0100 Subject: [PATCH 02/24] cmp: move misplaced comment to cmpc-inl-sysfun --- src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp | 18 ++++++++++++++++++ src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp | 18 ------------------ 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp index 5e2ad26e6..831e43985 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp @@ -28,6 +28,24 @@ ;;; compilation mode, respectively. ;;; +;;; Valid property names for open coded functions are: +;;; :INLINE-ALWAYS +;;; :INLINE-UNSAFE non-safe-compile only +;;; +;;; Each property is a list of 'inline-info's, where each inline-info is: +;;; ( types { type | boolean } { string | function } ). +;;; +;;; For each open-codable function, open coding will occur only if there exits +;;; an appropriate property with the argument types equal to 'types' and with +;;; the return-type equal to 'type'. +;;; +;;; The third element is T if and only if side effects may occur by the call of +;;; the function. Even if *DESTINATION* is TRASH, open code for such a function +;;; with side effects must be included in the compiled code. +;;; +;;; The forth element is T if and only if the result value is a new Lisp object, +;;; i.e., it must be explicitly protected against GBC. + (defun inline-information (name safety) (gethash (list name safety) *inline-information*)) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp index 2be583e1b..e580013ef 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp @@ -12,24 +12,6 @@ (in-package "COMPILER") -;;; Valid property names for open coded functions are: -;;; :INLINE-ALWAYS -;;; :INLINE-UNSAFE non-safe-compile only -;;; -;;; Each property is a list of 'inline-info's, where each inline-info is: -;;; ( types { type | boolean } { string | function } ). -;;; -;;; For each open-codable function, open coding will occur only if there exits -;;; an appropriate property with the argument types equal to 'types' and with -;;; the return-type equal to 'type'. -;;; -;;; The third element is T if and only if side effects may occur by the call of -;;; the function. Even if *DESTINATION* is TRASH, open code for such a function -;;; with side effects must be included in the compiled code. -;;; -;;; The forth element is T if and only if the result value is a new Lisp object, -;;; i.e., it must be explicitly protected against GBC. - (defun make-inline-temp-var (value-type &optional rep-type) (let ((out-rep-type (or rep-type (lisp-type->rep-type value-type)))) (if (eq out-rep-type :object) From b4da521398c039fc6670703c4cb14e3984591455 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 30 Nov 2023 07:53:34 +0100 Subject: [PATCH 03/24] cmp: set-loc: fix a braino (don't access special variable) set-loc saves the location to the destination, and while doing so it coerces the former to the type of the latter. Our code used *destination* as the argument to LOC-REPRESENTATION-TYPE, but DESTINATION and *DESTINATION* may not be the same. --- src/cmp/cmpbackend-cxx/cmppass2-loc.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp index 43b58576d..7f0f85913 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp @@ -403,7 +403,7 @@ (progn (wt-nl) (wt-loc destination) (wt " = ") - (wt-coerce-loc (loc-representation-type *destination*) loc) + (wt-coerce-loc (loc-representation-type destination) loc) (wt ";")))))) (defun set-the-loc (loc type orig-loc) From 397dc995d4c09c4997626326be4da3b2dd30d837 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 28 Nov 2023 09:11:41 +0100 Subject: [PATCH 04/24] cmp: cosmetic changes, elaborate in a comment --- src/cmp/cmpbackend-cxx/cmppass2-call.lsp | 3 +++ src/cmp/cmppass1-call.lsp | 14 ++++++-------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp index dc0238668..6eb5919b2 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp @@ -36,6 +36,9 @@ ;;; FUN the function to be called ;;; ARGS is the list of arguments ;;; FUN-VAL depends on the particular call type +;;; :LOCAL structure FUN [see cmprefs.lsp] +;;; :GLOBAL function name [symbol or (SETF symbol)] +;;; :UNKNOWN the value NIL ;;; CALL-TYPE is (member :LOCAL :GLOBAL :UKNOWN) ;;; (defun c2fcall (c1form fun args fun-val call-type) diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index 37ae6c8ba..6d02ed80f 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -238,14 +238,12 @@ :args (c1expr `(function ,fname)) (c1args* args) fun :local)) (defun c1call-global (fname args) - (let* ((forms (c1args* args))) - ;; If all arguments are constants, try to precompute the function - ;; value. We abort when the function signals an error or the value - ;; is not printable. - (let ((value (c1call-constant-fold fname forms))) - (when value - (return-from c1call-global value))) - ;; Otherwise emit a global function call + (let ((forms (c1args* args))) + ;; If all arguments are constants, try to precompute the function value. We + ;; abort when the function signals an error or the value is not printable. + (ext:when-let ((value (c1call-constant-fold fname forms))) + (return-from c1call-global value)) + ;; Otherwise emit a global function call. (make-c1form* 'FCALL :sp-change (function-may-change-sp fname) :side-effects (function-may-have-side-effects fname) From 141231f2fe5ba465ac9a0a9187d864e839fd91c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 28 Nov 2023 11:28:34 +0100 Subject: [PATCH 05/24] cmp: remove dead code --- src/cmp/cmplocs.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cmp/cmplocs.lsp b/src/cmp/cmplocs.lsp index 3b00d68b1..0497ef6a9 100644 --- a/src/cmp/cmplocs.lsp +++ b/src/cmp/cmplocs.lsp @@ -183,7 +183,7 @@ (defun uses-values (loc) (and (consp loc) - (or (member (car loc) '(CALL CALL-NORMAL CALL-INDIRECT CALL-STACK) :test #'eq) + (or (member (car loc) '(CALL-NORMAL CALL-INDIRECT CALL-STACK) :test #'eq) (and (eq (car loc) 'ffi:C-INLINE) (eq (sixth loc) 'cl:VALUES))))) From 364deb0551f4e62497aa7e7649be77bf47d478a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 22 Nov 2023 11:23:22 +0100 Subject: [PATCH 06/24] cmp: remove unused bindings EMIT-TOPLEVEL-FORM bound *compile-file-truename* and *compile-file-position* to be immedietely rebound in T2EXPR (to the same value!). *COMPILE-TO-LINKING-CALL* is not used anywhere. --- src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 5 +---- src/cmp/cmpglobals.lsp | 4 ---- src/cmp/cmppackage.lsp | 1 - src/compile.lsp.in | 4 ++-- 4 files changed, 3 insertions(+), 11 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index 78e00de5d..0228290f5 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -179,10 +179,7 @@ (*level* 0) (*env* 0) (*env-lvl* 0) - (*temp* 0) - (*compile-to-linking-call* nil) - (*compile-file-truename* (and form (c1form-file form))) - (*compile-file-position* (and form (c1form-file-position form)))) + (*temp* 0)) ;; We save the C body of the statement, indented, just in case ;; we need to add a {} section with the environment variables. (let ((body (let ((*opened-c-braces* (1+ *opened-c-braces*))) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 73cc7627b..135d31b6e 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -71,10 +71,6 @@ running the compiler. It may be updated by running ") (defvar *machine* nil) ;;; --cmpcall.lsp-- -;;; -;;; Whether to use linking calls. -;;; -(defvar *compile-to-linking-call* t) (defvar *compiler-declared-globals*) ;;; --cmpenv.lsp-- diff --git a/src/cmp/cmppackage.lsp b/src/cmp/cmppackage.lsp index 7b11df5c7..62ef2bc16 100644 --- a/src/cmp/cmppackage.lsp +++ b/src/cmp/cmppackage.lsp @@ -19,7 +19,6 @@ ;; Flags controlling the compiler behavior. "*COMPILER-BREAK-ENABLE*" "*COMPILE-PRINT*" - "*COMPILE-TO-LINKING-CALL*" "*COMPILE-VERBOSE*" "*COMPILER-FEATURES*" "*CC*" diff --git a/src/compile.lsp.in b/src/compile.lsp.in index bf52484b7..b818ba97c 100755 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -125,8 +125,8 @@ :system-p t :c-file t :data-file t :h-file t ;;:shared-data-file "build:ecl.sdat" ))) - #+CLOS - (let* ((c::*compile-to-linking-call* nil)) + #+clos + (progn (mapc #'proclaim +ecl-optimization-settings+) (setq lsp-objects (append lsp-objects (compile-if-old "build:clos;" +clos-module-files+ From def52d965722c3890d425755b4f934aff49c5c50 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 22 Nov 2023 11:32:43 +0100 Subject: [PATCH 07/24] cmp: pull emit-toplevel-form into emit-entry-fun Instead of mincing blocks form-by-form, we put them all in a single function environment and make them share locals. --- src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 60 ++++++++++++------------- 1 file changed, 29 insertions(+), 31 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index 0228290f5..2236cc677 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -62,7 +62,17 @@ (defun emit-entry-fun (name *compiler-output1*) (let* ((*opened-c-braces* 0) - (*aux-closure* nil)) + (*aux-closure* nil) + (*ihs-used-p* nil) + (*max-lex* 0) + (*max-env* 0) + (*max-temp* 0) + (*lcl* 0) + (*lex* 0) + (*level* 0) + (*env* 0) + (*env-lvl* 0) + (*temp* 0)) (wt-nl "ECL_DLLEXPORT void " name "(cl_object flag)") (wt-nl-open-brace) (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") @@ -93,10 +103,24 @@ (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)) - (dolist (form *top-level-forms*) - (emit-toplevel-form form)) + ;; We save the C body of the statement, indented, just in case we need to + ;; add a {} section with the environment variables. + (let ((body (let ((*opened-c-braces* (1+ *opened-c-braces*))) + (with-output-to-string (*compiler-output1*) + (wt-comment-nl "MAKE-LOAD-FORMs") + (dolist (form *make-forms*) + (t2expr form)) + (wt-comment-nl "TOP-LEVEL-FORMs") + (dolist (form *top-level-forms*) + (t2expr form)))))) + (if (or (plusp *max-lex*) + (plusp *max-temp*) + (plusp *max-env*) + *ihs-used-p*) + (with-lexical-scope () + (wt-function-locals) + (write-sequence body *compiler-output1*)) + (write-sequence body *compiler-output1*))) ;; We process top-level forms before functions to update their ;; environments. Then we emit functions before top level forms. (wt-nl-close-many-braces 0))) @@ -168,32 +192,6 @@ (wt-nl "#endif") (wt-nl top-output-string)) -(defun emit-toplevel-form (form) - (declare (si::c-local)) - (let ((*ihs-used-p* nil) - (*max-lex* 0) - (*max-env* 0) - (*max-temp* 0) - (*lcl* 0) - (*lex* 0) - (*level* 0) - (*env* 0) - (*env-lvl* 0) - (*temp* 0)) - ;; We save the C body of the statement, indented, just in case - ;; we need to add a {} section with the environment variables. - (let ((body (let ((*opened-c-braces* (1+ *opened-c-braces*))) - (with-output-to-string (*compiler-output1*) - (t2expr form))))) - (if (or (plusp *max-lex*) - (plusp *max-temp*) - (plusp *max-env*) - *ihs-used-p*) - (with-lexical-scope () - (wt-function-locals) - (write-sequence body *compiler-output1*)) - (write-sequence body *compiler-output1*))))) - (defun t2compiler-let (c1form symbols values body) (declare (ignore c1form)) (progv symbols values (c2expr body))) From c2ffcc5deb67472aea046c4acd271c9802c818b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 22 Nov 2023 13:29:48 +0100 Subject: [PATCH 08/24] cmp: introduce a separate environment for functions There is an environment for the backend, and there is a separate environment for each function. --- src/cmp/cmpbackend-cxx/cmpc-util.lsp | 31 ++- src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp | 42 ---- src/cmp/cmpbackend-cxx/cmppass2-top.lsp | 318 +++++++++++++----------- 3 files changed, 195 insertions(+), 196 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-util.lsp b/src/cmp/cmpbackend-cxx/cmpc-util.lsp index f49e7c17d..c0f8953cc 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-util.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-util.lsp @@ -85,13 +85,9 @@ ;;; (defmacro with-cxx-env (() &body body) - `(let ((*inline-blocks* 0) - (*open-c-braces* 0) - (*temp* 0) - (*max-temp* 0) + `(let ((*opened-c-braces* 0) + (*inline-blocks* 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) @@ -105,6 +101,29 @@ (*compiler-declared-globals* (make-hash-table))) ,@body)) +;;; Block IR creation environment. +;;; FIXME Still mixed with CXX bits. Clean this up while separating the backend. +(defmacro with-bir-env ((&key env level volatile) &body body) + `(let* ((*lcl* 0) + (*temp* 0) + (*max-temp* 0) + (*lex* 0) + (*max-lex* 0) + (*env-lvl* 0) + (*env* ,env) + (*max-env* *env*) + (*level* ,level) + (*last-label* 0) + (*volatile* ,volatile) + ;; + (*ihs-used-p* nil) + (*aux-closure* nil) + ;; + (*exit* 'LEAVE) + (*unwind-exit* '(LEAVE)) + (*destination* *exit*)) + ,@body)) + (defun-cached env-var-name (n) eql (format nil "env~D" n)) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp index 92915b386..019bfc57e 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp @@ -65,45 +65,3 @@ (*temp* *temp*)) (unwind-exit (apply #'produce-inline-loc (inline-args arguments) rest)) (close-inline-blocks))) - -(defun t3-defcallback (lisp-name c-name c-name-constant return-type return-type-code - arg-types arg-type-constants call-type &aux (return-p t)) - (declare (ignore lisp-name)) - (when (eql return-type :void) - (setf return-p nil)) - (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type))) - (vars (loop for n from 0 below (length arg-types) - collect (format nil "var~d" n))) - (fmod (case call-type - ((:cdecl :default) "") - (:stdcall "__stdcall ") - (t (cmperr "DEFCALLBACK does not support ~A as calling convention" - call-type))))) - (wt-nl-h "static " return-type-name " " fmod c-name "(") - (wt-nl1 "static " return-type-name " " fmod c-name "(") - (loop with comma = "" - for var in vars - for type in arg-types - for arg-type-name = (rep-type->c-name (ffi::%convert-to-arg-type type)) - do (wt-h comma arg-type-name " " var) - (wt comma arg-type-name " " var) - (setf comma ",")) - (wt ")") - (wt-h ");") - (with-lexical-scope () - (when return-p - (wt-nl return-type-name " output;")) - (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") - (wt-nl "cl_object aux;") - (with-stack-frame (frame) - (loop for var in vars - and type in arg-types - and ct in arg-type-constants - do (wt-nl "ecl_stack_frame_push(" frame "," `(ffi-data-ref ,var ,ct) ");")) - (wt-nl "aux = ecl_apply_from_stack_frame(" frame "," - "ecl_fdefinition(" c-name-constant "));") - ;; No UNWIND-EXIT, so we must close the frame manually. - (wt-nl "ecl_stack_frame_close(" frame ");")) - (when return-p - (set-loc `(ffi-data-ref "output" ,return-type-code) "aux") - (wt-nl "return output;"))))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index 2236cc677..5206ba632 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -44,6 +44,55 @@ (apply def form (c1form-args form))) (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form))) +(defun t2compiler-let (c1form symbols values body) + (declare (ignore c1form)) + (progv symbols values (c2expr body))) + +(defun t2progn (c1form args) + (declare (ignore c1form)) + (mapc #'t2expr args)) + +(defun t2ordinary (c1form form) + (declare (ignore c1form)) + (with-exit-label (*exit*) + (let ((*destination* 'TRASH)) + (c2expr form)))) + +(defun t2load-time-value (c1form vv-loc form) + (declare (ignore c1form)) + (with-exit-label (*exit*) + (let ((*destination* vv-loc)) + (c2expr form)))) + +(defun t2make-form (c1form vv-loc form) + (declare (ignore c1form)) + (with-exit-label (*exit*) + (let ((*destination* vv-loc)) + (c2expr form)))) + +(defun t2init-form (c1form vv-loc form) + (declare (ignore c1form vv-loc)) + (with-exit-label (*exit*) + (let ((*destination* 'TRASH)) + (c2expr form)))) + +(defun t2fset (c1form &rest args) + (declare (ignore args)) + (t2ordinary c1form c1form)) + +(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)) + (if (and (not (fun-closure fun)) + (eq *destination* 'TRASH)) + (wt-install-function fname fun macro-p) + (c2call-global c1form 'SI:FSET c1forms))) + + (defun emit-functions (*compiler-output1*) (declare (si::c-local)) ;; Local functions and closure functions @@ -60,73 +109,7 @@ ;; so disassemble can redefine it (t3function (first lfs))))))) -(defun emit-entry-fun (name *compiler-output1*) - (let* ((*opened-c-braces* 0) - (*aux-closure* nil) - (*ihs-used-p* nil) - (*max-lex* 0) - (*max-env* 0) - (*max-temp* 0) - (*lcl* 0) - (*lex* 0) - (*level* 0) - (*env* 0) - (*env-lvl* 0) - (*temp* 0)) - (wt-nl "ECL_DLLEXPORT void " name "(cl_object flag)") - (wt-nl-open-brace) - (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") - (wt-nl "cl_object value0;") - (wt-nl "cl_object *VVtemp;") - - (wt-nl "if (flag != OBJNULL){") - (wt-nl "Cblock = flag;") - (wt-nl "#ifndef ECL_DYNAMIC_VV") - (wt-nl "flag->cblock.data = VV;") - (wt-nl "#endif") - (when *self-destructing-fasl* - (wt-nl "flag->cblock.self_destruct=1;")) - (wt-nl "flag->cblock.data_size = VM;") - (wt-nl "flag->cblock.temp_data_size = VMtemp;") - (wt-nl "flag->cblock.data_text = compiler_data_text;") - (wt-nl "flag->cblock.cfuns_size = compiler_cfuns_size;") - (wt-nl "flag->cblock.cfuns = compiler_cfuns;") - (when ext:*source-location* - (wt-nl "flag->cblock.source = ecl_make_constant_base_string(\"" - (namestring (car ext:*source-location*)) "\",-1);")) - (wt-nl "return;}") - (wt-nl "#ifdef ECL_DYNAMIC_VV") - (wt-nl "VV = Cblock->cblock.data;") - (wt-nl "#endif") - ;; 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") - ;; We save the C body of the statement, indented, just in case we need to - ;; add a {} section with the environment variables. - (let ((body (let ((*opened-c-braces* (1+ *opened-c-braces*))) - (with-output-to-string (*compiler-output1*) - (wt-comment-nl "MAKE-LOAD-FORMs") - (dolist (form *make-forms*) - (t2expr form)) - (wt-comment-nl "TOP-LEVEL-FORMs") - (dolist (form *top-level-forms*) - (t2expr form)))))) - (if (or (plusp *max-lex*) - (plusp *max-temp*) - (plusp *max-env*) - *ihs-used-p*) - (with-lexical-scope () - (wt-function-locals) - (write-sequence body *compiler-output1*)) - (write-sequence body *compiler-output1*))) - ;; We process top-level forms before functions to update their - ;; environments. Then we emit functions before top level forms. - (wt-nl-close-many-braces 0))) - -(defun ctop-write (init-name h-pathname data-pathname - &aux def top-output-string (*volatile* "volatile ")) +(defun ctop-write (init-name h-pathname data-pathname &aux top-output-string) (wt-nl "#include \"" (brief-namestring h-pathname) "\"") ;; VV might be needed by functions in CLINES. @@ -143,7 +126,7 @@ ;;; We rebind the output to ensure that the initialization function is ;;; processed first and added last. (let ((output (make-string-output-stream))) - (emit-entry-fun init-name output) + (t3entry-fun init-name output) (emit-functions *compiler-output1*) (setq top-output-string (get-output-stream-string output))) ;; Declarations in h-file. @@ -184,7 +167,7 @@ (when *callbacks* (wt-nl-h "#include ") (dolist (x *callbacks*) - (apply #'t3-defcallback x))) + (apply #'t3callback x))) (wt-nl "#include \"" (brief-namestring data-pathname) "\"") (wt-nl "#ifdef __cplusplus") @@ -192,14 +175,6 @@ (wt-nl "#endif") (wt-nl top-output-string)) -(defun t2compiler-let (c1form symbols values body) - (declare (ignore c1form)) - (progv symbols values (c2expr body))) - -(defun t2progn (c1form args) - (declare (ignore c1form)) - (mapc #'t2expr args)) - (defun wt-function-locals (&optional closure-type) ;; FIXME! Are we careful enough with temporary variables that ;; we need not make them volatile? @@ -234,30 +209,104 @@ do (wt comma "CLV" i) finally (wt ";")))) + +(defun t3entry-fun (name *compiler-output1*) + (with-bir-env (:env 0 :level 0 :volatile "volatile ") + (wt-nl "ECL_DLLEXPORT void " name "(cl_object flag)") + (wt-nl-open-brace) + (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") + (wt-nl "cl_object value0;") + (wt-nl "cl_object *VVtemp;") -(defun t2ordinary (c1form form) - (declare (ignore c1form)) - (with-exit-label (*exit*) - (let ((*destination* 'TRASH)) - (c2expr form)))) + (wt-nl "if (flag != OBJNULL){") + (wt-nl "Cblock = flag;") + (wt-nl "#ifndef ECL_DYNAMIC_VV") + (wt-nl "flag->cblock.data = VV;") + (wt-nl "#endif") + (when *self-destructing-fasl* + (wt-nl "flag->cblock.self_destruct=1;")) + (wt-nl "flag->cblock.data_size = VM;") + (wt-nl "flag->cblock.temp_data_size = VMtemp;") + (wt-nl "flag->cblock.data_text = compiler_data_text;") + (wt-nl "flag->cblock.cfuns_size = compiler_cfuns_size;") + (wt-nl "flag->cblock.cfuns = compiler_cfuns;") + (when ext:*source-location* + (wt-nl "flag->cblock.source = ecl_make_constant_base_string(\"" + (namestring (car ext:*source-location*)) "\",-1);")) + (wt-nl "return;}") + (wt-nl "#ifdef ECL_DYNAMIC_VV") + (wt-nl "VV = Cblock->cblock.data;") + (wt-nl "#endif") + ;; 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") + ;; We save the C body of the statement, indented, just in case we need to + ;; add a {} section with the environment variables. + (let ((body (let ((*opened-c-braces* (1+ *opened-c-braces*))) + (with-output-to-string (*compiler-output1*) + (terpri *compiler-output1*) + (wt-comment-nl "MAKE-LOAD-FORMs") + (dolist (form *make-forms*) + (t2expr form)) + (wt-comment-nl "TOP-LEVEL-FORMs") + (dolist (form *top-level-forms*) + (t2expr form)))))) + (if (or (plusp *max-lex*) + (plusp *max-temp*) + (plusp *max-env*) + *ihs-used-p*) + (with-lexical-scope () + (wt-function-locals) + (write-sequence body *compiler-output1*)) + (write-sequence body *compiler-output1*))) + ;; We process top-level forms before functions to update their + ;; environments. Then we emit functions before top level forms. + (wt-nl-close-many-braces 0))) -(defun t2load-time-value (c1form vv-loc form) - (declare (ignore c1form)) - (with-exit-label (*exit*) - (let ((*destination* vv-loc)) - (c2expr form)))) - -(defun t2make-form (c1form vv-loc form) - (declare (ignore c1form)) - (with-exit-label (*exit*) - (let ((*destination* vv-loc)) - (c2expr form)))) - -(defun t2init-form (c1form vv-loc form) - (declare (ignore c1form vv-loc)) - (with-exit-label (*exit*) - (let ((*destination* 'TRASH)) - (c2expr form)))) +(defun t3callback (lisp-name c-name c-name-constant return-type return-type-code + arg-types arg-type-constants call-type &aux (return-p t)) + (declare (ignore lisp-name)) + (with-bir-env (:env 0 :level 0 :volatile "volatile ") + (when (eql return-type :void) + (setf return-p nil)) + (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type))) + (vars (loop for n from 0 below (length arg-types) + collect (format nil "var~d" n))) + (fmod (case call-type + ((:cdecl :default) "") + (:stdcall "__stdcall ") + (t (cmperr "DEFCALLBACK does not support ~A as calling convention" + call-type))))) + (wt-nl-h "static " return-type-name " " fmod c-name "(") + (wt-nl1 "static " return-type-name " " fmod c-name "(") + (loop with comma = "" + for var in vars + for type in arg-types + for arg-type-name = (rep-type->c-name (ffi::%convert-to-arg-type type)) + do (wt-h comma arg-type-name " " var) + (wt comma arg-type-name " " var) + (setf comma ",")) + (wt ")") + (wt-h ");") + (with-lexical-scope () + (when return-p + (wt-nl return-type-name " output;")) + (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") + (wt-nl "cl_object aux;") + (with-stack-frame (frame) + (loop for var in vars + and type in arg-types + and ct in arg-type-constants + do (wt-nl "ecl_stack_frame_push(" frame "," `(ffi-data-ref ,var ,ct) ");")) + (wt-nl "aux = ecl_apply_from_stack_frame(" frame "," + "ecl_fdefinition(" c-name-constant "));") + ;; No UNWIND-EXIT, so we must close the frame manually. + (wt-nl "ecl_stack_frame_close(" frame ");")) + (when return-p + (set-loc `(ffi-data-ref "output" ,return-type-code) "aux") + (wt-nl "return output;")))))) (defun t3function (fun) (declare (type fun fun)) @@ -267,35 +316,25 @@ (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) - (*last-label* 0) - (*lex* 0) (*max-lex* 0) - (*env* (fun-env fun)) ; continue growing env - (*max-env* *env*) (*env-lvl* 0) - (*aux-closure* nil) - (*level* (fun-lexical-levels fun)) - (*exit* 'LEAVE) - (*unwind-exit* '(LEAVE)) - (*destination* *exit*) - (*ihs-used-p* nil) - (*opened-c-braces* 0) (*tail-recursion-info* fun) - (*tail-recursion-mark* nil) - (*volatile* (c1form-volatile* lambda-expr))) - (t3function-declaration fun) - (wt-nl-open-brace) - (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) - (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) - (t3function-closure-scan fun)) - (write-sequence body *compiler-output1*) - (wt-nl-close-many-braces 0)))) + (*tail-recursion-mark* nil)) + (with-bir-env (:env (fun-env fun) + :level (fun-lexical-levels fun) + :volatile (c1form-volatile* lambda-expr)) + (t3function-declaration fun) + (wt-nl-open-brace) + (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) + (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) + (t3function-closure-scan fun)) + (write-sequence body *compiler-output1*) + (wt-nl-close-many-braces 0))))) (defun t3function-body (fun) (let ((string (make-array 2048 :element-type 'character @@ -323,7 +362,6 @@ (or (fun-name fun) (fun-description fun) 'CLOSURE)) (let* ((comma "") (lambda-expr (fun-lambda fun)) - (volatile (c1form-volatile* lambda-expr)) (lambda-list (c1form-arg 0 lambda-expr)) (requireds (loop repeat si::c-arguments-limit @@ -344,16 +382,16 @@ (wt-nl-h "static cl_object " cfun "(") (wt-nl "static cl_object " cfun "(")))) (when narg - (wt-h volatile "cl_narg") - (wt volatile "cl_narg narg") + (wt-h *volatile* "cl_narg") + (wt *volatile* "cl_narg narg") (setf comma ", ")) (dotimes (n (fun-lexical-levels fun)) (wt-h comma "volatile cl_object *") (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) + do (wt-h comma "cl_object " *volatile*) + (wt comma "cl_object " *volatile* lcl) (setf comma ", ")) (when narg (wt-h ", ...") @@ -438,19 +476,3 @@ (wt-nl "ecl_cmp_defun(" loc ");")) (wt-comment (loc-immediate-value fname)) (close-inline-blocks))) - -(defun t2fset (c1form &rest args) - (declare (ignore args)) - (t2ordinary c1form c1form)) - -(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)) - (if (and (not (fun-closure fun)) - (eq *destination* 'TRASH)) - (wt-install-function fname fun macro-p) - (c2call-global c1form 'SI:FSET c1forms))) From d13d40065446c5905b88bd51331c2a7809260a39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 23 Nov 2023 11:45:19 +0100 Subject: [PATCH 09/24] cmp: move the variable *DESTINATION* to cmpc --- src/cmp/cmpbackend-cxx/cmpc-util.lsp | 23 +++++++++++++++++++++++ src/cmp/cmpglobals.lsp | 7 ------- src/cmp/cmplocs.lsp | 19 ------------------- 3 files changed, 23 insertions(+), 26 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-util.lsp b/src/cmp/cmpbackend-cxx/cmpc-util.lsp index c0f8953cc..080a66aec 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-util.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-util.lsp @@ -56,6 +56,29 @@ (defvar *exit*) (defvar *unwind-exit*) +;;; Destination of output of different forms. +;;; +;;; Valid *DESTINATION* locations are: +;;; +;;; var-object Variable +;;; loc-object VV Location +;;; TRASH Value may be thrown away. +;;; LEAVE Object returned from current function. +;;; VALUEZ Values vector. +;;; VALUE0 +;;; ( VALUE i ) Nth value +;;; ( BIND var alternative ) Alternative is optional +;;; ( JUMP-TRUE label ) +;;; ( JUMP-FALSE label ) + +(defvar *destination*) + +(defun tmp-destination (loc) + (case loc + (VALUEZ 'VALUEZ) + (TRASH 'TRASH) + (T 'LEAVE))) + ;;; 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 }* diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 135d31b6e..e43a60fd9 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -120,13 +120,6 @@ 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*.") -;;; --cmplocs.lsp-- -;;; -;;; Destination of output of different forms. See cmplocs.lsp for types of -;;; destinations. -;;; -(defvar *destination*) - ;;; --cmpmain.lsp-- ;;; ;;; Do we debug the compiler? Then we need files not to be deleted. diff --git a/src/cmp/cmplocs.lsp b/src/cmp/cmplocs.lsp index 0497ef6a9..3da732b21 100644 --- a/src/cmp/cmplocs.lsp +++ b/src/cmp/cmplocs.lsp @@ -135,25 +135,6 @@ ;;; VA-ARG ;;; CL-VA-ARG -;;; Valid *DESTINATION* locations are: -;;; -;;; var-object Variable -;;; loc-object VV Location -;;; TRASH Value may be thrown away. -;;; LEAVE Object returned from current function. -;;; VALUEZ Values vector. -;;; VALUE0 -;;; ( VALUE i ) Nth value -;;; ( BIND var alternative ) Alternative is optional -;;; ( JUMP-TRUE label ) -;;; ( JUMP-FALSE label ) - -(defun tmp-destination (loc) - (case loc - (VALUEZ 'VALUEZ) - (TRASH 'TRASH) - (T 'LEAVE))) - (defun precise-loc-type (loc new-type) (if (subtypep (loc-type loc) new-type) loc From dfa02ba434ca4e6d7f55c5d1ecd31c949e76cbc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 30 Nov 2023 08:31:54 +0100 Subject: [PATCH 10/24] cmp: unwind-label: relax conditions for carrying the value There is no need to carry the location value across the unwind when the destination is not special, because then we may assign the destination before we unwind the stack. That allows us to skip examining the unwind requirements. --- src/cmp/cmpbackend-cxx/cmppass2-exit.lsp | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp index 041785fad..1555b9cbe 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp @@ -152,10 +152,9 @@ ;; This operator does not cross the function boundary. (assert (null exit-p)) (cond ((and (destination-value-matters-p *destination*) - (or (plusp frs-bind) bds-lcl (plusp bds-bind) stack-frame) - (or (loc-refers-to-special-p loc) - (loc-refers-to-special-p *destination*))) - ;; Save the value if LOC may possibly refer to special binding. + (loc-refers-to-special-p *destination*)) + ;; Save the value if *DESTINATION* may possibly refer to special + ;; binding. Otherwise we may set *DESTINATION* /before/ the unwind. (let* ((*temp* *temp*) (temp (make-temp-var))) (set-loc temp loc) From b9605fd3e41d530ffafa9b432574f92d77433354 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 23 Nov 2023 09:27:56 +0100 Subject: [PATCH 11/24] cmp: exit manager: introduce operators UNWIND-FLEE and UNWIND-COND The operator UNWIND-FLEE is used to perform a dynamic unwind. Previously we've opencoded this type of exits in appropriate operators. The operator UNWIND-COND is used to perform a conditional unwind. It is expected to be called to produce the IF statement body. With this commit all every transfer of control goes through the exit manager. Ultimately we will want to include the if test directly in UNWIND-COND. --- src/cmp/cmpbackend-cxx/cmppass2-cont.lsp | 20 +++++----- src/cmp/cmpbackend-cxx/cmppass2-eval.lsp | 2 +- src/cmp/cmpbackend-cxx/cmppass2-exit.lsp | 47 +++++++++++++++++++----- 3 files changed, 49 insertions(+), 20 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp index ecde25397..c5eb66808 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp @@ -45,8 +45,7 @@ (progn (let ((*destination* 'VALUEZ)) (c2expr* val)) - (let ((name (get-object (blk-name blk)))) - (wt-nl "cl_return_from(" (blk-var blk) "," name ");"))) + (unwind-flee blk :return-from)) (let ((*destination* (blk-destination blk)) (*exit* (blk-exit blk))) (c2expr val)))) @@ -81,9 +80,10 @@ ;; Allocate labels. (dolist (tag body) (when (and (tag-p tag) (plusp (tag-ref tag))) - (setf (tag-jump tag) (next-label nil)) - (wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))") - (wt-go (tag-jump tag)))) + (let ((target (next-label nil))) + (setf (tag-jump tag) target) + (wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))") + (unwind-cond target)))) (when (var-ref-ccb tag-loc) (wt-nl "ecl_internal_error(\"GO found an inexistent tag\");"))) (c2tagbody-body body)) @@ -105,20 +105,22 @@ (defun c2go (c1form tag nonlocal) (declare (ignore c1form)) (if nonlocal - (wt-nl "cl_go(" (tag-var tag) ",ecl_make_fixnum(" (tag-index tag) "));") + (unwind-flee tag :go) (unwind-jump (tag-jump tag)))) (defun c2throw (c1form tag val &aux loc) (declare (ignore c1form)) (case (c1form-name tag) - ((VARIABLE LOCATION) (setq loc (c1form-arg 0 tag))) - (t (setq loc (make-temp-var)) + ((VARIABLE LOCATION) + (setq loc (c1form-arg 0 tag))) + (t + (setq loc (make-temp-var)) (let ((*destination* loc)) (c2expr* tag)))) (let ((*destination* 'VALUEZ)) (c2expr* val)) - (wt-nl "cl_throw(" loc ");")) + (unwind-flee loc :throw)) (defun c2catch (c1form tag body) (declare (ignore c1form)) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp index 8bae8f54c..6933f1dd3 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp @@ -138,7 +138,7 @@ (let ((*destination* 'VALUE0)) (c2expr* f)) (wt-nl "if (" 'VALUE0 "!=ECL_NIL) ") - (wt-open-brace) (unwind-jump normal-exit) (wt-nl-close-brace)) + (unwind-cond normal-exit)) (c2expr last)) (unwind-exit 'VALUE0))))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp index 1555b9cbe..dcacdf0c1 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp @@ -13,8 +13,10 @@ ;;;; ;;;; The exit manager has two main operators that unwind the dynamic context: ;;;; -;;;; (UNWIND-EXIT value) carries VALUE to *DESTINATION* and unwinds to *EXIT*. -;;;; (UNWIND-JUMP label) unwinds to LABEL. +;;;; (UNWIND-EXIT value) carries VALUE to *DESTINATION* and unwinds to *EXIT* +;;;; (UNWIND-JUMP label) unwinds to LABEL +;;;; (UNWIND-COND label) unwinds to LABEL (conditionally) +;;;; (UNWIND-FLEE label) escapes to LABEL (runtime unwind) ;;;; (in-package "COMPILER") @@ -38,6 +40,31 @@ (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p) (wt-nl-go exit))) +;;; A conditional jump that is meant to be used as the IF statement body. +;;; FIXME we want UNWIND-JEQL and UNWIND-JNOT and open-code the test too. +(defun unwind-cond (exit) + (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p) + (compute-unwind (label-denv exit)) + (with-lexical-scope () + (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p) + (wt-nl-go exit)))) + +(defun unwind-flee (exit kind) + ;; All these boil down to calling ecl_unwind which unwinds stacks dynamically. + ;; If we want to implement call/cc, then this is the place where we dispatch. + #+ (or) (wt-nl "ecl_unwind(cl_env_copy," frs-id ");") + (ecase kind + (:go + ;; The second argument is passed as a value (index for jump). + (wt-nl "cl_go(" (tag-var exit) ",ecl_make_fixnum(" (tag-index exit) "));")) + (:throw + ;; Unlike GO and RETURN-FROM, the destination is not known at compile time. + ;; TODO in some cases it is possible to prove the destination CATCH form. + (wt-nl "cl_throw(" exit ");")) + (:return-from + ;; The second argument is used only to signal the error. + (wt-nl "cl_return_from(" (blk-var exit) "," (get-object (blk-name exit)) ");")))) + ;;; (defun baboon-exit-not-found (exit) @@ -177,10 +204,10 @@ (JUMP-TRUE (cond ((not constantp) (case (loc-representation-type loc) - (:bool (wt-nl "if (" loc ") ")) - (:object (wt-nl "if (" loc "!=ECL_NIL) ")) - (otherwise (wt-nl "if ((") (wt-coerce-loc :object loc) (wt ")!=ECL_NIL) "))) - (wt-open-brace) (unwind-jump label) (wt-nl-close-brace)) + (:bool (wt-nl "if (" loc ")")) + (:object (wt-nl "if (" loc "!=ECL_NIL)")) + (otherwise (wt-nl "if ((") (wt-coerce-loc :object loc) (wt ")!=ECL_NIL)"))) + (unwind-cond label)) ((not (null value)) (unwind-jump label))) (unless (and constantp (not (null value))) @@ -189,10 +216,10 @@ (JUMP-FALSE (cond ((not constantp) (case (loc-representation-type loc) - (:bool (wt-nl "if (!(" loc ")) ")) - (:object (wt-nl "if (Null(" loc ")) ")) - (otherwise (wt-nl "if (Null(") (wt-coerce-loc :object loc) (wt ")) "))) - (wt-open-brace) (unwind-jump label) (wt-nl-close-brace)) + (:bool (wt-nl "if (!(" loc "))")) + (:object (wt-nl "if (Null(" loc "))")) + (otherwise (wt-nl "if (Null(") (wt-coerce-loc :object loc) (wt "))"))) + (unwind-cond label)) ((null value) (unwind-jump label))) (unless (and constantp (null value)) From bc01ff1a3c062860894ee30df2237e17b1eef65c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 27 Nov 2023 11:32:59 +0100 Subject: [PATCH 12/24] cmp: unwind-cjump: avoid recursive call to unwind-exit Previously our call for conditional jumps worked like: unwind-exit -> unwind-cjump -> unwind-exit -> unwind-{label,exit} The roundtrip to unwind-exit makes tracking invocations harder. The new invocation chain is: unwind-exit -> unwind-cjump -> unwind-{label,exit} --- src/cmp/cmpbackend-cxx/cmppass2-exit.lsp | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp index dcacdf0c1..aff293aa9 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp @@ -212,7 +212,9 @@ (unwind-jump label))) (unless (and constantp (not (null value))) (let ((*destination* 'TRASH)) - (unwind-exit *vv-nil*)))) + (if (labelp *exit*) + (unwind-label *vv-nil*) + (unwind-leave *vv-nil*))))) (JUMP-FALSE (cond ((not constantp) (case (loc-representation-type loc) @@ -224,4 +226,6 @@ (unwind-jump label))) (unless (and constantp (null value)) (let ((*destination* 'TRASH)) - (unwind-exit *vv-t*)))))))) + (if (labelp *exit*) + (unwind-label *vv-t*) + (unwind-leave *vv-t*))))))))) From 909e5693abb6a4260b57442794b4456a45725054 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 24 Nov 2023 12:06:35 +0100 Subject: [PATCH 13/24] cmp: tagbody: move tag allocation before branching This is a cosmetic change for readibility. --- src/cmp/cmpbackend-cxx/cmppass2-cont.lsp | 63 +++++++++++------------- 1 file changed, 30 insertions(+), 33 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp index c5eb66808..0b97063d4 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp @@ -54,40 +54,37 @@ (defun c2tagbody (c1form tag-loc body) (declare (type var tag-loc) (ignore c1form)) - (if (null (var-kind tag-loc)) - ;; only local goto's - (dolist (x body (c2tagbody-body body)) - ;; Allocate labels. - (when (and (tag-p x) (plusp (tag-ref x))) - (setf (tag-jump x) (next-label t)))) - ;; some tag used non locally or inside an unwind-protect - (let ((*env* *env*) (*env-lvl* *env-lvl*) - (*lex* *lex*) (*lcl* *lcl*) - (*inline-blocks* 0) - (env-grows (env-grows (var-ref-ccb tag-loc)))) - (when env-grows - (let ((env-lvl *env-lvl*)) + (macrolet ((do-tags ((tag forms result) &body body) + ;; Allocate labels. + `(dolist (,tag ,forms ,result) + (when (and (tag-p ,tag) (plusp (tag-ref ,tag))) + (setf (tag-jump ,tag) (next-label t)) + ,@body)))) + (if (null (var-kind tag-loc)) + ;; only local goto's + (do-tags (tag body (c2tagbody-body body))) + ;; some tag used non locally or inside an unwind-protect + (let ((*env* *env*) (*env-lvl* *env-lvl*) + (*lex* *lex*) (*lcl* *lcl*) + (*inline-blocks* 0) + (env-grows (env-grows (var-ref-ccb tag-loc)))) + (when env-grows + (let ((env-lvl *env-lvl*)) + (maybe-open-inline-block) + (wt-nl "volatile cl_object env" (incf *env-lvl*) + " = env" env-lvl ";"))) + (when (eq :OBJECT (var-kind tag-loc)) + (setf (var-loc tag-loc) (next-lcl)) (maybe-open-inline-block) - (wt-nl "volatile cl_object env" (incf *env-lvl*) - " = env" env-lvl ";"))) - (when (eq :OBJECT (var-kind tag-loc)) - (setf (var-loc tag-loc) (next-lcl)) - (maybe-open-inline-block) - (wt-nl "cl_object " tag-loc ";")) - (bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc) - (with-unwind-frame (tag-loc) - (progn - ;; Allocate labels. - (dolist (tag body) - (when (and (tag-p tag) (plusp (tag-ref tag))) - (let ((target (next-label nil))) - (setf (tag-jump tag) target) - (wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))") - (unwind-cond target)))) - (when (var-ref-ccb tag-loc) - (wt-nl "ecl_internal_error(\"GO found an inexistent tag\");"))) - (c2tagbody-body body)) - (close-inline-blocks)))) + (wt-nl "cl_object " tag-loc ";")) + (bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc) + (with-unwind-frame (tag-loc) + (do-tags (tag body (when (var-ref-ccb tag-loc) + (wt-nl "ecl_internal_error(\"GO found an inexistent tag\");"))) + (wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))") + (unwind-cond (tag-jump tag))) + (c2tagbody-body body)) + (close-inline-blocks))))) (defun c2tagbody-body (body) ;;; INV: BODY is a list of tags and forms. We have processed the body From bb42ed7194e3a46c94a74e68462c81e430da11ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 28 Nov 2023 15:38:03 +0100 Subject: [PATCH 14/24] cmp: compute-unwind: make all arguments explicit Instead of relying on *UNWIND-PROTECT* we accept explicit arguments. --- src/cmp/cmpbackend-cxx/cmppass2-exit.lsp | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp index aff293aa9..bbad802b5 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp @@ -36,7 +36,7 @@ (defun unwind-jump (exit) (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p) - (compute-unwind (label-denv exit)) + (compute-unwind (label-denv exit) *unwind-exit*) (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p) (wt-nl-go exit))) @@ -44,7 +44,7 @@ ;;; FIXME we want UNWIND-JEQL and UNWIND-JNOT and open-code the test too. (defun unwind-cond (exit) (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p) - (compute-unwind (label-denv exit)) + (compute-unwind (label-denv exit) *unwind-exit*) (with-lexical-scope () (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p) (wt-nl-go exit)))) @@ -75,9 +75,9 @@ (baboon :format-control "The value of exit~%~A~%is not valid." :format-arguments (list exit))) -(defun baboon-unwind-invalid (unwind-exit) - (baboon :format-control "The value~%~A~%is not a tail of *UNWIND-EXIT*~%~A" - :format-arguments (list unwind-exit *unwind-exit*))) +(defun baboon-unwind-invalid (unwind-to unwind-from) + (baboon :format-control "The unwind value~%~A~%is not a tail of the unwind value~%~A" + :format-arguments (list unwind-to unwind-from))) (defun baboon-unwind-exit (exit) (baboon :format-control "The value of exit~%~A~%found in *UNWIND-EXIT*~%~A~%is not valid." @@ -118,8 +118,10 @@ (IHS (wt-nl "ecl_ihs_pop(cl_env_copy);")) (IHS-ENV (wt-nl "ihs.lex_env = _ecl_debug_env;")))) -(defun compute-unwind (last-cons) +(defun compute-unwind (unwind-to unwind-from) (declare (si::c-local)) + (unless (tailp unwind-to unwind-from) + (baboon-unwind-invalid unwind-to unwind-from)) (loop with bds-lcl = nil with bds-bind = 0 with stack-frame = nil @@ -127,9 +129,9 @@ with frs-bind = 0 with jump-p = nil with exit-p = nil - for unwind-exit on *unwind-exit* + for unwind-exit on unwind-from for ue = (car unwind-exit) - until (eq unwind-exit last-cons) + until (eq unwind-exit unwind-to) do (cond ((consp ue) (case (first ue) @@ -154,7 +156,7 @@ (defun unwind-leave (loc) (declare (si::c-local)) (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p) - (compute-unwind nil) + (compute-unwind nil *unwind-exit*) (declare (fixnum frs-bind bds-bind)) ;; *destination* must be either LEAVE or TRASH. (cond ((eq loc 'VALUEZ) @@ -174,7 +176,8 @@ (declare (si::c-local)) (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p jump-p exit-p) (compute-unwind (or (member *exit* *unwind-exit* :test #'eq) - (baboon-exit-not-found *exit*))) + (baboon-exit-not-found *exit*)) + *unwind-exit*) (declare (fixnum frs-bind bds-bind)) ;; This operator does not cross the function boundary. (assert (null exit-p)) From a12d24a8bfbd91d21304fcab6959cdbc2e500765 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 5 Dec 2023 09:12:01 +0100 Subject: [PATCH 15/24] cmp: exit manager: implement branching directly in the module Instead of open-coding branching manually in individual operators we introduce separate unwinding operators. --- src/cmp/cmpbackend-cxx/cmppass2-cont.lsp | 10 +- src/cmp/cmpbackend-cxx/cmppass2-eval.lsp | 3 +- src/cmp/cmpbackend-cxx/cmppass2-exit.lsp | 209 +++++++++++++---------- 3 files changed, 124 insertions(+), 98 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp index 0b97063d4..22ad17d0c 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp @@ -79,10 +79,12 @@ (wt-nl "cl_object " tag-loc ";")) (bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc) (with-unwind-frame (tag-loc) - (do-tags (tag body (when (var-ref-ccb tag-loc) - (wt-nl "ecl_internal_error(\"GO found an inexistent tag\");"))) - (wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))") - (unwind-cond (tag-jump tag))) + (progn + (do-tags (tag body nil) + (unwind-cond (tag-jump tag) :jump-eq + 'VALUEZ (tag-index tag))) + (when (var-ref-ccb tag-loc) + (wt-nl "ecl_internal_error(\"GO found an inexistent tag\");"))) (c2tagbody-body body)) (close-inline-blocks))))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp index 6933f1dd3..7b196d46d 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp @@ -137,8 +137,7 @@ (dolist (f butlast) (let ((*destination* 'VALUE0)) (c2expr* f)) - (wt-nl "if (" 'VALUE0 "!=ECL_NIL) ") - (unwind-cond normal-exit)) + (unwind-cond normal-exit :jump-t 'VALUE0)) (c2expr last)) (unwind-exit 'VALUE0))))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp index bbad802b5..e3957d497 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp @@ -35,35 +35,18 @@ (t (baboon-exit-invalid *exit*))))) (defun unwind-jump (exit) - (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p) - (compute-unwind (label-denv exit) *unwind-exit*) - (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p) - (wt-nl-go exit))) + (%unwind (label-denv exit) *unwind-exit*) + (%goto exit)) -;;; A conditional jump that is meant to be used as the IF statement body. -;;; FIXME we want UNWIND-JEQL and UNWIND-JNOT and open-code the test too. -(defun unwind-cond (exit) - (multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p) - (compute-unwind (label-denv exit) *unwind-exit*) - (with-lexical-scope () - (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p) - (wt-nl-go exit)))) +(defun unwind-cont (exit) + (%unwind (label-denv exit) *unwind-exit*) + (%goto exit)) (defun unwind-flee (exit kind) - ;; All these boil down to calling ecl_unwind which unwinds stacks dynamically. - ;; If we want to implement call/cc, then this is the place where we dispatch. - #+ (or) (wt-nl "ecl_unwind(cl_env_copy," frs-id ");") - (ecase kind - (:go - ;; The second argument is passed as a value (index for jump). - (wt-nl "cl_go(" (tag-var exit) ",ecl_make_fixnum(" (tag-index exit) "));")) - (:throw - ;; Unlike GO and RETURN-FROM, the destination is not known at compile time. - ;; TODO in some cases it is possible to prove the destination CATCH form. - (wt-nl "cl_throw(" exit ");")) - (:return-from - ;; The second argument is used only to signal the error. - (wt-nl "cl_return_from(" (blk-var exit) "," (get-object (blk-name exit)) ");")))) + (%escape exit kind)) + +(defun unwind-cond (exit kind &rest args) + (%branch exit *unwind-exit* kind args)) ;;; @@ -100,24 +83,6 @@ ;;; LEAVE -> outermost location ;;; #