diff --git a/src/cmp/cmpbackend-cxx/cmpc-arg-inl.lsp b/src/cmp/cmpbackend-cxx/cmpc-arg-inl.lsp new file mode 100644 index 000000000..6ca478510 --- /dev/null +++ b/src/cmp/cmpbackend-cxx/cmpc-arg-inl.lsp @@ -0,0 +1,205 @@ +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2023, Daniel Kochmański +;;;; +;;;; See the file 'LICENSE' for the copyright details. +;;;; + +;;;; Open coding nested forms as C expressions while preserving the order of +;;;; evaluation. Resulting locations stored in the INLINE-ARG structure may be +;;;; used inline in C expressions (locs still must to be coerced appropriately). + +(in-package "COMPILER") + +(defstruct (inlined-arg (:constructor %make-inlined-arg)) + loc + type + rep-type) + +(defun make-inlined-arg (loc lisp-type) + (%make-inlined-arg :loc loc :type lisp-type + :rep-type (loc-representation-type loc))) + +(defun maybe-open-inline-block () + (unless (plusp *inline-blocks*) + (open-inline-block))) + +(defun open-inline-block () + (wt-nl-open-brace) + (incf *inline-blocks*)) + +(defun close-inline-blocks () + (loop for i of-type fixnum from 0 below *inline-blocks* + do (wt-nl-close-brace))) + +(defun coerce-locs (inlined-args &optional types args-to-be-saved) + ;; INLINED-ARGS is a list of INLINED-ARG produced by the argument inliner. + ;; The structure contains a location, a lisp type, and the mach rep type. + ;; + ;; ARGS-TO-BE-SAVED is a positional list created by C-INLINE, instructing that + ;; the value should be saved in a temporary variable. + ;; + ;; TYPES is a list of destination types, to which the former values are + ;; coerced. The destination type can be: + ;; + ;; - A machine rep type (:OBJECT, :FIXNUM, :INT, ...) + ;; - A lisp type (T, INTEGER, STRING, CHARACTER, ...)) + ;; + (loop with block-opened = nil + for arg in inlined-args + for loc = (inlined-arg-loc arg) + for arg-rep-type = (inlined-arg-rep-type arg) + for type in (or types '#1=(:object . #1#)) + for i from 0 + for rep-type = (lisp-type->rep-type type) + collect + (cond ((and args-to-be-saved + (member i args-to-be-saved :test #'eql) + (not (loc-movable-p loc))) + (let ((lcl (make-lcl-var :rep-type rep-type))) + (wt-nl) + (unless block-opened + (setf block-opened t) + (open-inline-block)) + (wt (rep-type->c-name rep-type) " " lcl "= ") + (wt-coerce-loc rep-type loc) + (wt ";") + lcl)) + ((equal rep-type arg-rep-type) + loc) + (t + `(COERCE-LOC ,rep-type ,loc))))) + +(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) + (make-temp-var value-type) + (let ((var (make-lcl-var :rep-type out-rep-type + :type value-type))) + (open-inline-block) + (wt-nl (rep-type->c-name out-rep-type) " " var ";") + var)))) + +(defun emit-inlined-variable (form rest-forms) + (let ((var (c1form-arg 0 form)) + (lisp-type (c1form-primary-type form))) + (if (var-changed-in-form-list var rest-forms) + (let ((temp (make-inline-temp-var lisp-type (var-rep-type var)))) + (set-loc temp var) + (make-inlined-arg temp lisp-type)) + (make-inlined-arg var lisp-type)))) + +(defun emit-inlined-setq (form rest-forms) + (let ((vref (c1form-arg 0 form)) + (form1 (c1form-arg 1 form))) + (let ((*destination* vref)) + (c2expr* form1)) + (if (eq (c1form-name form1) 'LOCATION) + (make-inlined-arg (c1form-arg 0 form1) (c1form-primary-type form1)) + (emit-inlined-variable (make-c1form 'VARIABLE form vref nil) rest-forms)))) + +(defun emit-inlined-call-global (form expected-type) + (let* ((fname (c1form-arg 0 form)) + (args (c1form-arg 1 form)) + (return-type (c1form-primary-type form)) + (fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p)) + (loc (call-global-loc fname fun args return-type expected-type)) + (type (type-and return-type (loc-type loc))) + (temp (make-inline-temp-var type (loc-representation-type loc)))) + (set-loc temp loc) + (make-inlined-arg temp type))) + +(defun emit-inlined-progn (form forms) + (let ((args (c1form-arg 0 form))) + (loop with *destination* = 'TRASH + while (rest args) + do (c2expr* (pop args))) + (emit-inline-form (first args) forms))) + +(defun emit-inlined-values (form forms) + (let ((args (c1form-arg 0 form))) + (prog1 (emit-inline-form (or (pop args) (c1nil)) + ;; the rest of the values args need to be + ;; added to the rest forms to execute side + ;; effects in the correct order + (append args forms)) + (loop with *destination* = 'TRASH + for form in args + do (c2expr* form))))) + +(defun emit-inlined-structure-ref (form rest-forms) + (let ((type (c1form-primary-type form))) + (if (some #'c1form-side-effects rest-forms) + (let* ((temp (make-inline-temp-var type :object)) + (*destination* temp)) + (c2expr* form) + (make-inlined-arg temp type)) + (make-inlined-arg (list 'SI:STRUCTURE-REF + (first (coerce-locs + (inline-args (list (c1form-arg 0 form))))) + (c1form-arg 1 form) + (c1form-arg 2 form) + (c1form-arg 3 form)) + type)))) + +(defun emit-inlined-instance-ref (form rest-forms) + (let ((type (c1form-primary-type form))) + (if (some #'c1form-side-effects rest-forms) + (let* ((temp (make-inline-temp-var type :object)) + (*destination* temp)) + (c2expr* form) + (make-inlined-arg temp type)) + (make-inlined-arg (list 'SI:INSTANCE-REF + (first (coerce-locs + (inline-args (list (c1form-arg 0 form))))) + (c1form-arg 1 form) + #+ (or) (c1form-arg 2 form)) + type)))) + +(defun emit-inline-form (form forms) + (with-c1form-env (form form) + (case (c1form-name form) + (LOCATION + (make-inlined-arg (c1form-arg 0 form) (c1form-primary-type form))) + (VARIABLE + (emit-inlined-variable form forms)) + (CALL-GLOBAL + (emit-inlined-call-global form (c1form-primary-type form))) + (SI:STRUCTURE-REF + (emit-inlined-structure-ref form forms)) + (SI:INSTANCE-REF + (emit-inlined-instance-ref form forms)) + (SETQ + (emit-inlined-setq form forms)) + (PROGN + (emit-inlined-progn form forms)) + (VALUES + (emit-inlined-values form forms)) + (t (let* ((type (c1form-primary-type form)) + (temp (make-inline-temp-var type)) + (*destination* temp)) + (c2expr* form) + (make-inlined-arg temp type)))))) + +;;; +;;; inline-args: +;;; returns a list of pairs (type loc) +;;; side effects: emits code for temporary variables +;;; +;;; Whoever calls this function must wrap the body in WITH-INLINE-BLOCKS. +;;; +(defun inline-args (forms) + (loop for form-list on forms + for form = (first form-list) + collect (emit-inline-form form (rest form-list)))) + +;;; +;;; inline-arg0: +;;; returns a location that contains the function +;;; side effects: emits code for a temporary variable +;;; +;;; Whoever calls this function must wrap the body in WITH-INLINE-BLOCKS. +;;; +(defun inline-arg0 (value-form other-forms) + (emit-inline-form value-form other-forms)) diff --git a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp b/src/cmp/cmpbackend-cxx/cmpc-fun-inl.lsp similarity index 84% rename from src/cmp/cmpbackend-cxx/cmpc-inliner.lsp rename to src/cmp/cmpbackend-cxx/cmpc-fun-inl.lsp index 2ddb4285a..632d2f7f0 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-fun-inl.lsp @@ -2,8 +2,9 @@ ;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: ;;;; -;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. -;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2023, Daniel Kochmański ;;;; ;;;; See the file 'LICENSE' for the copyright details. ;;;; @@ -27,27 +28,17 @@ one-liner ;;; Whether the expansion spans more than one line ) -(defun inlined-arg-loc (arg) - (second arg)) - -(defun inlined-arg-type (arg) - (first arg)) - -(defun inlined-arg-rep-type (arg) - (loc-representation-type (second arg))) - (defmacro define-c-inliner (fname lambda-list &body body) `(setf (gethash ',fname *cinline-dispatch-table*) #'(lambda ,lambda-list (block nil ,@body)))) (defun apply-inliner (fname return-type inlined-args) - (let ((fd (gethash fname *cinline-dispatch-table*))) - (if fd - (apply fd return-type inlined-args) - (default-c-inliner fname return-type inlined-args)))) + (ext:if-let ((fd (gethash fname *cinline-dispatch-table*))) + (apply fd return-type inlined-args) + (default-c-inliner fname return-type inlined-args))) (defun default-c-inliner (fname return-type inlined-args) - (let* ((arg-types (mapcar #'first inlined-args)) + (let* ((arg-types (mapcar #'inlined-arg-type inlined-args)) (ii (inline-function fname arg-types return-type))) (and ii (apply-inline-info ii inlined-args)))) @@ -249,33 +240,18 @@ (wt "cl_env_copy->nvalues = " (length output-vars) ";") 'VALUEZ)))))) -(defun coerce-locs (inlined-args &optional types args-to-be-saved) - ;; INLINED-ARGS is a list of (TYPE LOCATION) produced by the - ;; inline code. ARGS-TO-BE-SAVED is a positional list created by - ;; C-INLINE, instructing that the value should be saved in a temporary - ;; variable. Finally, TYPES is a list of destination types, to which - ;; the former values are coerced. The destination types can be - ;; - A lisp type (:OBJECT, :FINXUM, etc) - ;; - A machine representation type (T, INTEGER, etc) - (loop with block-opened = nil - for (lisp-type loc) in inlined-args - for type in (or types '#1=(:object . #1#)) - for i from 0 - for rep-type = (lisp-type->rep-type type) - collect - (cond ((and args-to-be-saved - (member i args-to-be-saved :test #'eql) - (not (loc-movable-p loc))) - (let ((lcl (make-lcl-var :rep-type rep-type))) - (wt-nl) - (unless block-opened - (setf block-opened t) - (open-inline-block)) - (wt (rep-type->c-name rep-type) " " lcl "= ") - (wt-coerce-loc rep-type loc) - (wt ";") - lcl)) - ((equal rep-type (loc-representation-type loc)) - loc) - (t - `(COERCE-LOC ,rep-type ,loc))))) +;;; Whoever calls this function must wrap the body in WITH-INLINE-BLOCKS. +(defun negate-argument (argument dest-loc) + (let* ((inlined-arg (emit-inline-form argument nil)) + (rep-type (inlined-arg-rep-type inlined-arg))) + (apply #'produce-inline-loc + (list inlined-arg) + (if (eq (loc-representation-type dest-loc) :bool) + (case rep-type + (:bool '((:bool) (:bool) "(#0)==ECL_NIL" nil t)) + (:object '((:object) (:bool) "(#0)!=ECL_NIL" nil t)) + (otherwise (return-from negate-argument nil))) + (case rep-type + (:bool '((:bool) (:object) "(#0)?ECL_NIL:ECL_T" nil t)) + (:object '((:object) (:object) "Null(#0)?ECL_T:ECL_NIL" nil t)) + (otherwise (return-from negate-argument *vv-nil*))))))) 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 deleted file mode 100644 index 846033d49..000000000 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp +++ /dev/null @@ -1,178 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; -;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya -;;;; Copyright (c) 1990, Giuseppe Attardi -;;;; -;;;; See the file 'LICENSE' for the copyright details. -;;;; - -;;;; Open coding optimizer. - -(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) - (make-temp-var) - (let ((var (make-lcl-var :rep-type out-rep-type - :type value-type))) - (open-inline-block) - (wt-nl (rep-type->c-name out-rep-type) " " var ";") - var)))) - -(defun save-inline-loc (loc) - (let* ((rep-type (loc-representation-type (second loc))) - (temp (make-inline-temp-var (first loc) rep-type))) - (set-loc temp loc) - temp)) - -(defun emit-inlined-variable (form rest-forms) - (let ((var (c1form-arg 0 form)) - (value-type (c1form-primary-type form))) - (if (var-changed-in-form-list var rest-forms) - (let ((temp (make-inline-temp-var value-type (var-rep-type var)))) - (set-loc temp var) - (list value-type temp)) - (list value-type var)))) - -(defun emit-inlined-setq (form rest-forms) - (let ((vref (c1form-arg 0 form)) - (form1 (c1form-arg 1 form))) - (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 'VARIABLE form vref nil) rest-forms)))) - -(defun emit-inlined-call-global (form expected-type) - (let* ((fname (c1form-arg 0 form)) - (args (c1form-arg 1 form)) - (return-type (c1form-primary-type form)) - (fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p)) - (loc (call-global-loc fname fun args return-type expected-type)) - (type (type-and return-type (loc-type loc))) - (temp (make-inline-temp-var type (loc-representation-type loc)))) - (set-loc temp loc) - (list type temp))) - -(defun emit-inlined-progn (form forms) - (let ((args (c1form-arg 0 form))) - (loop with *destination* = 'TRASH - while (rest args) - do (c2expr* (pop args))) - (emit-inline-form (first args) forms))) - -(defun emit-inlined-values (form forms) - (let ((args (c1form-arg 0 form))) - (prog1 (emit-inline-form (or (pop args) (c1nil)) - ;; the rest of the values args need to be - ;; added to the rest forms to execute side - ;; effects in the correct order - (append args forms)) - (loop with *destination* = 'TRASH - for form in args - do (c2expr* form))))) - -(defun emit-inlined-structure-ref (form rest-forms) - (let ((type (c1form-primary-type form))) - (if (some #'c1form-side-effects rest-forms) - (let* ((temp (make-inline-temp-var type :object)) - (*destination* temp)) - (c2expr* form) - (list type temp)) - (list type - (list 'si:STRUCTURE-REF - (first (coerce-locs - (inline-args (list (c1form-arg 0 form))))) - (c1form-arg 1 form) - (c1form-arg 2 form) - (c1form-arg 3 form)))))) - -(defun emit-inlined-instance-ref (form rest-forms) - (let ((type (c1form-primary-type form))) - (if (some #'c1form-side-effects rest-forms) - (let* ((temp (make-inline-temp-var type :object)) - (*destination* temp)) - (c2expr* form) - (list type temp)) - (list type - (list 'si:instance-ref - (first (coerce-locs - (inline-args (list (c1form-arg 0 form))))) - (c1form-arg 1 form) - #+nil (c1form-arg 2 form)))))) - -(defun emit-inline-form (form forms) - (with-c1form-env (form form) - (case (c1form-name form) - (LOCATION - (list (c1form-primary-type form) (c1form-arg 0 form))) - (VARIABLE - (emit-inlined-variable form forms)) - (CALL-GLOBAL - (emit-inlined-call-global form (c1form-primary-type form))) - (si:STRUCTURE-REF - (emit-inlined-structure-ref form forms)) - #+clos - (si:INSTANCE-REF - (emit-inlined-instance-ref form forms)) - (SETQ - (emit-inlined-setq form forms)) - (PROGN - (emit-inlined-progn form forms)) - (VALUES - (emit-inlined-values form forms)) - (t (let* ((type (c1form-primary-type form)) - (temp (make-inline-temp-var type))) - (let ((*destination* temp)) (c2expr* form)) - (list type temp)))))) - -;;; -;;; inline-args: -;;; returns a list of pairs (type loc) -;;; side effects: emits code for temporary variables -;;; -;;; Whoever calls inline-args must bind *inline-blocks* to 0 and afterwards -;;; call close-inline-blocks -;;; -(defun inline-args (forms) - (loop for form-list on forms - 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))) - -(defun open-inline-block () - (wt-nl-open-brace) - (incf *inline-blocks*)) - -(defun close-inline-blocks () - (loop for i of-type fixnum from 0 below *inline-blocks* - do (wt-nl-close-brace))) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp index d5620b9a5..fbcb8d7b7 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp @@ -93,48 +93,44 @@ (produce-inline-loc (list arg1) '(:object :object) '(:object) consing nil t)))) -(define-c-inliner + (return-type &rest arguments &aux arg1 arg2) - (when (null arguments) - (return (make-vv :rep-type :fixnum :value 0))) - (setf arg1 (pop arguments)) - (when (null arguments) - (return (inlined-arg-loc arg1))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) - -(define-c-inliner - (return-type arg1 &rest arguments &aux arg2) - (when (null arguments) - (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)"))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) - (define-c-inliner * (return-type &rest arguments &aux arg1 arg2) (when (null arguments) (return (make-vv :rep-type :fixnum :value 1))) (setf arg1 (pop arguments)) (when (null arguments) (return (inlined-arg-loc arg1))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) + (setf arg2 (pop arguments)) + (when (null arguments) + (return (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*))) + (cmperr "The C inliner for (FUNCTION *) expected at most 2 arguments.")) + +(define-c-inliner + (return-type &rest arguments &aux arg1 arg2) + (when (null arguments) + (return (make-vv :rep-type :fixnum :value 0))) + (setf arg1 (pop arguments)) + (when (null arguments) + (return (inlined-arg-loc arg1))) + (setf arg2 (pop arguments)) + (when (null arguments) + (return (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+))) + (cmperr "The C inliner for (FUNCTION +) expected at most 2 arguments.")) + +(define-c-inliner - (return-type arg1 &rest arguments &aux arg2) + (when (null arguments) + (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)"))) + (setf arg2 (pop arguments)) + (when (null arguments) + (return (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-))) + (cmperr "The C inliner for (FUNCTION -) expected at most 2 arguments.")) (define-c-inliner / (return-type arg1 &rest arguments &aux arg2) (when (null arguments) (return (inline-arith-unop return-type arg1 "ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)"))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) + (setf arg2 (pop arguments)) + (when (null arguments) + (return (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/))) + (cmperr "The C inliner for (FUNCTION /) expected at most 2 arguments.")) (define-c-inliner float (return-type arg &optional float) (let ((arg-c-type (lisp-type->rep-type (inlined-arg-type arg))) diff --git a/src/cmp/cmpbackend-cxx/cmpc-util.lsp b/src/cmp/cmpbackend-cxx/cmpc-util.lsp index f49e7c17d..b1a1b3c4b 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 }* @@ -85,13 +108,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 +124,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)) @@ -147,11 +189,19 @@ (let ((code (incf *next-cfun*))) (format nil prefix code (lisp-to-c-name lisp-name)))) -(defmacro with-lexical-scope (() &body body) - `(progn - (wt-nl-open-brace) +;;; The macro WITH-INLINE-BLOCKS is used by callers who may optionally need to +;;; introduce inner lexical scope to create variables. Most notably it is used +;;; for temporary variables that are bound to local evaluation results. +(defmacro with-inline-blocks (() &body body) + `(let ((*inline-blocks* 0) + (*temp* *temp*)) ,@body - (wt-nl-close-brace))) + (close-inline-blocks))) + +(defmacro with-lexical-scope (() &body body) + `(with-inline-blocks () + (open-inline-block) + ,@body)) ;;; *LAST-LABEL* holds the label# of the last used label. This is used by the diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp index dc0238668..6bbf24de9 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp @@ -9,22 +9,6 @@ (in-package #:compiler) -;;; Functions that use MAYBE-SAVE-VALUE should rebind *TEMP*. -(defun maybe-save-value (value &optional (other-forms nil other-forms-flag)) - (declare (si::c-local)) - (let ((name (c1form-name value))) - (cond ((eq name 'LOCATION) - (c1form-arg 0 value)) - ((and (eq name 'VARIABLE) - other-forms-flag - (not (var-changed-in-form-list (c1form-arg 0 value) other-forms))) - (c1form-arg 0 value)) - (t - (let* ((temp (make-temp-var)) - (*destination* temp)) - (c2expr* value) - temp))))) - ;;; FIXME functions declared as SI::C-LOCAL can't be called from the stack ;;; because they are not installed in the environment. That means that if we ;;; have such function and call it with too many arguments it will be @@ -33,37 +17,82 @@ ;;; ;;; c2fcall: ;;; -;;; FUN the function to be called -;;; ARGS is the list of arguments +;;; FUN: the function to be called +;;; ARGS: the list of arguments ;;; FUN-VAL depends on the particular call type -;;; CALL-TYPE is (member :LOCAL :GLOBAL :UKNOWN) +;;; :LOCAL structure FUN [see cmprefs.lsp] +;;; :GLOBAL function name [symbol or (SETF symbol)] +;;; :UNKNOWN the value NIL +;;; CALL-TYPE: (member :LOCAL :GLOBAL :UKNOWN) ;;; (defun c2fcall (c1form fun args fun-val call-type) (if (> (length args) si:c-arguments-limit) (c2call-stack c1form fun args nil) - (ecase call-type - (:local (c2call-local c1form fun-val args)) - (:global (c2call-global c1form fun-val args)) - (:unknown (c2call-unknown c1form fun args))))) + (with-inline-blocks () + (ecase call-type + (:local (c2call-local c1form fun-val args)) + (:global (c2call-global c1form fun-val args)) + (:unknown (c2call-unknown c1form fun args)))))) (defun c2mcall (c1form form args fun-val call-type) + (declare (ignore fun-val call-type)) (c2call-stack c1form form args t)) +;;; +;;; c2call-stack: +;;; +;;; This is the most generic way of calling functions. First we push them on +;;; the stack, and then we apply from the stack frame. Other variants call +;;; inline-args and put results directly in the function call. +;;; +(defun c2call-stack (c1form form args values-p) + (declare (ignore c1form)) + (with-stack-frame (frame) + (let ((loc (inlined-arg-loc (inline-arg0 form args)))) + (let ((*destination* (if values-p 'VALUEZ 'LEAVE))) + (dolist (arg args) + (c2expr* arg) + (if values-p + (wt-nl "ecl_stack_frame_push_values(" frame ");") + (wt-nl "ecl_stack_frame_push(" frame ",value0);")))) + (unwind-exit (call-stack-loc nil loc))))) + ;;; ;;; c2call-global: ;;; -;;; ARGS is the list of arguments -;;; LOC is either NIL or the location of the function object +;;; LOC: the location of the function object or NIL +;;; ARGS: the list of arguments ;;; (defun c2call-global (c1form fname args) (let ((fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p))) (when (and fun (c2try-tail-recursive-call fun args)) (return-from c2call-global)) - (let* ((*inline-blocks* 0) - (*temp* *temp*)) - (unwind-exit (call-global-loc fname fun args (c1form-primary-type c1form) - (loc-type *destination*))) - (close-inline-blocks)))) + (unwind-exit (call-global-loc fname fun + (inline-args args) + (type-and (c1form-primary-type c1form) + (loc-type *destination*)))))) + +;;; +;;; c2call-local: +;;; +;;; FUN: the function object +;;; ARGS: the list of arguments +;;; +(defun c2call-local (c1form fun args) + (declare (type fun fun)) + (unless (c2try-tail-recursive-call fun args) + (unwind-exit (call-loc (fun-name fun) fun + (inline-args args) + (c1form-primary-type c1form))))) + +(defun c2call-unknown (c1form form args) + (declare (ignore c1form)) + (let* ((form-type (c1form-primary-type form)) + (function-p (and (subtypep form-type 'function) + (policy-assume-right-type))) + (loc (inlined-arg-loc (inline-arg0 form args))) + (args (inline-args args))) + (unwind-exit (call-unknown-global-loc loc args function-p)))) ;;; Tail-recursion optimization for a function F is possible only if ;;; 1. F receives only required parameters, and @@ -89,13 +118,10 @@ ((or (consp ue) (labelp ue) (eq ue 'IHS-ENV))) (t (baboon :format-control "tail-recursion-possible: unexpected situation."))))) -(defun last-call-p () - (eq *exit* 'LEAVE)) - (defun c2try-tail-recursive-call (fun args) (when (and *tail-recursion-info* (eq fun (first *tail-recursion-info*)) - (last-call-p) + (eq *exit* 'LEAVE) (tail-recursion-possible) (inline-possible (fun-name fun)) (= (length args) (length (rest *tail-recursion-info*)))) @@ -107,88 +133,71 @@ (cmpdebug "Tail-recursive call of ~s was replaced by iteration." (fun-name fun)) t)) -(defun c2call-local (c1form fun args) - (declare (type fun fun)) - (unless (c2try-tail-recursive-call fun args) - (let ((*inline-blocks* 0) - (*temp* *temp*)) - (unwind-exit (call-loc (fun-name fun) fun (inline-args args) - (c1form-primary-type c1form))) - (close-inline-blocks)))) - -(defun c2call-unknown (c1form form args) - (declare (ignore c1form)) - (let* ((*inline-blocks* 0) - (*temp* *temp*) - (form-type (c1form-primary-type form)) - (function-p (and (subtypep form-type 'function) - (policy-assume-right-type))) - (loc (maybe-save-value form args))) - (unwind-exit (call-unknown-global-loc loc (inline-args args) function-p)) - (close-inline-blocks))) - -(defun c2call-stack (c1form form args values-p) - (declare (ignore c1form)) - (let* ((*temp* *temp*) - (loc (maybe-save-value form args))) - (with-stack-frame (frame) - (let ((*destination* (if values-p 'VALUEZ 'LEAVE))) - (dolist (arg args) - (c2expr* arg) - (if values-p - (wt-nl "ecl_stack_frame_push_values(" frame ");") - (wt-nl "ecl_stack_frame_push(" frame ",value0);")))) - (unwind-exit (call-stack-loc nil loc))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; CALL LOCATIONS ;;; + +;;; +;;; call-stack-loc +;;; +;;; FNAME: the name of the function or NIL +;;; LOC: the location containing function +;;; +(defun call-stack-loc (fname loc) + `(CALL-STACK ,loc ,fname)) + +;;; +;;; call-loc +;;; +;;; FNAME: the name of the function +;;; FUN: a function object +;;; ARGS: a list of INLINED-ARGs +;;; TYPE: the type to which the output is coerced +;;; +(defun call-loc (fname fun args type) + (declare (ignore fname)) + `(CALL-NORMAL ,fun ,(coerce-locs args) ,type)) + ;;; ;;; call-global: ;;; FNAME: the name of the function -;;; LOC: either a function object or NIL +;;; FUN: either a function object or NIL ;;; ARGS: a list of typed locs with arguments -;;; RETURN-TYPE: the type to which the output is coerced +;;; TYPE: the type to which the output is coerced ;;; -(defun call-global-loc (fname fun args return-type expected-type) - ;; Check whether it is a global function that we cannot call directly. - (when (and (or (null fun) (fun-global fun)) (not (inline-possible fname))) - (return-from call-global-loc - (call-unknown-global-fun fname (inline-args args)))) +(defun call-global-loc (fname fun args type) - (setf args (inline-args args)) + ;; Check whether it is a global function that we cannot call directly. + (when (not (inline-possible fname)) + (return-from call-global-loc + (call-unknown-global-fun fname args))) ;; Try with a function that has a C-INLINE expansion - (let ((inline-loc (apply-inliner fname - (type-and return-type expected-type) - args))) - (when inline-loc - (return-from call-global-loc inline-loc))) + (ext:when-let ((inline-loc (apply-inliner fname type args))) + (return-from call-global-loc inline-loc)) - ;; Call to a function defined in the same file. Direct calls are - ;; only emitted for low or neutral values of DEBUG is >= 2. - (when (and (policy-use-direct-C-call) - (or (fun-p fun) - (and (null fun) - (setf fun (find fname *global-funs* :test #'same-fname-p - :key #'fun-name))))) - (return-from call-global-loc (call-loc fname fun args return-type))) + ;; Call to a function defined in the same file. Direct calls are only emitted + ;; for low or neutral values of DEBUG, that is DEBUG < 2. + (when (and fun (policy-use-direct-C-call)) + (return-from call-global-loc + (call-loc fname fun args type))) ;; Call to a global (SETF ...) function (when (not (symbolp fname)) (return-from call-global-loc (call-unknown-global-fun fname args))) - ;; Call to a function whose C language function name is known, - ;; either because it has been proclaimed so, or because it belongs - ;; to the runtime. + ;; Call to a function whose C language function name is known because it + ;; belongs to the runtime. (multiple-value-bind (found fd minarg maxarg) (si:mangle-name fname t) (when found (return-from call-global-loc - (call-exported-function-loc fname args fd minarg maxarg t return-type)))) + (call-exported-function-loc fname args fd minarg maxarg t type)))) + ;; Call to a function whose C language function name is known because it has + ;; been proclaimed so. (when (policy-use-direct-C-call) (ext:when-let ((fd (si:get-sysprop fname 'Lfun))) (multiple-value-bind (minarg maxarg found) (get-proclaimed-narg fname) @@ -202,20 +211,16 @@ (multiple-value-setq (found ignored minarg maxarg) (si:mangle-name fname))) (unless found - (cmperr "Can not call the function ~A using its exported C name ~A because its function type has not been proclaimed." + (cmperr "Can not call the function ~A using its exported C name ~A ~ + because its function type has not been proclaimed." fname fd))) (return-from call-global-loc (call-exported-function-loc fname args fd minarg maxarg - (si:mangle-name fname) return-type))))) + (si:mangle-name fname) type))))) (call-unknown-global-fun fname args)) -(defun call-loc (fname fun args type) - (declare (ignore fname)) - `(CALL-NORMAL ,fun ,(coerce-locs args) ,type)) - -(defun call-exported-function-loc (fname args fun-c-name minarg maxarg in-core - return-type) +(defun call-exported-function-loc (fname args fun-c-name minarg maxarg in-core type) (unless in-core ;; We only write declarations for functions which are not in lisp_external.h (multiple-value-bind (val declared) @@ -237,20 +242,23 @@ (setf (gethash fun-c-name *compiler-declared-globals*) 1)))) (let ((fun (make-fun :name fname :global t :cfun fun-c-name :lambda 'NIL :minarg minarg :maxarg maxarg))) - (call-loc fname fun args return-type))) + (call-loc fname fun args type))) ;;; ;;; call-unknown-global-loc -;;; LOC is NIL or location containing function -;;; ARGS is the list of typed locations for arguments ;;; -(defun call-unknown-global-loc (loc args &optional function-p) +;;; LOC: the location containing the function or NIL +;;; ARGS: a list of INLINED-ARGs +;;; FUNCTION-P: true when we can assume that LOC is the function +;;; +(defun call-unknown-global-loc (loc args function-p) `(CALL-INDIRECT ,loc ,(coerce-locs args) nil ,function-p)) ;;; ;;; call-unknown-global-fun -;;; FNAME is the name of the global function -;;; ARGS is the list of typed locations for arguments +;;; +;;; FNAME: the name of the global function +;;; ARGS: a list of INLINED-ARGs ;;; (defun call-unknown-global-fun (fname args) `(CALL-INDIRECT (FDEFINITION ,fname) ,(coerce-locs args) ,fname t)) @@ -260,11 +268,3 @@ ;;; ecl_function_dispatch. wt-fdefinition handles all proper names. (defun call-unknown-global-fun (fname args) `(CALL-INDIRECT ,(get-object fname) ,(coerce-locs args) ,fname nil)) - -;;; -;;; call-stack-loc -;;; LOC is NIL or location containing function -;;; ARGS is the list of typed locations for arguments -;;; -(defun call-stack-loc (fname loc) - `(CALL-STACK ,loc ,fname)) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp index ecde25397..22ad17d0c 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)))) @@ -55,39 +54,39 @@ (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))) - (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)))) - (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) + (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))))) (defun c2tagbody-body (body) ;;; INV: BODY is a list of tags and forms. We have processed the body @@ -105,20 +104,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..097f184b0 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp @@ -76,22 +76,6 @@ (declare (si::c-local)) (and (consp dest) (eq (si:cons-car dest) 'JUMP-FALSE))) -(defun negate-argument (inlined-arg dest-loc) - (declare (si::c-local)) - (let* ((loc (second inlined-arg)) - (rep-type (loc-representation-type loc))) - (apply #'produce-inline-loc - (list inlined-arg) - (if (eq (loc-representation-type dest-loc) :bool) - (case rep-type - (:bool '((:bool) (:bool) "(#0)==ECL_NIL" nil t)) - (:object '((:object) (:bool) "(#0)!=ECL_NIL" nil t)) - (otherwise (return-from negate-argument nil))) - (case rep-type - (:bool '((:bool) (:object) "(#0)?ECL_NIL:ECL_T" nil t)) - (:object '((:object) (:object) "Null(#0)?ECL_T:ECL_NIL" nil t)) - (otherwise (return-from negate-argument *vv-nil*))))))) - (defun c2fmla-not (c1form arg) (declare (ignore c1form)) (let ((dest *destination*)) @@ -102,10 +86,8 @@ (let ((*destination* `(JUMP-TRUE ,@(cdr dest)))) (c2expr arg))) (t - (let ((*inline-blocks* 0) - (*temp* *temp*)) - (unwind-exit (negate-argument (emit-inline-form arg nil) dest)) - (close-inline-blocks)))))) + (with-inline-blocks () + (unwind-exit (negate-argument arg dest))))))) (defun c2fmla-and (c1form butlast last) (declare (ignore c1form)) @@ -137,8 +119,7 @@ (dolist (f butlast) (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 :jump-t 'VALUE0)) (c2expr last)) (unwind-exit 'VALUE0))))) @@ -156,51 +137,50 @@ (defun c2values (c1form forms) (declare (ignore c1form)) (cond - ;; When the values are not going to be used, then just - ;; process each form separately. - ((eq *destination* 'TRASH) - (mapc #'c2expr* forms) - ;; We really pass no value, but we need UNWIND-EXIT to trigger all the - ;; frame-pop and all other exit forms. - (unwind-exit 'VALUE0)) - ;; For (VALUES) we can replace the output with either NIL (if the value is - ;; actually used) and set only NVALUES when the value is the output of a - ;; function. - ((endp forms) - (cond ((eq *destination* 'LEAVE) - (wt-nl "value0 = ECL_NIL;") - (wt-nl "cl_env_copy->nvalues = 0;") - (unwind-exit 'LEAVE)) - ((eq *destination* 'VALUEZ) - (wt-nl "cl_env_copy->values[0] = ECL_NIL;") - (wt-nl "cl_env_copy->nvalues = 0;") - (unwind-exit 'VALUEZ)) - (t - (unwind-exit *vv-nil*)))) - ;; For a single form, we must simply ensure that we only take a single - ;; value of those that the function may output. - ((endp (rest forms)) - (let ((form (first forms))) - (if (or (not (member *destination* '(LEAVE VALUEZ))) - (c1form-single-valued-p form)) - (c2expr form) - (progn - (let ((*destination* 'VALUE0)) (c2expr* form)) - (unwind-exit 'VALUE0))))) - ;; In all other cases, we store the values in the VALUES vector, - ;; and force the compiler to retrieve anything out of it. - (t - (let* ((nv (length forms)) - (*inline-blocks* 0) - (*temp* *temp*) - (forms (nreverse (coerce-locs (inline-args forms))))) - ;; By inlining arguments we make sure that VL has no call to funct. - ;; Reverse args to avoid clobbering VALUES(0) - (wt-nl "cl_env_copy->nvalues = " nv ";") - (do ((vl forms (rest vl)) - (i (1- (length forms)) (1- i))) - ((null vl)) - (declare (fixnum i)) - (wt-nl "cl_env_copy->values[" i "] = " (first vl) ";")) - (unwind-exit 'VALUEZ) - (close-inline-blocks))))) + ;; When the values are not going to be used, then just process each form + ;; separately. + ((eq *destination* 'TRASH) + (mapc #'c2expr* forms) + ;; We really pass no value, but we need UNWIND-EXIT to trigger all the + ;; frame-pop and all other exit forms. + (unwind-exit 'VALUE0)) + ;; For (VALUES) we can replace the output with either NIL (if the value is + ;; actually used) and set only NVALUES when the value is the output of a + ;; function. + ((endp forms) + (case *destination* + (VALUEZ + (wt-nl "cl_env_copy->values[0] = ECL_NIL;") + (wt-nl "cl_env_copy->nvalues = 0;") + (unwind-exit 'VALUEZ)) + (LEAVE + (wt-nl "value0 = ECL_NIL;") + (wt-nl "cl_env_copy->nvalues = 0;") + (unwind-exit 'LEAVE)) + (otherwise (unwind-exit *vv-nil*)))) + ;; For a single form, we must simply ensure that we only take a single + ;; value of those that the function may output. + ((endp (rest forms)) + (let ((form (first forms))) + (if (or (not (member *destination* '(LEAVE VALUEZ))) + (c1form-single-valued-p form)) + (c2expr form) + (progn + (let ((*destination* 'VALUE0)) + (c2expr* form)) + (unwind-exit 'VALUE0))))) + ;; In all other cases, we store the values in the VALUES vector, + ;; and force the compiler to retrieve anything out of it. + (t + (with-inline-blocks () + (let* ((nv (length forms)) + (forms (nreverse (coerce-locs (inline-args forms))))) + ;; By inlining arguments we make sure that VL has no call to funct. + ;; Reverse args to avoid clobbering VALUES(0) + (wt-nl "cl_env_copy->nvalues = " nv ";") + (do ((vl forms (rest vl)) + (i (1- (length forms)) (1- i))) + ((null vl)) + (declare (fixnum i)) + (wt-nl "cl_env_copy->values[" i "] = " (first vl) ";")) + (unwind-exit 'VALUEZ)))))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp index 041785fad..e3957d497 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") @@ -33,10 +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)) - (perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p) - (wt-nl-go exit))) + (%unwind (label-denv exit) *unwind-exit*) + (%goto exit)) + +(defun unwind-cont (exit) + (%unwind (label-denv exit) *unwind-exit*) + (%goto exit)) + +(defun unwind-flee (exit kind) + (%escape exit kind)) + +(defun unwind-cond (exit kind &rest args) + (%branch exit *unwind-exit* kind args)) ;;; @@ -48,9 +58,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." @@ -73,26 +83,10 @@ ;;; LEAVE -> outermost location ;;; #