From 02d6bdb0d30ce8f7f879f3d1da8debaf0e818ab0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 25 Sep 2023 13:13:02 +0200 Subject: [PATCH 01/15] tests: add a regression test for a bug encountered in this branch --- src/tests/normal-tests/compiler.lsp | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 9d7dfb405..fed4dbe93 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -2337,3 +2337,10 @@ (check-yfn (cmplambda* (a b) (multiple-value-call #'list (values a b) (nth-v3) (nth-v4)))) (check-yfn (cmplambda* (a b) (multiple-value-call #'list (values a b) (y-vals)))) (check-nfn (cmplambda* (a b) (multiple-value-call #'list (values a b) (n-vals))))))) + +;;; Unreleased refactor branch had a regression where constants were not +;;; properly initialized in the LET form. +(test cmp.0096.c1var/location + (is (floatp (funcall (cmplambda () + (let ((x most-positive-single-float)) + x)))))) From 4ec418742715393e8a18c261d4b7ad7f3cc0d2d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 11 Jul 2023 16:21:15 +0200 Subject: [PATCH 02/15] si_need_to_make_load_form_p: t_sse_pack does not need a constructor --- src/c/compiler.d | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/c/compiler.d b/src/c/compiler.d index 9be698e23..93f665b19 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2767,6 +2767,9 @@ si_need_to_make_load_form_p(cl_object object) case t_csfloat: case t_cdfloat: case t_clfloat: +#endif +#ifdef ECL_SSE2 + case t_sse_pack: #endif case t_symbol: case t_pathname: From 592a2cca1762e7f4008f3ebbb11d8d02267abcb6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 11 Jul 2023 16:35:17 +0200 Subject: [PATCH 03/15] cmp: expand-typep: fix broken (complex type) expansion This expansion did not account for the object not being a number. In that case REALPART errored in the compiled code. Example: (typep *package* '(complex float)) --- src/cmp/cmpopt.lsp | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp index a3b66d992..edcc46298 100644 --- a/src/cmp/cmpopt.lsp +++ b/src/cmp/cmpopt.lsp @@ -87,9 +87,9 @@ type (first type)) 'SI::DEFTYPE-DEFINITION)) - (expand-typep form object `',(funcall function (if (atom type) - nil - (rest type))) + (expand-typep form object `(quote ,(funcall function (if (atom type) + nil + (rest type)))) env)) ;; ;; There exists a function which checks for this type? @@ -162,7 +162,8 @@ ;; Compound COMPLEX types. ((and (eq first 'COMPLEX) (= (list-length type) 2)) - `(and (typep (realpart ,object) ',(second type)) + `(and (complexp ,object) + (typep (realpart ,object) ',(second type)) (typep (imagpart ,object) ',(second type)))) ;; ;; (SATISFIES predicate) From 33df93da1488409b6076973ae6bd33f674206481 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 22 Jun 2023 20:30:58 +0200 Subject: [PATCH 04/15] cmp: supply an explicit value for the empty location Previously we've passed a fixnum 0 that meant the empty loc. Even earlier probably NIL was used for that purpose. That have lead to an accidental complexity where fixnums could not be stored in the value vector. --- src/cmp/cmpclos.lsp | 4 ++-- src/cmp/cmpglobals.lsp | 1 + src/cmp/cmplocs.lsp | 10 ++++++---- src/cmp/cmpopt-sequence.lsp | 2 +- src/cmp/cmppass1-data.lsp | 2 +- 5 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/cmp/cmpclos.lsp b/src/cmp/cmpclos.lsp index 20a3011cb..58a4ecc6c 100644 --- a/src/cmp/cmpclos.lsp +++ b/src/cmp/cmpclos.lsp @@ -101,7 +101,7 @@ (when (typep reader 'clos:standard-reader-method) (let* ((slotd (clos:accessor-method-slot-definition reader)) (index (clos::safe-slot-definition-location slotd))) - (when (si::fixnump index) + (when (ext:fixnump index) `(clos::safe-instance-ref ,object ,index)))))))) (defun try-optimize-slot-writer (orig-writers args) @@ -113,7 +113,7 @@ (when (typep writer 'clos:standard-writer-method) (let* ((slotd (clos:accessor-method-slot-definition writer)) (index (clos::safe-slot-definition-location slotd))) - (when (si::fixnump index) + (when (ext:fixnump index) `(si::instance-set ,(second args) ,index ,(first args))))))))) #+(or) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 98078ea82..442a0aaf9 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -33,6 +33,7 @@ (defvar *compile-file-position* -1) (defvar *active-protection* nil) (defvar *pending-actions* nil) +(defvar *empty-loc* (gensym)) (defvar *compiler-conditions* '() "This variable determines whether conditions are printed or just accumulated.") diff --git a/src/cmp/cmplocs.lsp b/src/cmp/cmplocs.lsp index 46b07d087..04e6f5388 100644 --- a/src/cmp/cmplocs.lsp +++ b/src/cmp/cmplocs.lsp @@ -24,11 +24,13 @@ (permanent-p t) (value nil)) +;;; When the value is the "empty location" then it was created to be filled +;;; later and the real type of the object is not known. See DATA-EMPTY-LOC. (defun vv-type (loc) (let ((value (vv-value loc))) - (if (and value (not (ext:fixnump value))) - (type-of value) - t))) + (if (eq value *empty-loc*) + t + (type-of value)))) (defun loc-movable-p (loc) (if (atom loc) @@ -225,7 +227,7 @@ (values t loc)) ((vv-p loc) (let ((value (vv-value loc))) - (if (or (null value) (ext:fixnump value)) + (if (eq value *empty-loc*) (values nil nil) (values t value)))) ((atom loc) diff --git a/src/cmp/cmpopt-sequence.lsp b/src/cmp/cmpopt-sequence.lsp index e6f793572..f61dfc0fb 100644 --- a/src/cmp/cmpopt-sequence.lsp +++ b/src/cmp/cmpopt-sequence.lsp @@ -57,7 +57,7 @@ `(let* ((%seq ,seq) (%iterator ,iterator)) (declare (optimize (safety 0))) - (if (si::fixnump %iterator) + (if (ext:fixnump %iterator) ;; Fixnum iterators are always fine (aref %seq %iterator) ;; Error check in case we may have been passed an improper list diff --git a/src/cmp/cmppass1-data.lsp b/src/cmp/cmppass1-data.lsp index e990a1680..beb2eb013 100644 --- a/src/cmp/cmppass1-data.lsp +++ b/src/cmp/cmppass1-data.lsp @@ -77,7 +77,7 @@ (maybe-init location init-form))))))) (defun data-empty-loc () - (add-object 0 :duplicate t :permanent t)) + (add-object *empty-loc* :duplicate t :permanent t)) ;;; Note that we can't use GET-OBJECT to probe for referenced objects because ;;; ADD-OBJECT (when failed and :DUPLICATE is T) may return an object that is From faebc7b266483f7cd173fe98346490cc95b4c7ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 29 Jun 2023 19:55:08 +0200 Subject: [PATCH 05/15] cmp: enforce valid shape of si:function-block-name delcaration Also fix a declaration in clos::make-raw-lambda function. --- src/clos/method.lsp | 57 +++++++++++++------------ src/cmp/cmpbackend-cxx/cmppass2-loc.lsp | 2 +- src/cmp/cmpfun.lsp | 10 +++-- 3 files changed, 36 insertions(+), 33 deletions(-) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 7d242f31b..b2ec572eb 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -143,38 +143,39 @@ (not (member '&allow-other-keys lambda-list))) (let ((x (position '&aux lambda-list))) (setf lambda-list - (append (subseq lambda-list 0 x) - '(&allow-other-keys) - (and x (subseq lambda-list x)) - nil)))) + (append (subseq lambda-list 0 x) + '(&allow-other-keys) + (and x (subseq lambda-list x)) + nil)))) (let* ((copied-variables '()) (ignorable `(declare (ignorable ,@required-parameters))) + (block-name (si:function-block-name name)) (class-declarations - (nconc (when *add-method-argument-declarations* - (loop for name in required-parameters - for type in specializers - when (and (not (eq type t)) (symbolp type)) - do (push `(,name ,name) copied-variables) and - nconc `((type ,type ,name) - (si::no-check-type ,name)))) - (list (list 'si::function-block-name name)) - (cdar declarations))) - (block `(block ,(si::function-block-name name) ,@real-body)) + (nconc (when *add-method-argument-declarations* + (loop for name in required-parameters + for type in specializers + when (and (not (eq type t)) (symbolp type)) + do (push `(,name ,name) copied-variables) and + nconc `((type ,type ,name) + (si::no-check-type ,name)))) + (list (list 'si:function-block-name block-name)) + (cdar declarations))) + (block `(block ,block-name ,@real-body)) (method-lambda - ;; Remove the documentation string and insert the - ;; appropriate class declarations. The documentation - ;; string is removed to make it easy for us to insert - ;; new declarations later, they will just go after the - ;; second of the method lambda. The class declarations - ;; are inserted to communicate the class of the method's - ;; arguments to the code walk. - `(lambda ,lambda-list - ,@(and class-declarations `((declare ,@class-declarations))) - ,ignorable - ,(if copied-variables - `(let* ,copied-variables - ,ignorable - ,block) + ;; Remove the documentation string and insert the + ;; appropriate class declarations. The documentation + ;; string is removed to make it easy for us to insert + ;; new declarations later, they will just go after the + ;; second of the method lambda. The class declarations + ;; are inserted to communicate the class of the method's + ;; arguments to the code walk. + `(lambda ,lambda-list + ,@(and class-declarations `((declare ,@class-declarations))) + ,ignorable + ,(if copied-variables + `(let* ,copied-variables + ,ignorable + ,block) block)))) (values method-lambda declarations documentation)))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp index 114486c96..5ef7451ad 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp @@ -159,7 +159,7 @@ ;;; FDEFINITION, MAKE-CLOSURE ;;; (defun wt-fdefinition (fun-name) - (let* ((name (si::function-block-name fun-name)) + (let* ((name (si:function-block-name fun-name)) (package (symbol-package name)) (safe (or (not (safe-compile)) (and (or (eq package (find-package "CL")) diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index 7b1908496..dc3100892 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -166,10 +166,12 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." ;;; searches for a (FUNCTION-BLOCK-NAME ...) declaration (defun function-block-name-declaration (declarations) (loop for i in declarations - if (and (consp i) (eql (car i) 'si::function-block-name) - (consp (cdr i))) - return (cadr i) - finally (return nil))) + do (when (and (consp i) (eql (car i) 'si:function-block-name)) + (let ((name (second i)) + (rest (cddr i))) + (unless (and (symbolp name) (null rest)) + (cmperr "Invalid ~s declaration:~%~s" 'si:function-block-name i)) + (return name))))) (defun exported-fname (name) (let (cname) From 816c08340bbd161fed82c0d625073f3195d685c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 26 Jun 2023 14:21:13 +0200 Subject: [PATCH 06/15] cmp: have separate AST nodes for variables and locations That will aid moving inline optimizations to the backend. --- src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp | 5 +++-- src/cmp/cmpbackend-cxx/cmppass2-var.lsp | 11 ++++++++--- src/cmp/cmppass1-eval.lsp | 15 +++++++++++---- src/cmp/cmppass1-special.lsp | 2 +- src/cmp/cmppass1-var.lsp | 5 +++-- src/cmp/cmpprop.lsp | 9 +++++---- src/cmp/cmptables.lsp | 6 +++--- src/cmp/cmptype.lsp | 14 ++++++-------- 8 files changed, 40 insertions(+), 27 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp index 7bf2e431d..3ec92ba62 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp @@ -58,10 +58,11 @@ (defun emit-inlined-setq (form rest-forms) (let ((vref (c1form-arg 0 form)) (form1 (c1form-arg 1 form))) - (let ((*destination* vref)) (c2expr* form1)) + (let ((*destination* vref)) + (c2expr* form1)) (if (eq (c1form-name form1) 'LOCATION) (list (c1form-primary-type form1) (c1form-arg 0 form1)) - (emit-inlined-variable (make-c1form 'VAR form vref) rest-forms)))) + (emit-inlined-variable (make-c1form 'VAR form vref nil) rest-forms)))) (defun emit-inlined-call-global (form expected-type) (let* ((fname (c1form-arg 0 form)) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp index ae1ec2e09..3d924b528 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp @@ -133,10 +133,15 @@ ;; 6) Close the C expression. (close-inline-blocks))) -(defun c2var/location (c1form loc) - #+(or) (unwind-exit loc) +(defun c2location (c1form loc) (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) + (if loc + (c2location loc (c1form-arg 0 loc)) + (c2location c1form var))) + (defun c2setq (c1form vref form) (declare (ignore c1form)) ;; First comes the assignement @@ -144,7 +149,7 @@ (c2expr* form)) ;; Then the returned value (if (eq (c1form-name form) 'LOCATION) - (c2var/location form (c1form-arg 0 form)) + (c2location form (c1form-arg 0 form)) (unwind-exit vref))) (defun c2progv (c1form symbols values body) diff --git a/src/cmp/cmppass1-eval.lsp b/src/cmp/cmppass1-eval.lsp index 5060b47c3..a2f671f18 100644 --- a/src/cmp/cmppass1-eval.lsp +++ b/src/cmp/cmppass1-eval.lsp @@ -24,10 +24,11 @@ ((eq form t) (c1t)) ((keywordp form) (make-c1form* 'LOCATION :type (object-type form) - :args (add-symbol form))) - ((and (constantp form *cmp-env*) - (c1constant-value (symbol-value form)))) - (t (c1var form)))) + :args (add-symbol form))) + ((constantp form *cmp-env*) + (c1var form (c1constant-symbol-value form (symbol-value form)))) + (t + (c1var form nil)))) ((consp form) (cmpck (not (si:proper-list-p form)) "Improper list found in lisp form~%~A" form) @@ -150,6 +151,12 @@ :args (add-object val))) (t nil))) +;;; To inline a constant it must be possible to externalize its value or copies +;;; of the value must be EQL to each other. +(defun c1constant-symbol-value (name val) + (declare (ignore name)) + (c1constant-value val)) + #+sse2 (defun c1constant-value/sse (value) (let* ((bytes (ext:sse-pack-to-vector value '(unsigned-byte 8))) diff --git a/src/cmp/cmppass1-special.lsp b/src/cmp/cmppass1-special.lsp index e40b681ae..643494471 100644 --- a/src/cmp/cmppass1-special.lsp +++ b/src/cmp/cmppass1-special.lsp @@ -68,7 +68,7 @@ (let ((funob (local-function-ref fun t))) (if funob (let* ((var (fun-var funob))) - (add-to-read-nodes var (make-c1form* 'VAR :args var))) + (add-to-read-nodes var (make-c1form* 'VAR :args var nil))) (make-c1form* 'FUNCTION :type 'FUNCTION :sp-change (not (and (symbolp fun) diff --git a/src/cmp/cmppass1-var.lsp b/src/cmp/cmppass1-var.lsp index 0d41aae6c..7cb28fb53 100644 --- a/src/cmp/cmppass1-var.lsp +++ b/src/cmp/cmppass1-var.lsp @@ -242,11 +242,12 @@ :kind kind :ignorable ignorable :ref 0))))) -(defun c1var (name) +;;; When LOC is not NIL then we deal with a constant. +(defun c1var (name loc) (let* ((var (c1vref name)) (output (make-c1form* 'VAR :type (var-type var) - :args var))) + :args var loc))) (add-to-read-nodes var output) output)) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 4021f05a2..bcd30adfc 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -51,11 +51,12 @@ (declare (ignore rest)) (c1form-type form)) -(defun p1var (form var) - (let* (;; Use the type of C1FORM because it might have been - ;; coerced by a THE form. +(defun p1var (form var loc) + ;; Use the type of C1FORM because it might have been coerced by a THE form. + (let* ((loc-type (if loc (values-type-primary-type (p1propagate loc)) t)) (var-type (var-type var)) - (type (type-and var-type (c1form-primary-type form)))) + (type (type-and (type-and loc-type var-type) + (c1form-primary-type form)))) (prop-message "~&;;; Querying variable ~A gives ~A" (var-name var) type) type)) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 739c4fc85..94e1913ed 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -24,7 +24,7 @@ (CL:PROGN body :pure) ;; sub-level forms (LOCATION loc :pure :single-valued) - (VAR var :single-valued) + (VAR var value :single-valued) (CL:SETQ var value-c1form :side-effects) (CL:PSETQ var-list value-c1form-list :side-effects) (CL:BLOCK blk-var progn-c1form :pure) @@ -240,8 +240,8 @@ (cl:tagbody . c2tagbody) (cl:go . c2go) - (var . c2var/location) - (location . c2var/location) + (var . c2var) + (location . c2location) (cl:setq . c2setq) (cl:progv . c2progv) (cl:psetq . c2psetq) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 7fe8c6598..59109714d 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -42,20 +42,18 @@ (defun default-init (var &optional warn) (declare (ignore warn)) (let ((new-value (cdr (assoc (var-type var) - '((fixnum . 0) + `((fixnum . 0) (character . #\space) (long-float . 0.0L1) (double-float . 0.0D1) (single-float . 0.0F1) - #+complex-float - (si:complex-single-float . #c(0.0f0 0.0f0)) - #+complex-float - (si:complex-double-float . #c(0.0d0 0.0d0)) - #+complex-float - (si:complex-single-float . #c(0.0l0 0.0l0))) + ,@(when (member :complex-float *features*) + '((si:complex-single-float . #c(0.0f0 0.0f0)) + (si:complex-double-float . #c(0.0d0 0.0d0)) + (si:complex-single-float . #c(0.0l0 0.0l0))))) :test #'subtypep)))) (if new-value - (c1constant-value new-value) + (c1constant-value new-value :always t) (c1nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 8e3f1f0a3649d04598701cc46cdc0db3488d01f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 25 Sep 2023 14:34:00 +0200 Subject: [PATCH 07/15] cmp: add a kludge for C1CONSTANT-VALUE using *OPTIMIZABLE-CONSTANTS* This commit will be reverted soon, so it is not squashed onto the AST node separation for variables and locations. --- src/cmp/cmppass1-eval.lsp | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/cmp/cmppass1-eval.lsp b/src/cmp/cmppass1-eval.lsp index a2f671f18..e8ea796f1 100644 --- a/src/cmp/cmppass1-eval.lsp +++ b/src/cmp/cmppass1-eval.lsp @@ -26,7 +26,12 @@ (make-c1form* 'LOCATION :type (object-type form) :args (add-symbol form))) ((constantp form *cmp-env*) - (c1var form (c1constant-symbol-value form (symbol-value form)))) + ;; FIXME the compiler inlines some constants in the first pass. + ;; This is about to be addressed soon. For now we respect that. + (let ((value (symbol-value form))) + (if (assoc value *optimizable-constants*) + (c1constant-symbol-value form value) + (c1var form (c1constant-symbol-value form value))))) (t (c1var form nil)))) ((consp form) From c9ced2504dd49660831ba1e02dd49970af91c8e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 4 Jul 2023 11:16:54 +0200 Subject: [PATCH 08/15] cmp: simplify the ast node CL:FUNCTION The old AST node for CL:FUNCTION accounted for a possibility that a lambda is passed, although c1function (the only function that produces this node), discarded that possibility in favor expanding lambda to explicit FLET. --- src/cmp/cmpbackend-cxx/cmppass2-special.lsp | 13 +++---------- src/cmp/cmppass1-special.lsp | 21 ++++++++++----------- src/cmp/cmptables.lsp | 2 +- 3 files changed, 14 insertions(+), 22 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-special.lsp b/src/cmp/cmpbackend-cxx/cmppass2-special.lsp index d649804cb..3e794287f 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-special.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-special.lsp @@ -18,16 +18,9 @@ (declare (ignore c1form)) (progv symbols values (c2expr body))) -(defun c2function (c1form kind funob fun) - (declare (ignore c1form funob)) - (case kind - (GLOBAL - (unwind-exit `(FDEFINITION ,fun))) - (CLOSURE - ;; XXX: we have some code after baboon – is CLOSURE legal or not? - (baboon :format-control "c2function: c1form is of unexpected kind.") - (new-local fun) - (unwind-exit `(MAKE-CCLOSURE ,fun))))) +(defun c2function (c1form fname) + (declare (ignore c1form)) + (unwind-exit `(FDEFINITION ,fname))) ;;; Mechanism for sharing code. (defun new-local (fun) diff --git a/src/cmp/cmppass1-special.lsp b/src/cmp/cmppass1-special.lsp index 643494471..ffe886698 100644 --- a/src/cmp/cmppass1-special.lsp +++ b/src/cmp/cmppass1-special.lsp @@ -64,17 +64,16 @@ (defun c1function (args) (check-args-number 'FUNCTION args 1 1) (let ((fun (car args))) - (cond ((si::valid-function-name-p fun) - (let ((funob (local-function-ref fun t))) - (if funob - (let* ((var (fun-var funob))) - (add-to-read-nodes var (make-c1form* 'VAR :args var nil))) - (make-c1form* 'FUNCTION - :type 'FUNCTION - :sp-change (not (and (symbolp fun) - (si:get-sysprop fun 'NO-SP-CHANGE))) - :args 'GLOBAL nil fun)))) - ((and (consp fun) (member (car fun) '(LAMBDA EXT::LAMBDA-BLOCK))) + (cond ((si:valid-function-name-p fun) + (ext:if-let ((funob (local-function-ref fun t))) + (let ((var (fun-var funob))) + (add-to-read-nodes var (make-c1form* 'VAR :args var nil))) + (make-c1form* 'FUNCTION + :type 'FUNCTION + :sp-change (not (and (symbolp fun) + (si:get-sysprop fun 'NO-SP-CHANGE))) + :args fun))) + ((and (consp fun) (member (car fun) '(LAMBDA EXT:LAMBDA-BLOCK))) (cmpck (endp (cdr fun)) "The lambda expression ~s is illegal." fun) (let (name body) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 94e1913ed..b9e618481 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -62,7 +62,7 @@ (CL:MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects) (CL:MULTIPLE-VALUE-BIND vars-list init-c1form body :pure) - (CL:FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued) + (CL:FUNCTION fname :single-valued) (CL:RPLACD (dest-c1form value-c1form) :side-effects) (SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure) From e32b5d5e1f5f8c9be45919af1f13ab0e0056e43e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 23 Sep 2023 07:09:19 +0200 Subject: [PATCH 09/15] cmp: cmpopt-cons: remove expand-simple-optimizer (rplaca, rplacd) RPLACA and RPLACD macros were the only clients of SIMPLE-OPTIMIZER-FUNCTION and said optimizer took more code than explicitly writing twice the expansion as the compiler macro. --- src/cmp/cmpopt-cons.lsp | 58 ++++++++++++++--------------------------- 1 file changed, 19 insertions(+), 39 deletions(-) diff --git a/src/cmp/cmpopt-cons.lsp b/src/cmp/cmpopt-cons.lsp index acf9b9920..6b83d210e 100644 --- a/src/cmp/cmpopt-cons.lsp +++ b/src/cmp/cmpopt-cons.lsp @@ -6,40 +6,11 @@ ;;;; ;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll ;;;; -;;;; 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 the file 'LICENSE' for the copyright details. ;;;; -;;;; See file '../Copyright' for full details. (in-package "COMPILER") -(defun expand-simple-optimizer (values arg-types inline-form env) - (declare (si::c-local)) - `(ffi:c-inline ,(if (policy-assume-right-type env) - values - (loop for v in values - for value-and-type in arg-types - collect (if (consp value-and-type) - `(ext:checked-value ,(second value-and-type) ,v) - v))) - ,@inline-form)) - -(defun simple-optimizer-function (name args inline-form) - (declare (si::c-local)) - (si:put-sysprop - name 'si::compiler-macro - (if (every #'symbolp args) - #'(lambda (whole env) - (if (policy-inline-accessors env) - `(ffi:c-inline ,(rest whole) ,@inline-form) - whole)) - #'(lambda (whole env) - (if (policy-inline-accessors env) - (expand-simple-optimizer (rest whole) args inline-form env) - whole))))) - (defun si:cons-car (x) (declare (type cons x) (optimize (safety 0) (speed 3))) (car x)) @@ -74,16 +45,25 @@ ;;; RPLACA / RPLACD ;;; -(defmacro define-simple-optimizer (name args &rest inline-form) - `(simple-optimizer-function ',name ',args ',inline-form)) +(define-compiler-macro rplaca (&whole whole place value) + (if (policy-inline-accessors) + `(ffi:c-inline (,(if (policy-assume-right-type) + place + `(ext:checked-value cons ,place)) + ,value) + (:object :object) :object + "(ECL_CONS_CAR(#0)=#1,#0)" :one-liner t) + whole)) -(define-simple-optimizer rplaca ((c cons) value) - (:object :object) :object - "@0;(ECL_CONS_CAR(#0)=#1,#0)" :one-liner t) - -(define-simple-optimizer rplacd ((c cons) value) - (:object :object) :object - "@0;(ECL_CONS_CDR(#0)=#1,#0)" :one-liner t) +(define-compiler-macro rplacd (&whole whole place value) + (if (policy-inline-accessors) + `(ffi:c-inline (,(if (policy-assume-right-type) + place + `(ext:checked-value cons ,place)) + ,value) + (:object :object) :object + "(ECL_CONS_CDR(#0)=#1,#0)" :one-liner t) + whole)) ;;; ;;; NTH / NTHCDR From 2d0ffd53b2f53e4fe57431bd0bd5db9e503d81dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 19 Jun 2023 15:26:15 +0200 Subject: [PATCH 10/15] cmpc: remove the safety-level qualifier :SAFE from the inliner This inlining qualifier was commented to be applied only in the safe code, but in the code it was applied all the same as :always (as a second choice after the unsafe optimizer). Moreover there was only single sysfun that specified it. --- src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp | 11 +++++------ src/cmp/cmpbackend-cxx/cmpc-inliner.lsp | 4 ---- src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp | 15 ++++++++------- 3 files changed, 13 insertions(+), 17 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp index 0c57ca0f6..9b205ca30 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp @@ -23,9 +23,9 @@ ;;; Here, ARG-TYPE is the list of argument types belonging to the lisp family, ;;; while RETURN-REP-TYPE is a representation type, i.e. the C type of the ;;; output expression. EXPANSION-STRING is a C/C++ expression template, like the -;;; ones used by C-INLINE. Finally, KIND can be :ALWAYS, :SAFE or :UNSAFE, -;;; depending on whether the inline expression should be applied always, in safe -;;; or in unsafe compilation mode, respectively. +;;; ones used by C-INLINE. Finally, KIND can be :ALWAYS or :UNSAFE, depending on +;;; whether the inline expression should be applied always or only in the unsafe +;;; compilation mode, respectively. ;;; (defun inline-information (name safety) @@ -41,9 +41,8 @@ (setf safety (case safety (:unsafe :inline-unsafe) - (:safe :inline-safe) (:always :inline-always) - (t (error "In DEF-INLINE, wrong value of SAFETY")))) + (t (error "In DEF-INLINE, ~s is a wrong value of SAFETY." safety)))) ;; Ensure we can inline this form. We only inline when the features are ;; there (checked above) and when the C types are part of this machine ;; (checked here). @@ -333,7 +332,7 @@ (def-inline cl:cons :always (t t) t "CONS(#0,#1)") - (def-inline cl:endp :safe (t) :bool "ecl_endp(#0)") + (def-inline cl:endp :always (t) :bool "ecl_endp(#0)") (def-inline cl:endp :unsafe (t) :bool "#0==ECL_NIL") (def-inline cl:nth :always (t t) t "ecl_nth(ecl_to_size(#0),#1)") diff --git a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp index e35189339..ba72635e7 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp @@ -96,10 +96,6 @@ (let ((other (inline-type-matches x types return-type))) (when other (setf output (choose-inline-info output other return-type return-rep-type)))))) - (dolist (x (inline-information fname ':INLINE-SAFE)) - (let ((other (inline-type-matches x types return-type))) - (when other - (setf output (choose-inline-info output other return-type return-rep-type))))) (dolist (x (inline-information fname ':INLINE-ALWAYS)) (let ((other (inline-type-matches x types return-type))) (when other diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp index 3ec92ba62..c242d55ee 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp @@ -14,7 +14,6 @@ ;;; Valid property names for open coded functions are: ;;; :INLINE-ALWAYS -;;; :INLINE-SAFE safe-compile only ;;; :INLINE-UNSAFE non-safe-compile only ;;; ;;; Each property is a list of 'inline-info's, where each inline-info is: @@ -22,12 +21,14 @@ ;;; ;;; 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. +;;; 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)))) From 49668f8ddafe3d8094304d1f3ce430ae44953a85 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 20 Jun 2023 11:20:11 +0200 Subject: [PATCH 11/15] cmpc: %def-inline: remove an option :inline-or-warn --- contrib/cl-simd/ecl-sse-core.lisp | 12 +++---- src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp | 10 +----- src/cmp/cmpbackend-cxx/cmpc-inliner.lsp | 37 ++++++---------------- src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp | 4 +-- src/cmp/cmpbackend-cxx/cmpc-wt.lsp | 10 ++++++ 5 files changed, 26 insertions(+), 47 deletions(-) diff --git a/contrib/cl-simd/ecl-sse-core.lisp b/contrib/cl-simd/ecl-sse-core.lisp index fcf3b2a2e..7df19654c 100644 --- a/contrib/cl-simd/ecl-sse-core.lisp +++ b/contrib/cl-simd/ecl-sse-core.lisp @@ -137,8 +137,7 @@ `((defun ,name ,asyms (declare (optimize (speed 0) (debug 0) (safety 1))) (ffi:c-inline ,asyms ,aftypes ,rftype ,(or defun-body call-str) :one-liner t)))) - (def-inline ,name :always ,(mapcar #'inline-arg-type-of arg-types) ,rftype - ,call-str :inline-or-warn t)))) + (def-inline ,name :always ,(mapcar #'inline-arg-type-of arg-types) ,rftype ,call-str)))) (defmacro def-unary-intrinsic (name ret-type insn cost c-name &key (arg-type ret-type) partial result-size immediate-arg) @@ -211,8 +210,7 @@ :one-liner t)) ;; AREF (def-inline ,rm-aref-name :always (t t) ,rftype - ,(fmtr "ecl_row_major_ptr(#0,fixint(#1),~A)" bsize) - :inline-or-warn t) + ,(fmtr "ecl_row_major_ptr(#0,fixint(#1),~A)" bsize)) (def-inline ,rm-aref-name :always (t fixnum) ,rftype ,(fmtr "ecl_row_major_ptr(#0,#1,~A)" bsize)) ;; AREF unsafe @@ -237,8 +235,7 @@ (defsetf ,rm-aref-name ,rm-aset-name) ;; ASET (def-inline ,rm-aset-name :always (t t ,val-type) ,rftype - ,(fmtw "ecl_row_major_ptr(#0,fixint(#1),~A)" bsize) - :inline-or-warn t) + ,(fmtw "ecl_row_major_ptr(#0,fixint(#1),~A)" bsize)) (def-inline ,rm-aset-name :always (t fixnum ,val-type) ,rftype ,(fmtw "ecl_row_major_ptr(#0,#1,~A)" bsize)) ;; ASET unsafe @@ -290,8 +287,7 @@ ,(fmt "(((char*)#~A) + #~A)") :one-liner t)) (def-inline ,name :always (,@prefix-itypes t ,@postfix-itypes) ,rftype - ,(fmt "ecl_to_pointer(#~A)") - :inline-or-warn t) + ,(fmt "ecl_to_pointer(#~A)")) (def-inline ,name :always (,@prefix-itypes t ,@postfix-itypes t) ,rftype ,(fmt "(((char*)ecl_to_pointer(#~A)) + fixint(#~A))")) (def-inline ,name :always (,@prefix-itypes t ,@postfix-itypes fixnum) ,rftype diff --git a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp index 9b205ca30..85b0d3f1f 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp @@ -35,7 +35,7 @@ (setf (gethash (list name safety) *inline-information*) value)) (defun %def-inline (name safety arg-types return-rep-type expansion - &key (one-liner t) (exact-return-type nil) (inline-or-warn nil) + &key (one-liner t) (exact-return-type nil) (multiple-values t) &aux arg-rep-types) (setf safety @@ -58,8 +58,6 @@ arg-types)) (when (eq return-rep-type t) (setf return-rep-type :object)) - (when inline-or-warn - (setf (inline-information name 'should-be-inlined) t)) (let* ((return-type (if (and (consp return-rep-type) (eq (first return-rep-type) 'values)) t @@ -75,12 +73,6 @@ ;; :side-effects (not (si:get-sysprop name 'no-side-effects)) :one-liner one-liner :expansion expansion))) - #+(or) - (loop for i in (inline-information name safety) - when (and (equalp (inline-info-arg-types i) arg-types) - (not (equalp return-type (inline-info-return-type i)))) - do (format t "~&;;; Redundand inline definition for ~A~&;;; ~<~A~>~&;;; ~<~A~>" - name i inline-info)) (push inline-info (gethash (list name safety) *inline-information*)))) (defmacro def-inline (&rest args) diff --git a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp index ba72635e7..0badbb194 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp @@ -100,30 +100,22 @@ (let ((other (inline-type-matches x types return-type))) (when other (setf output (choose-inline-info output other return-type return-rep-type))))) - (when (and (null output) - (inline-information fname 'should-be-inlined) - (>= (cmp-env-optimization 'speed) 1)) - (cmpwarn-style "Could not inline call to ~S ~S - performance may be degraded." - fname types)) output)) (defun to-fixnum-float-type (type) - (dolist (i '(FIXNUM DOUBLE-FLOAT SINGLE-FLOAT LONG-FLOAT) - nil) + (dolist (i '(CL:FIXNUM CL:DOUBLE-FLOAT CL:SINGLE-FLOAT CL:LONG-FLOAT) nil) (when (type>= i type) (return i)))) (defun maximum-float-type (t1 t2) - (cond ((null t1) - t2) - ((or (eq t1 'LONG-FLOAT) (eq t2 'LONG-FLOAT)) - 'LONG-FLOAT) - ((or (eq t1 'DOUBLE-FLOAT) (eq t2 'DOUBLE-FLOAT)) - 'DOUBLE-FLOAT) - ((or (eq t1 'SINGLE-FLOAT) (eq t2 'SINGLE-FLOAT)) - 'SINGLE-FLOAT) - (T - 'FIXNUM))) + (macrolet ((try-type (type) + `(and (or (eq t1 ,type) (eq t2 ,type)) + ,type))) + (or (and (null t1) t2) + (try-type 'CL:LONG-FLOAT) + (try-type 'CL:DOUBLE-FLOAT) + (try-type 'CL:SINGLE-FLOAT) + 'CL:FIXNUM))) (defun inline-type-matches (inline-info arg-types return-type) (when (and (not (inline-info-multiple-values inline-info)) @@ -181,17 +173,6 @@ (nreverse rts)) inline-info)))) -(defun c-inline-safe-string (constant-string) - ;; Produce a text representation of a string that can be used - ;; in a C-INLINE form, without triggering the @ or # escape - ;; characters - (c-filtered-string - (concatenate 'string - (loop for c across constant-string - when (member c '(#\# #\@)) - collect c - collect c)))) - (defun produce-inline-loc (inlined-arguments arg-types output-rep-type c-expression side-effects one-liner) (let* (args-to-be-saved diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp index c242d55ee..469b53100 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp @@ -159,8 +159,8 @@ ;;; (defun inline-args (forms) (loop for form-list on forms - for form = (first form-list) - collect (emit-inline-form form (rest form-list)))) + for form = (first form-list) + collect (emit-inline-form form (rest form-list)))) (defun destination-type () (rep-type->lisp-type (loc-representation-type *destination*)) diff --git a/src/cmp/cmpbackend-cxx/cmpc-wt.lsp b/src/cmp/cmpbackend-cxx/cmpc-wt.lsp index 93dc130f2..85b01f027 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-wt.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-wt.lsp @@ -210,3 +210,13 @@ (defun c-filtered-string (string &rest args) (with-output-to-string (aux-stream) (apply #'wt-filtered-data string aux-stream :one-liner t args))) + +(defun c-inline-safe-string (constant-string) + ;; Produce a text representation of a string that can be used in a C-INLINE + ;; form, without triggering the @ or # escape characters + (c-filtered-string + (concatenate 'string + (loop for c across constant-string + when (member c '(#\# #\@)) + collect c + collect c)))) From 6d60cf294a1fd6c073fd8a7d0316b7810a16315e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 20 Jun 2023 13:41:32 +0200 Subject: [PATCH 12/15] cmpc: move the c-inliner fully to the cmpc backend module --- src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp | 5 +++++ src/cmp/cmpbackend-cxx/cmpc-inliner.lsp | 18 ++++++++++++++---- src/cmp/cmpbackend-cxx/cmpc-mach.lsp | 2 -- src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp | 2 +- src/cmp/cmpbackend-cxx/cmpc-util.lsp | 7 ++++++- src/cmp/cmpglobals.lsp | 7 +------ src/cmp/cmptypes.lsp | 13 ------------- src/cmp/load.lsp.in | 5 +++-- 8 files changed, 30 insertions(+), 29 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp index 85b0d3f1f..64bd2b7e7 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp @@ -806,3 +806,8 @@ (def-inline clos:funcallable-standard-instance-access :unsafe (clos:funcallable-standard-object fixnum) t "(#0)->instance.slots[#1]")) *inline-information*)) + +;;; XXX this should be part of the initializer for the compiler instance (but +;;; currently the compiler is a singleton). +(setf (machine-inline-information *default-machine*) + (make-inline-information *default-machine*)) diff --git a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp index 0badbb194..b73efc7a7 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp @@ -14,8 +14,18 @@ (in-package "COMPILER") -(setf (machine-inline-information *default-machine*) - (make-inline-information *default-machine*)) +(defstruct (inline-info) + name ;;; Function name + arg-rep-types ;;; List of representation types for the arguments + return-rep-type ;;; Representation type for the output + arg-types ;;; List of lisp types for the arguments + return-type ;;; Lisp type for the output + exact-return-type ;;; Only use this expansion when the output is + ;;; declared to have a subtype of RETURN-TYPE + multiple-values ;;; Works with all destinations, including VALUES / RETURN + expansion ;;; C template containing the expansion + one-liner ;;; Whether the expansion spans more than one line +) (defun inlined-arg-loc (arg) (second arg)) @@ -47,8 +57,8 @@ ;;; returns NIL if inline expansion of the function is not possible ;;; (defun inline-function (fname arg-types return-type &optional (return-rep-type 'any)) - ;; Those functions that use INLINE-FUNCTION must rebind - ;; the variable *INLINE-BLOCKS*. + ;; Those functions that use INLINE-FUNCTION must rebind the variable + ;; *INLINE-BLOCKS*. (and (inline-possible fname) (not (gethash fname *c2-dispatch-table*)) (let* (;; (dest-rep-type (loc-representation-type *destination*)) diff --git a/src/cmp/cmpbackend-cxx/cmpc-mach.lsp b/src/cmp/cmpbackend-cxx/cmpc-mach.lsp index 5b6161940..c10273eb9 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-mach.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-mach.lsp @@ -17,8 +17,6 @@ sorted-types inline-information) -;;; FIXME currently all definitions assume C machine (see cmpc-machine.lsp). - (defstruct (rep-type (:constructor %make-rep-type)) (index 0) ; Precedence order in the type list (name t) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp index 7cf5550cb..51e5bf39d 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp @@ -24,7 +24,7 @@ :one-liner t :side-effects nil)))) ((floatp name) (let* ((value name) - (type (type-of value)) + (type (type-of value)) (loc-type (case type (cl:single-float 'single-float-value) (cl:double-float 'double-float-value) diff --git a/src/cmp/cmpbackend-cxx/cmpc-util.lsp b/src/cmp/cmpbackend-cxx/cmpc-util.lsp index fdfe63f1b..3bde7430f 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-util.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-util.lsp @@ -10,6 +10,7 @@ (defvar *opened-c-braces* 0) (defvar *emitted-local-funs* nil) +(defvar *inline-information* nil) ;;; Compiled code uses the following kinds of variables: ;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl) @@ -67,7 +68,11 @@ (*temp* 0) (*max-temp* 0) (*next-cfun* 0) - (*last-label* 0)) + (*last-label* 0) + (*inline-information* + (ext:if-let ((r (machine-inline-information *machine*))) + (si:copy-hash-table r) + (make-inline-information *machine*)))) ,@body)) (defun-cached env-var-name (n) eql diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 442a0aaf9..7b52c3826 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -22,7 +22,6 @@ (defvar *inline-max-depth* 3 "Depth at which inlining of functions stops.") -(defvar *inline-information* nil) ;;; --cmputil.lsp-- ;;; @@ -267,9 +266,5 @@ be deleted if they have been opened with LoadLibrary.") (*clines-string-list* '()) (si::*defun-inline-hook* 'maybe-install-inline-function) (*machine* (or *machine* *default-machine*)) - (*optimizable-constants* (make-optimizable-constants *machine*)) - (*inline-information* - (ext:if-let ((r (machine-inline-information *machine*))) - (si:copy-hash-table r) - (make-inline-information *machine*))))) + (*optimizable-constants* (make-optimizable-constants *machine*)))) diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp index 053bc99c7..73c6cbdf8 100644 --- a/src/cmp/cmptypes.lsp +++ b/src/cmp/cmptypes.lsp @@ -49,16 +49,3 @@ (format t "~% ~D > ~A, parent ~A" *c1form-level* form (c1form-parents form)) (print-c1forms (c1form-args form)) form))) - -(defstruct (inline-info) - name ;;; Function name - arg-rep-types ;;; List of representation types for the arguments - return-rep-type ;;; Representation type for the output - arg-types ;;; List of lisp types for the arguments - return-type ;;; Lisp type for the output - exact-return-type ;;; Only use this expansion when the output is - ;;; declared to have a subtype of RETURN-TYPE - multiple-values ;;; Works with all destinations, including VALUES / RETURN - expansion ;;; C template containing the expansion - one-liner ;;; Whether the expansion spans more than one line -) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 4d0458811..2ee92144f 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -48,9 +48,10 @@ "src:cmp;cmpbackend-cxx;cmpc-util.lsp" "src:cmp;cmpbackend-cxx;cmpc-mach.lsp" "src:cmp;cmpbackend-cxx;cmpc-wt.lsp" - "src:cmp;cmpbackend-cxx;cmpc-inl-sysfun.lsp" - "src:cmp;cmpbackend-cxx;cmpc-inl-lspfun.lsp" "src:cmp;cmpbackend-cxx;cmpc-inliner.lsp" + ;; Inliner definitions + "src:cmp;cmpbackend-cxx;cmpc-inl-lspfun.lsp" + "src:cmp;cmpbackend-cxx;cmpc-inl-sysfun.lsp" "src:cmp;cmpbackend-cxx;cmpc-opt-inl.lsp" "src:cmp;cmpbackend-cxx;cmpc-opt-num.lsp" "src:cmp;cmpbackend-cxx;cmpc-opt-ct.lsp" From 5a8f6780b8834f523459302d45e432c07f9a8d8d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 23 Sep 2023 10:15:04 +0200 Subject: [PATCH 13/15] cmpc: sysfun: add default inline definitions for printer functions This resolves a todo in cmpc-opt-printer.lsp: ;;; TODO move mundane inliners to the sysfun database. We leave only the optimizer for CL:PRINC that is not mundane. The default C inliner for CL:PRINC is also defined in the sysfun database. --- src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp | 5 +++++ src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp | 25 +-------------------- 2 files changed, 6 insertions(+), 24 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp index 64bd2b7e7..ff1ec496e 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp @@ -644,6 +644,11 @@ (def-inline cl:boundp :always (t) :bool "ecl_boundp(cl_env_copy,#0)") (def-inline cl:boundp :unsafe ((and symbol (not null))) :bool "ECL_SYM_VAL(cl_env_copy,#0)!=OBJNULL") + (def-inline cl:terpri :always (t) :object "(ecl_terpri(#0))") + (def-inline cl:print :always (t t) :object "(ecl_print(#0,#1))") + (def-inline cl:prin1 :always (t t) :object "(ecl_prin1(#0,#1))") + (def-inline cl:princ :always (t t) :object "(ecl_princ(#0,#1))") + ;; file unixsys.d ;; file sequence.d diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp index 494b97d71..4f4d57858 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp @@ -12,30 +12,7 @@ (in-package "COMPILER") -;;; TODO move mundane inliners to the sysfun database. - -(define-c-inliner terpri (return-type &optional stream) - (produce-inline-loc (list stream) - '(:object) '(:object) - "ecl_terpri(#0)" t t)) - -(define-c-inliner print (return-type value &optional stream) - (produce-inline-loc (list value stream) - '(:object :object) '(:object) - "ecl_print(#0,#1)" t t)) - -(define-c-inliner prin1 (return-type value &optional stream) - (produce-inline-loc (list value stream) - '(:object :object) '(:object) - "ecl_prin1(#0,#1)" t t)) - -#+ (or) -(define-c-inliner princ (return-type expression &optional stream) - (produce-inline-loc (list expression stream) - '(:object :object) '(:object) - "ecl_princ(#0,#1)" t t)) - -(define-c-inliner princ (return-type expression &optional stream) +(define-c-inliner cl:princ (return-type expression &optional stream) (multiple-value-bind (foundp value) (loc-immediate-value-p (inlined-arg-loc expression)) (cond From f195f7d57413075adbb8db971cc6c1adffedef45 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 30 Jun 2023 12:46:03 +0200 Subject: [PATCH 14/15] cmpc: get rid of an undocumented and unused code path for FFI:CLINES We've supported syntax for clines that allowed inlining Lisp objects when they were prepended with @, for example (ffi:clines "#include @my-variable"); that said I have not seen a single use of this syntax and it compilcated the logic (the read object needed to land in the data segment during the second pass). --- src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp | 26 +++++++------------------ 1 file changed, 7 insertions(+), 19 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp index b6a628fc7..01342c6b5 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp @@ -33,25 +33,13 @@ '(progn)) (defun output-clines (output-stream) - (flet ((parse-one-string (s output-stream) - (with-input-from-string (stream s) - (loop for c = (read-char stream nil nil) - while c - do (if (eq c #\@) - (let ((object (handler-case (read stream) - (serious-condition (c) - (cmperr "Unable to parse FFI:CLINES string~& ~S" - s))))) - (let ((*compiler-output1* output-stream)) - (wt (add-object object :permanent t)))) - (write-char c output-stream)))))) - (loop for s in *clines-string-list* - do (terpri output-stream) - do (if (find #\@ s) - (parse-one-string s output-stream) - (write-string s output-stream))) - (terpri output-stream) - (setf *clines-string-list* nil))) + (loop for s in *clines-string-list* + do (terpri output-stream) + do (if (find #\@ s) + (cmperr "The character #\\@ is not allowed in ~s." 'FFI:CLINES) + (write-string s output-stream))) + (terpri output-stream) + (setf *clines-string-list* nil)) ;; ---------------------------------------------------------------------- ;; C/C++ INLINE CODE From e49eafac2290f99bacd6dd0b792ad3923e243025 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 30 Jun 2023 13:16:35 +0200 Subject: [PATCH 15/15] cmpc: get rid of another undocumented feature from FFI:C-INLINE ffi:c-inline allowed for the xyntax @object (similar to the previous commit), although only syntax "@(return x) = xxx" is specified in the documentation. --- contrib/sockets/sockets.lisp | 4 ++-- src/cmp/cmpbackend-cxx/cmppass2-loc.lsp | 23 ++++++++++------------- src/cmp/cmppass1-ffi.lsp | 4 ++-- src/lsp/ffi.lsp | 7 ++++--- src/lsp/top.lsp | 4 ++-- 5 files changed, 20 insertions(+), 22 deletions(-) diff --git a/contrib/sockets/sockets.lisp b/contrib/sockets/sockets.lisp index 7a80b40c6..8f3260f35 100755 --- a/contrib/sockets/sockets.lisp +++ b/contrib/sockets/sockets.lisp @@ -210,7 +210,7 @@ containing the whole rest of the given `string', if any." HOST-NAME may also be an IP address in dotted quad notation or some other weird stuff - see getaddrinfo(3) for details." (multiple-value-bind (errno canonical-name addresses aliases) - (c-inline (host-name) (:cstring) + (c-inline (host-name :test #'equalp) (:cstring :object :object) (values :int :object :object :object) " { @@ -247,7 +247,7 @@ other weird stuff - see getaddrinfo(3) for details." ecl_aset(vector,1, ecl_make_fixnum( (ip>>16) & 0xFF)); ecl_aset(vector,2, ecl_make_fixnum( (ip>>8) & 0xFF)); ecl_aset(vector,3, ecl_make_fixnum( ip & 0xFF )); - addresses = cl_adjoin(4, vector, addresses, @':test, @'equalp); + addresses = cl_adjoin(4, vector, addresses, #1, #2); if ( rp->ai_canonname != 0 ) { cl_object alias = ecl_make_simple_base_string( rp->ai_canonname, -1 ); aliases = CONS(alias, aliases); diff --git a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp index 5ef7451ad..d2fb35b35 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp @@ -385,19 +385,16 @@ (case c (#\@ (let ((object (read s))) - (cond ((and (consp object) (equal (first object) 'RETURN)) - (if (eq output-vars 'VALUES) - (cmperr "User @(RETURN ...) in a C-INLINE form with no output values") - (let ((ndx (or (second object) 0)) - (l (length output-vars))) - (if (< ndx l) - (wt (nth ndx output-vars)) - (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values" - ndx l))))) - (t - (when (and (consp object) (eq (first object) 'QUOTE)) - (setq object (second object))) - (wt (add-object object :permanent t)))))) + (unless (and (consp object) (eq (car object) 'RETURN)) + (cmperr "Used @~s in C-INLINE form. Expected syntax is @(RETURN ...)." object)) + (if (eq output-vars 'VALUES) + (cmperr "Used @(RETURN ...) in a C-INLINE form with no output values.") + (let ((ndx (or (second object) 0)) + (l (length output-vars))) + (if (< ndx l) + (wt (nth ndx output-vars)) + (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values." + ndx l)))))) (#\# (let* ((k (read-char s)) (next-char (peek-char nil s nil nil)) diff --git a/src/cmp/cmppass1-ffi.lsp b/src/cmp/cmppass1-ffi.lsp index bc9ffa75d..9d7792282 100644 --- a/src/cmp/cmppass1-ffi.lsp +++ b/src/cmp/cmppass1-ffi.lsp @@ -175,6 +175,6 @@ `(progn (defun ,name ,(reverse arg-variables) ,@body) (si:put-sysprop ',name :callback - (ffi:c-inline () () :object - ,(format nil "ecl_make_foreign_data(@':pointer-void,0,(void*)~a)" c-name) + (ffi:c-inline (:pointer-void) (:object) :object + ,(format nil "ecl_make_foreign_data(#0,0,(void*)~a)" c-name) :one-liner t))))))) diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index 017aaaa99..894c9642f 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -477,12 +477,13 @@ translate ASCII and binary strings." Converts a Lisp string to a foreign string. Memory should be freed with free-foreign-object." - (let ((lisp-string (string string-designator))) - (c-inline (lisp-string) (t) t + (let ((lisp-string (string string-designator)) + (foreign-type '(* :char))) + (c-inline (lisp-string foreign-type) (t t) t "{ cl_object lisp_string = #0; cl_index size = lisp_string->base_string.fillp; - cl_object output = ecl_allocate_foreign_data(@(* :char), size+1); + cl_object output = ecl_allocate_foreign_data(#1, size+1); memcpy(output->foreign.data, lisp_string->base_string.self, size); output->foreign.data[size] = '\\0'; @(return) = output; diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 4d602e5b3..efa2c48e1 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -843,7 +843,7 @@ Use special code 0 to cancel this operation.") #-ecl-min (defun decode-env-elt (env ndx) - (ffi:c-inline (env ndx) (:object :fixnum) :object + (ffi:c-inline (env ndx :utf-8) (:object :fixnum :object) :object " cl_object v = #0; cl_index ndx = #1; @@ -851,7 +851,7 @@ Use special code 0 to cancel this operation.") pinfo d = (pinfo)(v->vector.self.t[1]) + ndx; cl_object name; #ifdef ECL_UNICODE - name = ecl_decode_from_cstring(d->name,-1,@:utf-8); + name = ecl_decode_from_cstring(d->name,-1,#2); if (!name) #endif name = ecl_make_constant_base_string(d->name,-1);