mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-04-22 01:30:45 -07:00
cmp: inl: move code around in the cxx backend inliners
After understanding better the code I've moved argument inlining and function inlining close to each other, also negate-argument clearly belongs in there too. INLINED-ARG is now a structure (not a naked list) - that helps with understanding abstractions better.
This commit is contained in:
Daniel Kochmański
parent
48c39c8083
commit
c6955e41c5
4 changed files with 117 additions and 108 deletions
|
|
@ -1,17 +1,77 @@
|
|||
;;;; -*- 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
|
||||
;;;; Copyright (c) 2023, Daniel Kochmański
|
||||
;;;;
|
||||
;;;; See the file 'LICENSE' for the copyright details.
|
||||
;;;;
|
||||
|
||||
;;;; Open coding optimizer.
|
||||
;;;; 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)
|
||||
|
|
@ -30,12 +90,12 @@
|
|||
|
||||
(defun emit-inlined-variable (form rest-forms)
|
||||
(let ((var (c1form-arg 0 form))
|
||||
(value-type (c1form-primary-type form)))
|
||||
(lisp-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))))
|
||||
(let ((temp (make-inline-temp-var lisp-type (var-rep-type var))))
|
||||
(set-loc temp var)
|
||||
(list value-type temp))
|
||||
(list value-type 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))
|
||||
|
|
@ -43,7 +103,7 @@
|
|||
(let ((*destination* vref))
|
||||
(c2expr* form1))
|
||||
(if (eq (c1form-name form1) 'LOCATION)
|
||||
(list (c1form-primary-type form1) (c1form-arg 0 form1))
|
||||
(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)
|
||||
|
|
@ -55,7 +115,7 @@
|
|||
(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)))
|
||||
(make-inlined-arg temp type)))
|
||||
|
||||
(defun emit-inlined-progn (form forms)
|
||||
(let ((args (c1form-arg 0 form)))
|
||||
|
|
@ -81,14 +141,14 @@
|
|||
(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))))))
|
||||
(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)))
|
||||
|
|
@ -96,26 +156,25 @@
|
|||
(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))))))
|
||||
(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
|
||||
(list (c1form-primary-type form) (c1form-arg 0 form)))
|
||||
(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))
|
||||
#+clos
|
||||
(SI:INSTANCE-REF
|
||||
(emit-inlined-instance-ref form forms))
|
||||
(SETQ
|
||||
|
|
@ -128,15 +187,15 @@
|
|||
(temp (make-inline-temp-var type))
|
||||
(*destination* temp))
|
||||
(c2expr* form)
|
||||
(list type temp))))))
|
||||
(make-inlined-arg temp type))))))
|
||||
|
||||
;;;
|
||||
;;; 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.
|
||||
;;; Whoever calls this function must bind *INLINE-BLOCKS* to 0 and afterwards
|
||||
;;; call CLOSE-INLINE-BLOCKS.
|
||||
;;;
|
||||
(defun inline-args (forms)
|
||||
(loop for form-list on forms
|
||||
|
|
@ -148,19 +207,8 @@
|
|||
;;; returns a location that contains the function
|
||||
;;; side effects: emits code for a temporary variable
|
||||
;;;
|
||||
;;; Whoever calls inline-arg0 must rebind *TEMP*.
|
||||
;;; Whoever calls this function must bind *INLINE-BLOCKS* to 0 and afterwards
|
||||
;;; call CLOSE-INLINE-BLOCKS, and must rebind *TEMP*.
|
||||
;;;
|
||||
(defun inline-arg0 (value-form other-forms)
|
||||
(emit-inline-form value-form other-forms))
|
||||
|
||||
(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)))
|
||||
|
|
@ -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,19 @@
|
|||
(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 bind *INLINE-BLOCKS* to 0 and afterwards
|
||||
;;; call CLOSE-INLINE-BLOCKS, and must rebind *TEMP*.
|
||||
(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*)))))))
|
||||
|
|
@ -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*))
|
||||
|
|
@ -104,7 +88,7 @@
|
|||
(t
|
||||
(let ((*inline-blocks* 0)
|
||||
(*temp* *temp*))
|
||||
(unwind-exit (negate-argument (emit-inline-form arg nil) dest))
|
||||
(unwind-exit (negate-argument arg dest))
|
||||
(close-inline-blocks))))))
|
||||
|
||||
(defun c2fmla-and (c1form butlast last)
|
||||
|
|
|
|||
|
|
@ -48,11 +48,11 @@
|
|||
"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-inliner.lsp"
|
||||
"src:cmp;cmpbackend-cxx;cmpc-arg-inl.lsp"
|
||||
"src:cmp;cmpbackend-cxx;cmpc-fun-inl.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"
|
||||
"src:cmp;cmpbackend-cxx;cmpc-opt-printer.lsp"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue