diff --git a/src/cmp/cmpc-inliner.lsp b/src/cmp/cmpc-inliner.lsp new file mode 100644 index 000000000..1aa81f0d8 --- /dev/null +++ b/src/cmp/cmpc-inliner.lsp @@ -0,0 +1,167 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. +;;;; +;;;; CMPC-INLINER -- Open coding functions as C expressions +;;;; + +(in-package "COMPILER") + +(defmacro define-c-inliner (fname lambda-list &body body) + `(setf (gethash fname *cinline-dispatch-table*) + #'(ext:lambda-block ,fname ,lambda-list ,@body))) + +(defun apply-inliner (fname return-type inlined-args) + (let ((fd (gethash fname *cinline-dispatch-table*))) + (if fd + (apply fd 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)) + (ii (inline-function fname arg-types return-type))) + (and ii (apply-inline-info ii inlined-args)))) + +;;; +;;; inline-function: +;;; locs are typed locs as produced by inline-args +;;; 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*. + (and (inline-possible fname) + (not (gethash fname *c2-dispatch-table*)) + (let* ((dest-rep-type (loc-representation-type *destination*)) + (dest-type (rep-type->lisp-type dest-rep-type)) + (ii (get-inline-info fname arg-types return-type return-rep-type))) + ii))) + +(defun apply-inline-info (ii inlined-locs) + (let* ((arg-types (inline-info-arg-types ii)) + (out-rep-type (inline-info-return-rep-type ii)) + (out-type (inline-info-return-type ii)) + (side-effects-p (function-may-have-side-effects (inline-info-name ii))) + (fun (inline-info-expansion ii)) + (one-liner (inline-info-one-liner ii))) + (produce-inline-loc inlined-locs arg-types (list out-rep-type) + fun side-effects-p one-liner))) + +(defun choose-inline-info (ia ib return-type return-rep-type) + (cond + ;; Only accept inliners that have the right rep type + ((not (or (eq return-rep-type 'any) + (eq return-rep-type :void) + (let ((info-type (inline-info-return-rep-type ib))) + (or (eq return-rep-type info-type) + ;; :bool can be coerced to any other location type + (eq info-type :bool))))) + ia) + ((null ia) + ib) + ;; Keep the first one, which is typically the least safe but fastest. + ((equal (inline-info-arg-types ia) (inline-info-arg-types ib)) + ia) + ;; More specific? + ((every #'type>= (inline-info-arg-types ia) (inline-info-arg-types ib)) + ib) + ;; Keep the first one, which is typically the least safe but fastest. + (t + ia))) + +(defun get-inline-info (fname types return-type return-rep-type) + (declare (si::c-local)) + (let ((output nil)) + (unless (safe-compile) + (dolist (x (get-sysprop fname ':INLINE-UNSAFE)) + (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 (get-sysprop 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 (get-sysprop fname ':INLINE-ALWAYS)) + (let ((other (inline-type-matches x types return-type))) + (when other + (setf output (choose-inline-info output other return-type return-rep-type))))) + output)) + +(defun to-fixnum-float-type (type) + (dolist (i '(FIXNUM DOUBLE-FLOAT SINGLE-FLOAT + #+short-float SHORT-FLOAT #+long-float LONG-FLOAT) + nil) + (when (type>= i type) + (return i)))) + +(defun maximum-float-type (t1 t2) + (cond ((null t1) + t2) + #+long-float + ((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) + #+short-float + ((or (eq t1 'SHORT-FLOAT) (eq t2 'SHORT-FLOAT)) + 'SHORT-FLOAT) + (T + 'FIXNUM))) + +(defun inline-type-matches (inline-info arg-types return-type) + (let* ((rts nil) + (number-max nil)) + ;; + ;; Check that the argument types match those of the inline expression + ;; + (do* ((arg-types arg-types (cdr arg-types)) + (types (inline-info-arg-types inline-info) (cdr types))) + ((or (endp arg-types) (endp types)) + (when (or arg-types types) + (return-from inline-type-matches nil))) + (let* ((arg-type (first arg-types)) + (type (first types))) + (cond ((eq type 'FIXNUM-FLOAT) + (let ((new-type (to-fixnum-float-type arg-type))) + (unless new-type + (return-from inline-type-matches nil)) + (push new-type rts) + (setq number-max (maximum-float-type number-max new-type)))) + ((type>= type arg-type) + (push type rts)) + (t (return-from inline-type-matches nil))))) + ;; + ;; Now there is an optional check of the return type. This check is + ;; only used when enforced by the inliner. + ;; + (when (or (eq (inline-info-return-rep-type inline-info) :bool) + (null (inline-info-exact-return-type inline-info)) + (let ((inline-return-type (inline-info-return-type inline-info))) + (if number-max + ;; for arithmetic operators we take the maximal + ;; type as possible result type. Note that FIXNUM + ;; is not an option, because the product, addition + ;; or difference of fixnums may be a larger + ;; integer. + (and (setf number-max (if (eq number-max 'fixnum) + 'integer + number-max)) + (type>= inline-return-type number-max) + (type>= number-max return-type)) + ;; no contravariance + (type>= inline-return-type return-type)))) + (let ((inline-info (copy-structure inline-info))) + (setf (inline-info-arg-types inline-info) + (nreverse rts)) + inline-info)))) + diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index a2386d9c6..18299446e 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -110,12 +110,14 @@ (return-from call-global-loc (call-unknown-global-loc fname nil (inline-args args)))) - ;; Open-codable function. - (let* ((arg-types (mapcar #'c1form-primary-type args)) - (ii (inline-function fname arg-types (type-and return-type expected-type)))) - (setf args (inline-args args (and ii (inline-info-arg-types ii)))) - (when ii - (return-from call-global-loc (apply-inline-info ii args)))) + (setf args (inline-args 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))) ;; Call to a function defined in the same file. Direct calls are ;; only emitted for low or neutral values of DEBUG is >= 2. diff --git a/src/cmp/cmpif.lsp b/src/cmp/cmpif.lsp index 831500fbd..88ec6c2fd 100644 --- a/src/cmp/cmpif.lsp +++ b/src/cmp/cmpif.lsp @@ -118,7 +118,7 @@ (let ((*inline-blocks* 0) (*temp* *temp*)) (unwind-exit (negate-argument - (emit-inline-form arg t nil) + (emit-inline-form arg nil) *destination*)) (close-inline-blocks)))))) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index 6fd155a4a..f3f7a9f70 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -31,33 +31,32 @@ ;;; 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 (expected-type value-type &optional rep-type) - (let ((out-rep-type (or rep-type (lisp-type->rep-type expected-type)))) +(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 (type-and expected-type value-type)))) + :type value-type))) (wt-nl "{" (rep-type-name out-rep-type) " " var ";") (incf *inline-blocks*) var)))) -(defun emit-inlined-variable (form expected-type rest-forms) +(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 expected-type value-type - (var-rep-type var)))) + (let* ((temp (make-inline-temp-var value-type (var-rep-type var)))) (let ((*destination* temp)) (set-loc var)) (list value-type temp)) (list value-type var)))) -(defun emit-inlined-setq (form expected-type rest-forms) +(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 'VAR form vref) expected-type rest-forms)))) + (emit-inlined-variable (make-c1form 'VAR form vref) rest-forms)))) (defun emit-inlined-call-global (form expected-type) (let* ((fname (c1form-arg 0 form)) @@ -66,30 +65,29 @@ (fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p)) (loc (call-global-loc fname fun args return-type expected-type)) (type (loc-type loc)) - (temp (make-inline-temp-var expected-type type - (loc-representation-type loc))) + (temp (make-inline-temp-var type (loc-representation-type loc))) (*destination* temp)) (set-loc loc) (list type temp))) -(defun emit-inlined-progn (form expected-type forms) +(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) expected-type forms))) + (emit-inline-form (first args) forms))) -(defun emit-inlined-values (form expected-type forms) +(defun emit-inlined-values (form forms) (let ((args (c1form-arg 0 form))) - (prog1 (emit-inline-form (pop args) expected-type forms) + (prog1 (emit-inline-form (pop args) forms) (loop with *destination* = 'TRASH for form in args do (c2expr* form))))) -(defun emit-inlined-structure-ref (form expected-type rest-forms) +(defun emit-inlined-structure-ref (form rest-forms) (let ((type (c1form-primary-type form))) (if (args-cause-side-effect rest-forms) - (let* ((temp (make-inline-temp-var expected-type type)) + (let* ((temp (make-inline-temp-var type :object)) (*destination* temp)) (c2expr* form) (list type temp)) @@ -101,10 +99,10 @@ (c1form-arg 2 form) (c1form-arg 3 form)))))) -(defun emit-inlined-instance-ref (form expected-type rest-forms) +(defun emit-inlined-instance-ref (form rest-forms) (let ((type (c1form-primary-type form))) (if (args-cause-side-effect rest-forms) - (let* ((temp (make-inline-temp-var expected-type type)) + (let* ((temp (make-inline-temp-var type :object)) (*destination* temp)) (c2expr* form) (list type temp)) @@ -115,28 +113,28 @@ (c1form-arg 1 form) #+nil (c1form-arg 2 form)))))) -(defun emit-inline-form (form expected-type forms) +(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))) (VAR - (emit-inlined-variable form expected-type forms)) + (emit-inlined-variable form forms)) (CALL-GLOBAL - (emit-inlined-call-global form expected-type)) + (emit-inlined-call-global form (c1form-primary-type form))) (SYS:STRUCTURE-REF - (emit-inlined-structure-ref form expected-type forms)) + (emit-inlined-structure-ref form forms)) #+clos (SYS:INSTANCE-REF - (emit-inlined-instance-ref form expected-type forms)) + (emit-inlined-instance-ref form forms)) (SETQ - (emit-inlined-setq form expected-type forms)) + (emit-inlined-setq form forms)) (PROGN - (emit-inlined-progn form expected-type forms)) + (emit-inlined-progn form forms)) (VALUES - (emit-inlined-values form expected-type forms)) + (emit-inlined-values form forms)) (t (let* ((type (c1form-primary-type form)) - (temp (make-inline-temp-var expected-type type))) + (temp (make-inline-temp-var type))) (let ((*destination* temp)) (c2expr* form)) (list type temp)))))) @@ -148,152 +146,16 @@ ;;; Whoever calls inline-args must bind *inline-blocks* to 0 and afterwards ;;; call close-inline-blocks ;;; -(defun inline-args (forms &optional types) +(defun inline-args (forms) (loop for form-list on forms for form = (first form-list) - for expected-type = (if types (pop types) t) - collect (emit-inline-form form expected-type (rest form-list)))) + collect (emit-inline-form form (rest form-list)))) (defun destination-type () (rep-type->lisp-type (loc-representation-type *destination*)) ;;(loc-type *destination*) ) -;;; -;;; inline-function: -;;; locs are typed locs as produced by inline-args -;;; 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*. - (and (inline-possible fname) - (not (gethash fname *c2-dispatch-table*)) - (let* ((dest-rep-type (loc-representation-type *destination*)) - (dest-type (rep-type->lisp-type dest-rep-type)) - (ii (get-inline-info fname arg-types return-type return-rep-type))) - ii))) - -(defun apply-inline-info (ii inlined-locs) - (let* ((arg-types (inline-info-arg-types ii)) - (out-rep-type (inline-info-return-rep-type ii)) - (out-type (inline-info-return-type ii)) - (side-effects-p (function-may-have-side-effects (inline-info-name ii))) - (fun (inline-info-expansion ii)) - (one-liner (inline-info-one-liner ii))) - (produce-inline-loc inlined-locs arg-types (list out-rep-type) - fun side-effects-p one-liner))) - -(defun choose-inline-info (ia ib return-type return-rep-type) - (cond - ;; Only accept inliners that have the right rep type - ((not (or (eq return-rep-type 'any) - (eq return-rep-type :void) - (let ((info-type (inline-info-return-rep-type ib))) - (or (eq return-rep-type info-type) - ;; :bool can be coerced to any other location type - (eq info-type :bool))))) - ia) - ((null ia) - ib) - ;; Keep the first one, which is typically the least safe but fastest. - ((equal (inline-info-arg-types ia) (inline-info-arg-types ib)) - ia) - ;; More specific? - ((every #'type>= (inline-info-arg-types ia) (inline-info-arg-types ib)) - ib) - ;; Keep the first one, which is typically the least safe but fastest. - (t - ia))) - -(defun get-inline-info (fname types return-type return-rep-type) - (declare (si::c-local)) - (let ((output nil)) - (unless (safe-compile) - (dolist (x (get-sysprop fname ':INLINE-UNSAFE)) - (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 (get-sysprop 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 (get-sysprop fname ':INLINE-ALWAYS)) - (let ((other (inline-type-matches x types return-type))) - (when other - (setf output (choose-inline-info output other return-type return-rep-type))))) - output)) - -(defun to-fixnum-float-type (type) - (dolist (i '(FIXNUM DOUBLE-FLOAT SINGLE-FLOAT - #+short-float SHORT-FLOAT #+long-float LONG-FLOAT) - nil) - (when (type>= i type) - (return i)))) - -(defun maximum-float-type (t1 t2) - (cond ((null t1) - t2) - #+long-float - ((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) - #+short-float - ((or (eq t1 'SHORT-FLOAT) (eq t2 'SHORT-FLOAT)) - 'SHORT-FLOAT) - (T - 'FIXNUM))) - -(defun inline-type-matches (inline-info arg-types return-type) - (let* ((rts nil) - (number-max nil)) - ;; - ;; Check that the argument types match those of the inline expression - ;; - (do* ((arg-types arg-types (cdr arg-types)) - (types (inline-info-arg-types inline-info) (cdr types))) - ((or (endp arg-types) (endp types)) - (when (or arg-types types) - (return-from inline-type-matches nil))) - (let* ((arg-type (first arg-types)) - (type (first types))) - (cond ((eq type 'FIXNUM-FLOAT) - (let ((new-type (to-fixnum-float-type arg-type))) - (unless new-type - (return-from inline-type-matches nil)) - (push new-type rts) - (setq number-max (maximum-float-type number-max new-type)))) - ((type>= type arg-type) - (push type rts)) - (t (return-from inline-type-matches nil))))) - ;; - ;; Now there is an optional check of the return type. This check is - ;; only used when enforced by the inliner. - ;; - (when (or (eq (inline-info-return-rep-type inline-info) :bool) - (null (inline-info-exact-return-type inline-info)) - (let ((inline-return-type (inline-info-return-type inline-info))) - (if number-max - ;; for arithmetic operators we take the maximal - ;; type as possible result type. Note that FIXNUM - ;; is not an option, because the product, addition - ;; or difference of fixnums may be a larger - ;; integer. - (and (setf number-max (if (eq number-max 'fixnum) - 'integer - number-max)) - (type>= inline-return-type number-max) - (type>= number-max return-type)) - ;; no contravariance - (type>= inline-return-type return-type)))) - (let ((inline-info (copy-structure inline-info))) - (setf (inline-info-arg-types inline-info) - (nreverse rts)) - inline-info)))) - (defun maybe-open-inline-block () (unless (plusp *inline-blocks*) (wt "{") diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 8826521f6..9dd174317 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -238,3 +238,5 @@ (defparameter *p0-dispatch-table* (make-dispatch-table '()) "Type propagators for known functions.") + +(defparameter *cinline-dispatch-table* (make-dispatch-table '())) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index d94b408ca..e43cac5c8 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -8,12 +8,13 @@ "src:cmp;cmpmac.lsp" "src:cmp;cmpform.lsp" "src:cmp;cmptables.lsp" - "src:cmp;cmpc-wt.lsp" "src:cmp;cmpinline.lsp" "src:cmp;cmputil.lsp" "src:cmp;cmptype-arith.lsp" "src:cmp;cmptype-prop.lsp" "src:cmp;cmptype.lsp" + "src:cmp;cmpc-wt.lsp" + "src:cmp;cmpc-inliner.lsp" "src:cmp;cmpbind.lsp" "src:cmp;cmpblock.lsp" "src:cmp;cmpcall.lsp"