mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-14 13:21:54 -08:00
Organize the code in INLINE-ARGS, factoring out parts that can be used in call-global-loc and allowing the use of temporary variables which are not of type :cl-object.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
6446cde7c3
commit
0ea425866c
14 changed files with 291 additions and 218 deletions
|
|
@ -94,11 +94,9 @@
|
|||
(when (and fun (c2try-tail-recursive-call fun args))
|
||||
(return-from c2call-global))
|
||||
(let* ((*inline-blocks* 0)
|
||||
(destination-rep-type (loc-representation-type *destination*))
|
||||
(destination-type (loc-type *destination*)))
|
||||
(unwind-exit (call-global-loc fname fun (inline-args args)
|
||||
(type-and return-type destination-type)
|
||||
destination-rep-type))
|
||||
(*temp* *temp*))
|
||||
(unwind-exit (call-global-loc fname fun args return-type
|
||||
(loc-type *destination*)))
|
||||
(close-inline-blocks))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -112,45 +110,51 @@
|
|||
;;; ARGS: a list of typed locs with arguments
|
||||
;;; RETURN-TYPE: the type to which the output is coerced
|
||||
;;;
|
||||
(defun call-global-loc (fname fun args return-type &optional (return-rep-type 'any)
|
||||
&aux loc found fd minarg maxarg)
|
||||
(cond
|
||||
;; Check whether it is a global function that we cannot call directly.
|
||||
((and (or (null fun) (fun-global fun)) (not (inline-possible fname)))
|
||||
(call-unknown-global-loc fname nil args))
|
||||
(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-loc fname nil (inline-args args))))
|
||||
|
||||
;; Open-codable function call.
|
||||
((and (or (null fun) (fun-global fun))
|
||||
(setq loc (inline-function fname args return-type return-rep-type)))
|
||||
loc)
|
||||
;; Open-codable function.
|
||||
(let* ((arg-types (mapcar #'c1form-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))))
|
||||
|
||||
;; Call to a function defined in the same file. Direct calls are
|
||||
;; only emitted for low or neutral values of DEBUG is >= 2.
|
||||
((and (<= (cmp-env-optimization 'debug) 1)
|
||||
(or (fun-p fun)
|
||||
(and (null fun)
|
||||
(setf fun (find fname *global-funs* :test #'same-fname-p
|
||||
;; 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 (<= (cmp-env-optimization 'debug) 1)
|
||||
(or (fun-p fun)
|
||||
(and (null fun)
|
||||
(setf fun (find fname *global-funs* :test #'same-fname-p
|
||||
:key #'fun-name)))))
|
||||
(call-loc fname fun args))
|
||||
(return-from call-global-loc (call-loc fname fun args)))
|
||||
|
||||
;; Call to a global (SETF ...) function
|
||||
((not (symbolp fname))
|
||||
(call-unknown-global-loc fname nil args))
|
||||
;; Call to a global (SETF ...) function
|
||||
(when (not (symbolp fname))
|
||||
(return-from call-global-loc (call-unknown-global-loc fname nil 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.
|
||||
((and (<= (cmp-env-optimization 'debug) 1)
|
||||
(setf fd (get-sysprop fname 'Lfun))
|
||||
(multiple-value-setq (minarg maxarg) (get-proclaimed-narg fname)))
|
||||
(call-exported-function-loc fname args fd minarg maxarg
|
||||
#-ecl-min nil
|
||||
#+ecl-min (member fname *in-all-symbols-functions*)))
|
||||
;; 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.
|
||||
(when (and (<= (cmp-env-optimization 'debug) 1)
|
||||
(setf fd (get-sysprop fname 'Lfun)))
|
||||
(multiple-value-bind (minarg maxarg) (get-proclaimed-narg fname)
|
||||
(return-from call-global-loc
|
||||
(call-exported-function-loc
|
||||
fname args fd minarg maxarg
|
||||
#-ecl-min nil
|
||||
#+ecl-min (member fname *in-all-symbols-functions*)))))
|
||||
|
||||
((multiple-value-setq (found fd minarg maxarg) (si::mangle-name fname t))
|
||||
(call-exported-function-loc fname args fd minarg maxarg t))
|
||||
(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))))
|
||||
|
||||
(t (call-unknown-global-loc fname nil args))))
|
||||
(call-unknown-global-loc fname nil args))
|
||||
|
||||
(defun call-loc (fname fun args)
|
||||
`(CALL-NORMAL ,fun ,(coerce-locs args)))
|
||||
|
|
@ -271,6 +275,7 @@
|
|||
(nth n *text-for-lexical-level*) x))
|
||||
(push x args))))))
|
||||
(unless (<= minarg narg maxarg)
|
||||
(baboon)
|
||||
(cmperr "Wrong number of arguments for function ~S"
|
||||
(or fun-lisp-name 'ANONYMOUS)))
|
||||
(when (fun-needs-narg fun)
|
||||
|
|
|
|||
|
|
@ -230,6 +230,7 @@
|
|||
)
|
||||
|
||||
(defstruct (inline-info)
|
||||
name ;;; Function name
|
||||
arg-rep-types ;;; List of representation types for the arguments
|
||||
return-rep-type ;;; Representation type for the output
|
||||
arg-types ;;; List of lisp types for the arguments
|
||||
|
|
@ -264,6 +265,7 @@
|
|||
;;; Variables and constants for error handling
|
||||
;;;
|
||||
(defvar *current-form* '|compiler preprocess|)
|
||||
(defvar *current-c2form* nil)
|
||||
(defvar *compile-file-position* -1)
|
||||
(defvar *first-error* t)
|
||||
(defconstant *cmperr-tag* (cons nil nil))
|
||||
|
|
|
|||
|
|
@ -625,7 +625,7 @@
|
|||
(defun policy-inline-slot-access-p (&optional (env *cmp-env*))
|
||||
"Do we inline access to structures and sealed classes?"
|
||||
(or (< (cmp-env-optimization 'safety env) 2)
|
||||
(<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env))))
|
||||
(<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env))))
|
||||
|
||||
(defun policy-check-all-arguments-p (&optional (env *cmp-env*))
|
||||
"Do we assume that arguments are the right type?"
|
||||
|
|
@ -639,3 +639,11 @@
|
|||
(defun policy-assume-types-dont-change-p (&optional (env *cmp-env*))
|
||||
"Do we assume that type and class definitions will not change?"
|
||||
(<= (cmp-env-optimization 'safety env) 1))
|
||||
|
||||
(defun policy-open-code-aref/aset-p (&optional (env *cmp-env*))
|
||||
"Do we inline access to arrays?"
|
||||
(< (cmp-env-optimization 'safety env) 2))
|
||||
|
||||
(defun policy-array-bounds-check-p (&optional (env *cmp-env*))
|
||||
"Check access to array bounds?"
|
||||
(>= (cmp-env-optimization 'safety env) 1))
|
||||
|
|
|
|||
|
|
@ -113,6 +113,7 @@
|
|||
(let* ((*file* (c1form-file form))
|
||||
(*file-position* (c1form-file form))
|
||||
(*current-form* (c1form-form form))
|
||||
(*current-c2form* form)
|
||||
(name (c1form-name form))
|
||||
(args (c1form-args form))
|
||||
(dispatch (get-sysprop name 'C2)))
|
||||
|
|
|
|||
|
|
@ -397,7 +397,8 @@
|
|||
'VALUES))))))
|
||||
|
||||
(defun c2c-inline (arguments &rest rest)
|
||||
(let ((*inline-blocks* 0))
|
||||
(let ((*inline-blocks* 0)
|
||||
(*temp* *temp*))
|
||||
(unwind-exit (apply #'produce-inline-loc (inline-args arguments) rest))
|
||||
(close-inline-blocks)))
|
||||
|
||||
|
|
|
|||
|
|
@ -251,7 +251,8 @@
|
|||
(defun c2call-local (fun args &optional narg)
|
||||
(declare (type fun fun))
|
||||
(unless (c2try-tail-recursive-call fun args)
|
||||
(let ((*inline-blocks* 0))
|
||||
(let ((*inline-blocks* 0)
|
||||
(*temp* *temp*))
|
||||
(unwind-exit (list 'CALL-NORMAL fun (coerce-locs (inline-args args))))
|
||||
(close-inline-blocks))))
|
||||
|
||||
|
|
|
|||
|
|
@ -91,31 +91,35 @@
|
|||
(check-args-number 'RPLACA args 2 2)
|
||||
(make-c1form* 'RPLACA :args (c1args* args)))
|
||||
|
||||
(defun c2rplaca (args &aux (*inline-blocks* 0) x y)
|
||||
(setq args (coerce-locs (inline-args args))
|
||||
x (first args)
|
||||
y (second args))
|
||||
(when (safe-compile)
|
||||
(wt-nl "if(ATOM(" x "))"
|
||||
"FEtype_error_cons(" x ");"))
|
||||
(wt-nl "ECL_CONS_CAR(" x ") = " y ";")
|
||||
(unwind-exit x)
|
||||
(close-inline-blocks))
|
||||
(defun c2rplaca (args)
|
||||
(let* ((*inline-blocks* 0)
|
||||
(*temp* *temp*)
|
||||
(args (coerce-locs (inline-args args)))
|
||||
(x (first args))
|
||||
(y (second args)))
|
||||
(when (safe-compile)
|
||||
(wt-nl "if(ATOM(" x "))"
|
||||
"FEtype_error_cons(" x ");"))
|
||||
(wt-nl "ECL_CONS_CAR(" x ") = " y ";")
|
||||
(unwind-exit x)
|
||||
(close-inline-blocks)))
|
||||
|
||||
(defun c1rplacd (args)
|
||||
(check-args-number 'RPLACD args 2 2)
|
||||
(make-c1form* 'RPLACD :args (c1args* args)))
|
||||
|
||||
(defun c2rplacd (args &aux (*inline-blocks* 0) x y)
|
||||
(setq args (coerce-locs (inline-args args))
|
||||
x (first args)
|
||||
y (second args))
|
||||
(when (safe-compile)
|
||||
(wt-nl "if(ATOM(" x "))"
|
||||
"FEtype_error_cons(" x ");"))
|
||||
(wt-nl "ECL_CONS_CDR(" x ") = " y ";")
|
||||
(unwind-exit x)
|
||||
(close-inline-blocks))
|
||||
(defun c2rplacd (args)
|
||||
(let* ((*inline-blocks* 0)
|
||||
(*temp* *temp*)
|
||||
(args (coerce-locs (inline-args args)))
|
||||
(x (first args))
|
||||
(y (second args)))
|
||||
(when (safe-compile)
|
||||
(wt-nl "if(ATOM(" x "))"
|
||||
"FEtype_error_cons(" x ");"))
|
||||
(wt-nl "ECL_CONS_CDR(" x ") = " y ";")
|
||||
(unwind-exit x)
|
||||
(close-inline-blocks)))
|
||||
|
||||
(defun c1member (args)
|
||||
(check-args-number 'MEMBER args 2)
|
||||
|
|
@ -130,17 +134,18 @@
|
|||
(t
|
||||
(c1call-global 'MEMBER args))))
|
||||
|
||||
(defun c2member!2 (fun args
|
||||
&aux (*inline-blocks* 0))
|
||||
(unwind-exit
|
||||
(produce-inline-loc (inline-args args) '(T T) '(:object)
|
||||
(case fun
|
||||
(EQ "si_memq(#0,#1)")
|
||||
(EQL "ecl_memql(#0,#1)")
|
||||
(EQUAL "ecl_member(#0,#1)"))
|
||||
nil ; side effects?
|
||||
t)) ; one liner?
|
||||
(close-inline-blocks))
|
||||
(defun c2member!2 (fun args)
|
||||
(let ((*inline-blocks* 0)
|
||||
(*temp* *temp*))
|
||||
(unwind-exit
|
||||
(produce-inline-loc (inline-args args) '(T T) '(:object)
|
||||
(case fun
|
||||
(EQ "si_memq(#0,#1)")
|
||||
(EQL "ecl_memql(#0,#1)")
|
||||
(EQUAL "ecl_member(#0,#1)"))
|
||||
nil ; side effects?
|
||||
t)) ; one liner?
|
||||
(close-inline-blocks)))
|
||||
|
||||
(defun c1assoc (args)
|
||||
(check-args-number 'ASSOC args 2)
|
||||
|
|
@ -156,19 +161,20 @@
|
|||
(t
|
||||
(c1call-global 'ASSOC args))))
|
||||
|
||||
(defun c2assoc!2 (fun args
|
||||
&aux (*inline-blocks* 0))
|
||||
(unwind-exit
|
||||
(produce-inline-loc (inline-args args) '(T T) '(:object)
|
||||
(case fun
|
||||
(eq "ecl_assq(#0,#1)")
|
||||
(eql "ecl_assql(#0,#1)")
|
||||
(equal "ecl_assoc(#0,#1)")
|
||||
(equalp "ecl_assqlp(#0,#1)"))
|
||||
nil ; side effects?
|
||||
t
|
||||
))
|
||||
(close-inline-blocks))
|
||||
(defun c2assoc!2 (fun args)
|
||||
(let* ((*inline-blocks* 0)
|
||||
(*temp* *temp*))
|
||||
(unwind-exit
|
||||
(produce-inline-loc (inline-args args) '(T T) '(:object)
|
||||
(case fun
|
||||
(eq "ecl_assq(#0,#1)")
|
||||
(eql "ecl_assql(#0,#1)")
|
||||
(equal "ecl_assoc(#0,#1)")
|
||||
(equalp "ecl_assqlp(#0,#1)"))
|
||||
nil ; side effects?
|
||||
t
|
||||
))
|
||||
(close-inline-blocks)))
|
||||
|
||||
(defun co1nth (args)
|
||||
(and (not (endp args))
|
||||
|
|
|
|||
|
|
@ -31,6 +31,75 @@
|
|||
;;; 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 loc)
|
||||
(let ((out-rep-type (lisp-type->rep-type expected-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))))
|
||||
(if loc
|
||||
(wt-nl "{" (rep-type-name out-rep-type) " " var "=" loc ";")
|
||||
(wt-nl "{" (rep-type-name out-rep-type) " " var ";"))
|
||||
(incf *inline-blocks*)
|
||||
var))))
|
||||
|
||||
(defun emit-inlined-variable (form expected-type 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)))
|
||||
(let ((*destination* temp)) (set-loc var))
|
||||
(list value-type temp))
|
||||
(list value-type var))))
|
||||
|
||||
(defun emit-inlined-setq (form expected-type 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))))
|
||||
|
||||
(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))
|
||||
(loc (call-global-loc fname nil args return-type expected-type))
|
||||
(type (loc-type loc))
|
||||
(temp (make-inline-temp-var expected-type type))
|
||||
(*destination* temp))
|
||||
(set-loc loc)
|
||||
(list type temp)))
|
||||
|
||||
(defun emit-inlined-structure-ref (form expected-type rest-forms)
|
||||
(let ((type (c1form-primary-type form)))
|
||||
(if (args-cause-side-effect rest-forms)
|
||||
(let* ((temp (make-inline-temp-var expected-type type))
|
||||
(*destination* temp))
|
||||
(c2expr* form)
|
||||
(list type temp))
|
||||
(list type
|
||||
(list 'SYS: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 expected-type rest-forms)
|
||||
(let ((type (c1form-primary-type form)))
|
||||
(if (args-cause-side-effect rest-forms)
|
||||
(let* ((temp (make-inline-temp-var expected-type type))
|
||||
(*destination* temp))
|
||||
(c2expr* form)
|
||||
(list type temp))
|
||||
(list type
|
||||
(list 'SYS:INSTANCE-REF
|
||||
(first (coerce-locs
|
||||
(inline-args (list (c1form-arg 0 form)))))
|
||||
(c1form-arg 1 form)
|
||||
#+nil (c1form-arg 2 form))))))
|
||||
|
||||
;;;
|
||||
;;; inline-args:
|
||||
;;; returns a list of pairs (type loc)
|
||||
|
|
@ -40,116 +109,36 @@
|
|||
;;; call close-inline-blocks
|
||||
;;;
|
||||
(defun inline-args (forms &optional types)
|
||||
(flet ((all-locations (args &aux (res t))
|
||||
(dolist (arg args res)
|
||||
(unless (member (c1form-name arg)
|
||||
'(LOCATION VAR SYS:STRUCTURE-REF
|
||||
#+clos SYS:INSTANCE-REF)
|
||||
:test #'eq)
|
||||
(setq res nil)))))
|
||||
(do* ((forms forms)
|
||||
(expected-type)
|
||||
(form)
|
||||
(locs '()))
|
||||
((endp forms) (nreverse locs))
|
||||
(setq form (pop forms)
|
||||
expected-type (if types (pop types) t))
|
||||
(case (c1form-name form)
|
||||
(LOCATION
|
||||
(push (list (c1form-primary-type form) (c1form-arg 0 form)) locs))
|
||||
(VAR
|
||||
(push (emit-inlined-variable form expected-type forms) locs))
|
||||
|
||||
(do ((forms forms (cdr forms))
|
||||
(form) (locs))
|
||||
((endp forms) (nreverse locs))
|
||||
(setq form (car forms))
|
||||
(case (c1form-name form)
|
||||
(LOCATION
|
||||
(push (list (c1form-primary-type form) (c1form-arg 0 form)) locs))
|
||||
(VAR
|
||||
(let ((var (c1form-arg 0 form)))
|
||||
(if (var-changed-in-form-list var (cdr forms))
|
||||
(let* ((var-rep-type (var-rep-type var))
|
||||
(lcl (make-lcl-var :rep-type var-rep-type :type (var-type var))))
|
||||
(wt-nl "{" (rep-type-name var-rep-type) " " lcl "= " var ";")
|
||||
(push (list (c1form-primary-type form) lcl) locs)
|
||||
(incf *inline-blocks*))
|
||||
(push (list (c1form-primary-type form) var) locs))))
|
||||
(CALL-GLOBAL
|
||||
(push (emit-inlined-call-global form expected-type) locs))
|
||||
|
||||
(CALL-GLOBAL
|
||||
(let* ((fname (c1form-arg 0 form))
|
||||
(args (c1form-arg 1 form))
|
||||
(return-type (c1form-primary-type form))
|
||||
(arg-locs (inline-args args))
|
||||
(loc (inline-function fname arg-locs return-type)))
|
||||
(if loc
|
||||
;; If there are side effects, we may not move the C form
|
||||
;; around and we have to save its value in a variable.
|
||||
;; We use a variable of type out-type to save the value
|
||||
;; if (return-type >= out-type)
|
||||
;; then
|
||||
;; coerce the value to out-type
|
||||
;; otherwise
|
||||
;; save the value without coercion and return the
|
||||
;; variable tagged with and-type,
|
||||
;; so that whoever uses it may coerce it to such type
|
||||
(let* ((and-type (type-and return-type (loc-type loc)))
|
||||
(out-rep-type (loc-representation-type loc))
|
||||
(var (make-lcl-var :rep-type out-rep-type :type and-type)))
|
||||
(wt-nl "{" (rep-type-name out-rep-type) " " var "= " loc ";")
|
||||
(incf *inline-blocks*)
|
||||
(setq loc var)
|
||||
(push (list (loc-type loc) loc) locs))
|
||||
(let* ((temp (make-temp-var)) ;; output value
|
||||
;; bindings like c2expr*
|
||||
(*exit* (next-label))
|
||||
(*unwind-exit* (cons *exit* *unwind-exit*))
|
||||
(*lcl* *lcl*)
|
||||
(*temp* *temp*)
|
||||
(*destination* temp))
|
||||
(unwind-exit (call-global-loc fname nil arg-locs return-type :object))
|
||||
(wt-label *exit*)
|
||||
(push
|
||||
(list (if (subtypep 'T return-type)
|
||||
(or (get-return-type fname) 'T)
|
||||
return-type)
|
||||
temp)
|
||||
locs)))))
|
||||
(SYS:STRUCTURE-REF
|
||||
(push (emit-inlined-structure-ref form expected-type forms) locs))
|
||||
|
||||
(SYS:STRUCTURE-REF
|
||||
(let ((type (c1form-primary-type form)))
|
||||
(if (args-cause-side-effect (cdr forms))
|
||||
(let* ((temp (make-temp-var))
|
||||
(*destination* temp))
|
||||
(c2expr* form)
|
||||
(push (list type temp) locs))
|
||||
(push (list type
|
||||
(list 'SYS:STRUCTURE-REF
|
||||
(first (coerce-locs
|
||||
(inline-args (list (c1form-arg 0 form)))))
|
||||
(c1form-arg 1 form)
|
||||
(c1form-arg 2 form)
|
||||
(c1form-arg 3 form)))
|
||||
locs))))
|
||||
#+clos
|
||||
(SYS:INSTANCE-REF
|
||||
(let ((type (c1form-primary-type form)))
|
||||
(if (args-cause-side-effect (cdr forms))
|
||||
(let* ((temp (make-temp-var))
|
||||
(*destination* temp))
|
||||
(c2expr* form)
|
||||
(push (list type temp) locs))
|
||||
(push (list type
|
||||
(list 'SYS:INSTANCE-REF
|
||||
(first (coerce-locs
|
||||
(inline-args (list (c1form-arg 0 form)))))
|
||||
(c1form-arg 1 form)
|
||||
#+nil (c1form-arg 2 form))) ; JJGR
|
||||
locs))))
|
||||
(SETQ
|
||||
(let ((vref (c1form-arg 0 form))
|
||||
(form1 (c1form-arg 1 form)))
|
||||
(let ((*destination* vref)) (c2expr* form1))
|
||||
(if (eq (c1form-name form1) 'LOCATION)
|
||||
(push (list (c1form-primary-type form1) (c1form-arg 0 form1)) locs)
|
||||
(setq forms (list* nil ; discarded at iteration
|
||||
(make-c1form 'VAR form vref)
|
||||
(cdr forms))
|
||||
))))
|
||||
#+clos
|
||||
(SYS:INSTANCE-REF
|
||||
(push (emit-inlined-instance-ref form expected-type forms) locs))
|
||||
|
||||
(t (let ((temp (make-temp-var)))
|
||||
(let ((*destination* temp)) (c2expr* form))
|
||||
(push (list (c1form-primary-type form) temp) locs))))))
|
||||
)
|
||||
(SETQ
|
||||
(push (emit-inlined-setq form expected-type forms) locs))
|
||||
|
||||
(t (let* ((type (c1form-primary-type form))
|
||||
(temp (make-inline-temp-var expected-type type)))
|
||||
(let ((*destination* temp)) (c2expr* form))
|
||||
(push (list type temp) locs))))))
|
||||
|
||||
(defun destination-type ()
|
||||
(rep-type->lisp-type (loc-representation-type *destination*))
|
||||
|
|
@ -161,24 +150,25 @@
|
|||
;;; locs are typed locs as produced by inline-args
|
||||
;;; returns NIL if inline expansion of the function is not possible
|
||||
;;;
|
||||
(defun inline-function (fname inlined-locs return-type &optional (return-rep-type 'any))
|
||||
(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 (get-sysprop fname 'C2))
|
||||
(let* ((dest-rep-type (loc-representation-type *destination*))
|
||||
(dest-type (rep-type->lisp-type dest-rep-type))
|
||||
(ii (get-inline-info fname (mapcar #'first inlined-locs)
|
||||
return-type return-rep-type)))
|
||||
(when ii
|
||||
(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 fname))
|
||||
(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))))))
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -102,6 +102,7 @@
|
|||
(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)
|
||||
|
|
|
|||
|
|
@ -82,6 +82,7 @@
|
|||
|
||||
(defun c2structure-ref (form name-vv index unsafe)
|
||||
(let* ((*inline-blocks* 0)
|
||||
(*temp* *temp*)
|
||||
(loc (first (coerce-locs (inline-args (list form))))))
|
||||
(unwind-exit (list 'SYS:STRUCTURE-REF loc name-vv index unsafe))
|
||||
(close-inline-blocks)))
|
||||
|
|
@ -129,18 +130,19 @@
|
|||
&aux locs (*inline-blocks* 0))
|
||||
;; the third argument here *c1t* is just a hack to ensure that
|
||||
;; a variable is introduced for y if it is an expression with side effects
|
||||
(setq locs (inline-args (list x y *c1t*)))
|
||||
(setq x (second (first locs)))
|
||||
(setq y `(coerce-loc :object ,(second (second locs))))
|
||||
(if (safe-compile)
|
||||
(wt-nl "ecl_structure_set(" x "," name-vv "," index "," y ");")
|
||||
#+clos
|
||||
(wt-nl "(" x ")->instance.slots[" index "]= " y ";")
|
||||
#-clos
|
||||
(wt-nl "(" x ")->str.self[" index "]= " y ";"))
|
||||
(unwind-exit y)
|
||||
(close-inline-blocks)
|
||||
)
|
||||
(let* ((*inline-blocks* 0)
|
||||
(*temp* *temp*)
|
||||
(locs (inline-args (list x y *c1t*)))
|
||||
(x (second (first locs)))
|
||||
(y `(coerce-loc :object ,(second (second locs)))))
|
||||
(if (safe-compile)
|
||||
(wt-nl "ecl_structure_set(" x "," name-vv "," index "," y ");")
|
||||
#+clos
|
||||
(wt-nl "(" x ")->instance.slots[" index "]= " y ";")
|
||||
#-clos
|
||||
(wt-nl "(" x ")->str.self[" index "]= " y ";"))
|
||||
(unwind-exit y)
|
||||
(close-inline-blocks)))
|
||||
|
||||
(put-sysprop 'SYS:STRUCTURE-REF 'C1 'c1structure-ref)
|
||||
(put-sysprop 'SYS:STRUCTURE-REF 'C2 'c2structure-ref)
|
||||
|
|
|
|||
|
|
@ -632,6 +632,7 @@
|
|||
(wt ")"))
|
||||
|
||||
(let* ((*lcl* 0) (*temp* 0) (*max-temp* 0)
|
||||
(*last-label* 0)
|
||||
(*lex* 0) (*max-lex* 0)
|
||||
(*env* (fun-env fun)) ; continue growing env
|
||||
(*max-env* *env*) (*env-lvl* 0)
|
||||
|
|
|
|||
|
|
@ -83,6 +83,8 @@
|
|||
(abort))
|
||||
|
||||
(defun handle-compiler-internal-error (c)
|
||||
(when *compiler-break-enable*
|
||||
(si::default-debugger c))
|
||||
(setf c (make-condition 'compiler-internal-error
|
||||
:format-control "~A"
|
||||
:format-arguments (list c)))
|
||||
|
|
|
|||
|
|
@ -162,7 +162,7 @@
|
|||
(setq rep-type (if type (lisp-type->rep-type type) :object)))
|
||||
(unless type
|
||||
(setq type 'T))
|
||||
(make-var :kind rep-type :type type :loc `(LCL ,(incf *lcl*))))
|
||||
(make-var :kind rep-type :type type :loc (next-lcl)))
|
||||
|
||||
(defun make-temp-var (&optional (type 'T))
|
||||
(make-var :kind :object :type type :loc `(TEMP ,(next-temp))))
|
||||
|
|
|
|||
|
|
@ -83,7 +83,8 @@
|
|||
(setf return-rep-type :object))
|
||||
(let* ((return-type (rep-type->lisp-type return-rep-type))
|
||||
(inline-info
|
||||
(make-inline-info :arg-rep-types arg-rep-types
|
||||
(make-inline-info :name name
|
||||
:arg-rep-types arg-rep-types
|
||||
:return-rep-type return-rep-type
|
||||
:return-type (rep-type->lisp-type return-rep-type)
|
||||
:arg-types arg-types
|
||||
|
|
@ -196,14 +197,58 @@
|
|||
"ecl_aset_bv(#1,#2,#0)")
|
||||
|
||||
(proclaim-function row-major-aref (array fixnum) t :no-side-effects t)
|
||||
(def-inline row-major-aref :always (array fixnum) t "ecl_aref(#0,#1)")
|
||||
(def-inline row-major-aref :always (t t) t "ecl_aref(#0,fixint(#1))")
|
||||
(def-inline row-major-aref :always (t fixnum) t "ecl_aref(#0,#1)")
|
||||
(def-inline row-major-aref :unsafe (t t) t "ecl_aref_unsafe(#0,fix(#1))")
|
||||
(def-inline row-major-aref :unsafe (t fixnum) t "ecl_aref_unsafe(#0,#1)")
|
||||
(def-inline row-major-aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,fix(#1))")
|
||||
(def-inline row-major-aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)")
|
||||
#+unicode
|
||||
(def-inline row-major-aref :unsafe ((array character) fixnum) :wchar
|
||||
"(#0)->string.self[#1]")
|
||||
(def-inline row-major-aref :unsafe ((array base-char) fixnum) :char
|
||||
"(#0)->base_string.self[#1]")
|
||||
(def-inline row-major-aref :unsafe ((array double-float) fixnum) :double
|
||||
"(#0)->array.self.df[#1]")
|
||||
(def-inline row-major-aref :unsafe ((array single-float) fixnum) :float
|
||||
"(#0)->array.self.sf[#1]")
|
||||
(def-inline row-major-aref :unsafe ((array fixnum) fixnum) :fixnum
|
||||
"(#0)->array.self.fix[#1]")
|
||||
|
||||
(proclaim-function si:row-major-aset (array fixnum t) t)
|
||||
(def-inline si:row-major-aset :always (array fixnum t) t "ecl_aset(#0,#1,#2)")
|
||||
(def-inline si:row-major-aset :always (t t t) t "ecl_aset(#0,fixint(#1),#2)")
|
||||
(def-inline si:row-major-aset :always (t fixnum t) t "ecl_aset(#0,#1,#2)")
|
||||
(def-inline si:row-major-aset :unsafe (t t t) t "ecl_aset_unsafe(#0,fix(#1),#2)")
|
||||
(def-inline si:row-major-aset :unsafe (t fixnum t) t "ecl_aset_unsafe(#0,#1,#2)")
|
||||
(def-inline si:row-major-aset :unsafe ((array t) fixnum t) t
|
||||
"(#0)->vector.self.t[#1]= #2")
|
||||
(def-inline si:row-major-aset :unsafe ((array bit) fixnum t) :fixnum
|
||||
"ecl_aset_bv(#0,#1,fix(#2))")
|
||||
(def-inline si:row-major-aset :unsafe ((array bit) fixnum fixnum) :fixnum
|
||||
"ecl_aset_bv(#0,#1,#2)")
|
||||
(def-inline si:row-major-aset :unsafe ((array base-char) fixnum base-char) :char
|
||||
"(#0)->base_string.self[#1]= #2")
|
||||
#+unicode
|
||||
(def-inline si:row-major-aset :unsafe ((array character) fixnum character) :wchar
|
||||
"(#0)->string.self[#1]= #2")
|
||||
(def-inline si:row-major-aset :unsafe ((array double-float) fixnum double-float) :double
|
||||
"(#0)->array.self.df[#1]= #2")
|
||||
(def-inline si:row-major-aset :unsafe ((array single-float) fixnum single-float) :float
|
||||
"(#0)->array.self.sf[#1]= #2")
|
||||
(def-inline si:row-major-aset :unsafe ((array fixnum) fixnum fixnum) :fixnum
|
||||
"(#0)->array.self.fix[#1]= #2")
|
||||
|
||||
(proclaim-function array-element-type (array) t)
|
||||
(proclaim-function array-rank (array) fixnum)
|
||||
(def-inline array-rank :unsafe (array) :fixnum
|
||||
"(#0)->array.rank")
|
||||
|
||||
(proclaim-function array-dimension (array fixnum) fixnum)
|
||||
(def-inline array-dimension :unsafe (array t) :fixnum
|
||||
"(#0)->array.dims[fix(#1)]")
|
||||
(def-inline array-dimension :unsafe (array fixnum) :fixnum
|
||||
"(#0)->array.dims[#1]")
|
||||
|
||||
(proclaim-function array-total-size (array) t :no-side-effects t)
|
||||
(def-inline array-total-size :unsafe (t) :fixnum "((#0)->array.dim)")
|
||||
|
||||
|
|
@ -769,18 +814,26 @@
|
|||
(proclaim-function < (t *) t :predicate t :no-side-effects t)
|
||||
(def-inline < :always (t t) :bool "ecl_number_compare(#0,#1)<0")
|
||||
(def-inline < :always (fixnum-float fixnum-float) :bool "(#0)<(#1)")
|
||||
(def-inline < :always (fixnum-float fixnum-float fixnum-float) :bool
|
||||
"@012;((#0)<(#1) && (#1)<(#2))")
|
||||
|
||||
(proclaim-function > (t *) t :predicate t :no-side-effects t)
|
||||
(def-inline > :always (t t) :bool "ecl_number_compare(#0,#1)>0")
|
||||
(def-inline > :always (fixnum-float fixnum-float) :bool "(#0)>(#1)")
|
||||
(def-inline > :always (fixnum-float fixnum-float fixnum-float) :bool
|
||||
"@012;((#0)>(#1) && (#1)>(#2))")
|
||||
|
||||
(proclaim-function <= (t *) t :predicate t :no-side-effects t)
|
||||
(def-inline <= :always (t t) :bool "ecl_number_compare(#0,#1)<=0")
|
||||
(def-inline <= :always (fixnum-float fixnum-float) :bool "(#0)<=(#1)")
|
||||
(def-inline <= :always (fixnum-float fixnum-float fixnum-float) :bool
|
||||
"@012;((#0)<=(#1) && (#1)<=(#2))")
|
||||
|
||||
(proclaim-function >= (t *) t :predicate t :no-side-effects t)
|
||||
(def-inline >= :always (t t) :bool "ecl_number_compare(#0,#1)>=0")
|
||||
(def-inline >= :always (fixnum-float fixnum-float) :bool "(#0)>=(#1)")
|
||||
(def-inline >= :always (fixnum-float fixnum-float fixnum-float) :bool
|
||||
"@012;((#0)>=(#1) && (#1)>=(#2))")
|
||||
|
||||
(proclaim-function max (t *) t :no-side-effects t)
|
||||
(def-inline max :always (t t) t "@01;(ecl_number_compare(#0,#1)>=0?#0:#1)")
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue