mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-11 19:53:52 -08:00
Code Issues Projects Releases Packages Wiki Activity

Changed the way INLINE-ARGUMENTS works: temporary variables are now created based on the representation type of the inlined value, not on its expected types. Furthermore, expected types are no longer an argument to INLINE-ARGUMENTS.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2010-05-27 23:49:47 +02:00
parent 164605aa72
commit 1ca77df9bc
6 changed files with 207 additions and 173 deletions
Download patch file Download diff file Expand all files Collapse all files

167
src/cmp/cmpc-inliner.lsp Normal file
View file

@ -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))))

14
src/cmp/cmpcall.lsp
View file

@ -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.

2
src/cmp/cmpif.lsp
View file

@ -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))))))

192
src/cmp/cmpinline.lsp
View file

@ -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 "{")

2
src/cmp/cmptables.lsp
View file

@ -238,3 +238,5 @@
(defparameter *p0-dispatch-table* (make-dispatch-table '())
"Type propagators for known functions.")
(defparameter *cinline-dispatch-table* (make-dispatch-table '()))

3
src/cmp/load.lsp.in
View file

@ -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"