mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-10 23:20:23 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'cmpc-cleanup' into 'develop'

Browse source 
cmp: various cleanups and fixes

See merge request embeddable-common-lisp/ecl!302
This commit is contained in:
Marius Gerbershagen 2023-09-30 14:41:20 +00:00
commit f3362ddec7
36 changed files with 241 additions and 290 deletions
Download patch file Download diff file Expand all files Collapse all files

12
contrib/cl-simd/ecl-sse-core.lisp
View file

@ -137,8 +137,7 @@
`((defun ,name ,asyms
(declare (optimize (speed 0) (debug 0) (safety 1)))
(ffi:c-inline ,asyms ,aftypes ,rftype ,(or defun-body call-str) :one-liner t))))
(def-inline ,name :always ,(mapcar #'inline-arg-type-of arg-types) ,rftype
,call-str :inline-or-warn t))))
(def-inline ,name :always ,(mapcar #'inline-arg-type-of arg-types) ,rftype ,call-str))))
(defmacro def-unary-intrinsic (name ret-type insn cost c-name
&key (arg-type ret-type) partial result-size immediate-arg)
@ -211,8 +210,7 @@
:one-liner t))
;; AREF
(def-inline ,rm-aref-name :always (t t) ,rftype
,(fmtr "ecl_row_major_ptr(#0,fixint(#1),~A)" bsize)
:inline-or-warn t)
,(fmtr "ecl_row_major_ptr(#0,fixint(#1),~A)" bsize))
(def-inline ,rm-aref-name :always (t fixnum) ,rftype
,(fmtr "ecl_row_major_ptr(#0,#1,~A)" bsize))
;; AREF unsafe
@ -237,8 +235,7 @@
(defsetf ,rm-aref-name ,rm-aset-name)
;; ASET
(def-inline ,rm-aset-name :always (t t ,val-type) ,rftype
,(fmtw "ecl_row_major_ptr(#0,fixint(#1),~A)" bsize)
:inline-or-warn t)
,(fmtw "ecl_row_major_ptr(#0,fixint(#1),~A)" bsize))
(def-inline ,rm-aset-name :always (t fixnum ,val-type) ,rftype
,(fmtw "ecl_row_major_ptr(#0,#1,~A)" bsize))
;; ASET unsafe
@ -290,8 +287,7 @@
,(fmt "(((char*)#~A) + #~A)")
:one-liner t))
(def-inline ,name :always (,@prefix-itypes t ,@postfix-itypes) ,rftype
,(fmt "ecl_to_pointer(#~A)")
:inline-or-warn t)
,(fmt "ecl_to_pointer(#~A)"))
(def-inline ,name :always (,@prefix-itypes t ,@postfix-itypes t) ,rftype
,(fmt "(((char*)ecl_to_pointer(#~A)) + fixint(#~A))"))
(def-inline ,name :always (,@prefix-itypes t ,@postfix-itypes fixnum) ,rftype

4
contrib/sockets/sockets.lisp
View file

@ -210,7 +210,7 @@ containing the whole rest of the given `string', if any."
HOST-NAME may also be an IP address in dotted quad notation or some
other weird stuff - see getaddrinfo(3) for details."
(multiple-value-bind (errno canonical-name addresses aliases)
(c-inline (host-name) (:cstring)
(c-inline (host-name :test #'equalp) (:cstring :object :object)
(values :int :object :object :object)
"
{
@ -247,7 +247,7 @@ other weird stuff - see getaddrinfo(3) for details."
ecl_aset(vector,1, ecl_make_fixnum( (ip>>16) & 0xFF));
ecl_aset(vector,2, ecl_make_fixnum( (ip>>8) & 0xFF));
ecl_aset(vector,3, ecl_make_fixnum( ip & 0xFF ));
addresses = cl_adjoin(4, vector, addresses, @':test, @'equalp);
addresses = cl_adjoin(4, vector, addresses, #1, #2);
if ( rp->ai_canonname != 0 ) {
cl_object alias = ecl_make_simple_base_string( rp->ai_canonname, -1 );
aliases = CONS(alias, aliases);

3
src/c/compiler.d
View file

@ -2767,6 +2767,9 @@ si_need_to_make_load_form_p(cl_object object)
case t_csfloat:
case t_cdfloat:
case t_clfloat:
#endif
#ifdef ECL_SSE2
case t_sse_pack:
#endif
case t_symbol:
case t_pathname:

57
src/clos/method.lsp
View file

@ -143,38 +143,39 @@
(not (member '&allow-other-keys lambda-list)))
(let ((x (position '&aux lambda-list)))
(setf lambda-list
(append (subseq lambda-list 0 x)
'(&allow-other-keys)
(and x (subseq lambda-list x))
nil))))
(append (subseq lambda-list 0 x)
'(&allow-other-keys)
(and x (subseq lambda-list x))
nil))))
(let* ((copied-variables '())
(ignorable `(declare (ignorable ,@required-parameters)))
(block-name (si:function-block-name name))
(class-declarations
(nconc (when *add-method-argument-declarations*
(loop for name in required-parameters
for type in specializers
when (and (not (eq type t)) (symbolp type))
do (push `(,name ,name) copied-variables) and
nconc `((type ,type ,name)
(si::no-check-type ,name))))
(list (list 'si::function-block-name name))
(cdar declarations)))
(block `(block ,(si::function-block-name name) ,@real-body))
(nconc (when *add-method-argument-declarations*
(loop for name in required-parameters
for type in specializers
when (and (not (eq type t)) (symbolp type))
do (push `(,name ,name) copied-variables) and
nconc `((type ,type ,name)
(si::no-check-type ,name))))
(list (list 'si:function-block-name block-name))
(cdar declarations)))
(block `(block ,block-name ,@real-body))
(method-lambda
;; Remove the documentation string and insert the
;; appropriate class declarations. The documentation
;; string is removed to make it easy for us to insert
;; new declarations later, they will just go after the
;; second of the method lambda. The class declarations
;; are inserted to communicate the class of the method's
;; arguments to the code walk.
`(lambda ,lambda-list
,@(and class-declarations `((declare ,@class-declarations)))
,ignorable
,(if copied-variables
`(let* ,copied-variables
,ignorable
,block)
;; Remove the documentation string and insert the
;; appropriate class declarations. The documentation
;; string is removed to make it easy for us to insert
;; new declarations later, they will just go after the
;; second of the method lambda. The class declarations
;; are inserted to communicate the class of the method's
;; arguments to the code walk.
`(lambda ,lambda-list
,@(and class-declarations `((declare ,@class-declarations)))
,ignorable
,(if copied-variables
`(let* ,copied-variables
,ignorable
,block)
block))))
(values method-lambda declarations documentation))))

31
src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp
View file

@ -23,9 +23,9 @@
;;; Here, ARG-TYPE is the list of argument types belonging to the lisp family,
;;; while RETURN-REP-TYPE is a representation type, i.e. the C type of the
;;; output expression. EXPANSION-STRING is a C/C++ expression template, like the
;;; ones used by C-INLINE. Finally, KIND can be :ALWAYS, :SAFE or :UNSAFE,
;;; depending on whether the inline expression should be applied always, in safe
;;; or in unsafe compilation mode, respectively.
;;; ones used by C-INLINE. Finally, KIND can be :ALWAYS or :UNSAFE, depending on
;;; whether the inline expression should be applied always or only in the unsafe
;;; compilation mode, respectively.
;;;
(defun inline-information (name safety)
@ -35,15 +35,14 @@
(setf (gethash (list name safety) *inline-information*) value))
(defun %def-inline (name safety arg-types return-rep-type expansion
&key (one-liner t) (exact-return-type nil) (inline-or-warn nil)
&key (one-liner t) (exact-return-type nil)
(multiple-values t)
&aux arg-rep-types)
(setf safety
(case safety
(:unsafe :inline-unsafe)
(:safe :inline-safe)
(:always :inline-always)
(t (error "In DEF-INLINE, wrong value of SAFETY"))))
(t (error "In DEF-INLINE, ~s is a wrong value of SAFETY." safety))))
;; Ensure we can inline this form. We only inline when the features are
;; there (checked above) and when the C types are part of this machine
;; (checked here).
@ -59,8 +58,6 @@
arg-types))
(when (eq return-rep-type t)
(setf return-rep-type :object))
(when inline-or-warn
(setf (inline-information name 'should-be-inlined) t))
(let* ((return-type (if (and (consp return-rep-type)
(eq (first return-rep-type) 'values))
t
@ -76,12 +73,6 @@
;; :side-effects (not (si:get-sysprop name 'no-side-effects))
:one-liner one-liner
:expansion expansion)))
#+(or)
(loop for i in (inline-information name safety)
when (and (equalp (inline-info-arg-types i) arg-types)
(not (equalp return-type (inline-info-return-type i))))
do (format t "~&;;; Redundand inline definition for ~A~&;;; ~<~A~>~&;;; ~<~A~>"
name i inline-info))
(push inline-info (gethash (list name safety) *inline-information*))))
(defmacro def-inline (&rest args)
@ -333,7 +324,7 @@
(def-inline cl:cons :always (t t) t "CONS(#0,#1)")
(def-inline cl:endp :safe (t) :bool "ecl_endp(#0)")
(def-inline cl:endp :always (t) :bool "ecl_endp(#0)")
(def-inline cl:endp :unsafe (t) :bool "#0==ECL_NIL")
(def-inline cl:nth :always (t t) t "ecl_nth(ecl_to_size(#0),#1)")
@ -653,6 +644,11 @@
(def-inline cl:boundp :always (t) :bool "ecl_boundp(cl_env_copy,#0)")
(def-inline cl:boundp :unsafe ((and symbol (not null))) :bool "ECL_SYM_VAL(cl_env_copy,#0)!=OBJNULL")
(def-inline cl:terpri :always (t) :object "(ecl_terpri(#0))")
(def-inline cl:print :always (t t) :object "(ecl_print(#0,#1))")
(def-inline cl:prin1 :always (t t) :object "(ecl_prin1(#0,#1))")
(def-inline cl:princ :always (t t) :object "(ecl_princ(#0,#1))")
;; file unixsys.d
;; file sequence.d
@ -815,3 +811,8 @@
(def-inline clos:funcallable-standard-instance-access :unsafe (clos:funcallable-standard-object fixnum) t "(#0)->instance.slots[#1]"))
*inline-information*))
;;; XXX this should be part of the initializer for the compiler instance (but
;;; currently the compiler is a singleton).
(setf (machine-inline-information *default-machine*)
(make-inline-information *default-machine*))

59
src/cmp/cmpbackend-cxx/cmpc-inliner.lsp
View file

@ -14,8 +14,18 @@
(in-package "COMPILER")
(setf (machine-inline-information *default-machine*)
(make-inline-information *default-machine*))
(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
return-type ;;; Lisp type for the output
exact-return-type ;;; Only use this expansion when the output is
;;; declared to have a subtype of RETURN-TYPE
multiple-values ;;; Works with all destinations, including VALUES / RETURN
expansion ;;; C template containing the expansion
one-liner ;;; Whether the expansion spans more than one line
)
(defun inlined-arg-loc (arg)
(second arg))
@ -47,8 +57,8 @@
;;; 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*.
;; 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*))
@ -96,38 +106,26 @@
(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 (inline-information 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 (inline-information 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)))))
(when (and (null output)
(inline-information fname 'should-be-inlined)
(>= (cmp-env-optimization 'speed) 1))
(cmpwarn-style "Could not inline call to ~S ~S - performance may be degraded."
fname types))
output))
(defun to-fixnum-float-type (type)
(dolist (i '(FIXNUM DOUBLE-FLOAT SINGLE-FLOAT LONG-FLOAT)
nil)
(dolist (i '(CL:FIXNUM CL:DOUBLE-FLOAT CL:SINGLE-FLOAT CL:LONG-FLOAT) nil)
(when (type>= i type)
(return i))))
(defun maximum-float-type (t1 t2)
(cond ((null t1)
t2)
((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)
(T
'FIXNUM)))
(macrolet ((try-type (type)
`(and (or (eq t1 ,type) (eq t2 ,type))
,type)))
(or (and (null t1) t2)
(try-type 'CL:LONG-FLOAT)
(try-type 'CL:DOUBLE-FLOAT)
(try-type 'CL:SINGLE-FLOAT)
'CL:FIXNUM)))
(defun inline-type-matches (inline-info arg-types return-type)
(when (and (not (inline-info-multiple-values inline-info))
@ -185,17 +183,6 @@
(nreverse rts))
inline-info))))
(defun c-inline-safe-string (constant-string)
;; Produce a text representation of a string that can be used
;; in a C-INLINE form, without triggering the @ or # escape
;; characters
(c-filtered-string
(concatenate 'string
(loop for c across constant-string
when (member c '(#\# #\@))
collect c
collect c))))
(defun produce-inline-loc (inlined-arguments arg-types output-rep-type
c-expression side-effects one-liner)
(let* (args-to-be-saved

2
src/cmp/cmpbackend-cxx/cmpc-mach.lsp
View file

@ -17,8 +17,6 @@
sorted-types
inline-information)
;;; FIXME currently all definitions assume C machine (see cmpc-machine.lsp).
(defstruct (rep-type (:constructor %make-rep-type))
(index 0) ; Precedence order in the type list
(name t)

2
src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp
View file

@ -24,7 +24,7 @@
:one-liner t :side-effects nil))))
((floatp name)
(let* ((value name)
(type (type-of value))
(type (type-of value))
(loc-type (case type
(cl:single-float 'single-float-value)
(cl:double-float 'double-float-value)

24
src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp
View file

@ -14,7 +14,6 @@
;;; Valid property names for open coded functions are:
;;; :INLINE-ALWAYS
;;; :INLINE-SAFE safe-compile only
;;; :INLINE-UNSAFE non-safe-compile only
;;;
;;; Each property is a list of 'inline-info's, where each inline-info is:
@ -22,12 +21,14 @@
;;;
;;; 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.
;;; 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))))
@ -58,10 +59,11 @@
(defun emit-inlined-setq (form rest-forms)
(let ((vref (c1form-arg 0 form))
(form1 (c1form-arg 1 form)))
(let ((*destination* vref)) (c2expr* form1))
(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) rest-forms))))
(emit-inlined-variable (make-c1form 'VAR form vref nil) rest-forms))))
(defun emit-inlined-call-global (form expected-type)
(let* ((fname (c1form-arg 0 form))
@ -157,8 +159,8 @@
;;;
(defun inline-args (forms)
(loop for form-list on forms
for form = (first form-list)
collect (emit-inline-form form (rest form-list))))
for form = (first form-list)
collect (emit-inline-form form (rest form-list))))
(defun destination-type ()
(rep-type->lisp-type (loc-representation-type *destination*))

25
src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp
View file

@ -12,30 +12,7 @@
(in-package "COMPILER")
;;; TODO move mundane inliners to the sysfun database.
(define-c-inliner terpri (return-type &optional stream)
(produce-inline-loc (list stream)
'(:object) '(:object)
"ecl_terpri(#0)" t t))
(define-c-inliner print (return-type value &optional stream)
(produce-inline-loc (list value stream)
'(:object :object) '(:object)
"ecl_print(#0,#1)" t t))
(define-c-inliner prin1 (return-type value &optional stream)
(produce-inline-loc (list value stream)
'(:object :object) '(:object)
"ecl_prin1(#0,#1)" t t))
#+ (or)
(define-c-inliner princ (return-type expression &optional stream)
(produce-inline-loc (list expression stream)
'(:object :object) '(:object)
"ecl_princ(#0,#1)" t t))
(define-c-inliner princ (return-type expression &optional stream)
(define-c-inliner cl:princ (return-type expression &optional stream)
(multiple-value-bind (foundp value)
(loc-immediate-value-p (inlined-arg-loc expression))
(cond

7
src/cmp/cmpbackend-cxx/cmpc-util.lsp
View file

@ -10,6 +10,7 @@
(defvar *opened-c-braces* 0)
(defvar *emitted-local-funs* nil)
(defvar *inline-information* nil)
;;; Compiled code uses the following kinds of variables:
;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl)
@ -67,7 +68,11 @@
(*temp* 0)
(*max-temp* 0)
(*next-cfun* 0)
(*last-label* 0))
(*last-label* 0)
(*inline-information*
(ext:if-let ((r (machine-inline-information *machine*)))
(si:copy-hash-table r)
(make-inline-information *machine*))))
,@body))
(defun-cached env-var-name (n) eql

10
src/cmp/cmpbackend-cxx/cmpc-wt.lsp
View file

@ -210,3 +210,13 @@
(defun c-filtered-string (string &rest args)
(with-output-to-string (aux-stream)
(apply #'wt-filtered-data string aux-stream :one-liner t args)))
(defun c-inline-safe-string (constant-string)
;; Produce a text representation of a string that can be used in a C-INLINE
;; form, without triggering the @ or # escape characters
(c-filtered-string
(concatenate 'string
(loop for c across constant-string
when (member c '(#\# #\@))
collect c
collect c))))

26
src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp
View file

@ -33,25 +33,13 @@
'(progn))
(defun output-clines (output-stream)
(flet ((parse-one-string (s output-stream)
(with-input-from-string (stream s)
(loop for c = (read-char stream nil nil)
while c
do (if (eq c #\@)
(let ((object (handler-case (read stream)
(serious-condition (c)
(cmperr "Unable to parse FFI:CLINES string~& ~S"
s)))))
(let ((*compiler-output1* output-stream))
(wt (add-object object :permanent t))))
(write-char c output-stream))))))
(loop for s in *clines-string-list*
do (terpri output-stream)
do (if (find #\@ s)
(parse-one-string s output-stream)
(write-string s output-stream)))
(terpri output-stream)
(setf *clines-string-list* nil)))
(loop for s in *clines-string-list*
do (terpri output-stream)
do (if (find #\@ s)
(cmperr "The character #\\@ is not allowed in ~s." 'FFI:CLINES)
(write-string s output-stream)))
(terpri output-stream)
(setf *clines-string-list* nil))
;; ----------------------------------------------------------------------
;; C/C++ INLINE CODE

25
src/cmp/cmpbackend-cxx/cmppass2-loc.lsp
View file

@ -159,7 +159,7 @@
;;; FDEFINITION, MAKE-CLOSURE
;;;
(defun wt-fdefinition (fun-name)
(let* ((name (si::function-block-name fun-name))
(let* ((name (si:function-block-name fun-name))
(package (symbol-package name))
(safe (or (not (safe-compile))
(and (or (eq package (find-package "CL"))
@ -385,19 +385,16 @@
(case c
(#\@
(let ((object (read s)))
(cond ((and (consp object) (equal (first object) 'RETURN))
(if (eq output-vars 'VALUES)
(cmperr "User @(RETURN ...) in a C-INLINE form with no output values")
(let ((ndx (or (second object) 0))
(l (length output-vars)))
(if (< ndx l)
(wt (nth ndx output-vars))
(cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values"
ndx l)))))
(t
(when (and (consp object) (eq (first object) 'QUOTE))
(setq object (second object)))
(wt (add-object object :permanent t))))))
(unless (and (consp object) (eq (car object) 'RETURN))
(cmperr "Used @~s in C-INLINE form. Expected syntax is @(RETURN ...)." object))
(if (eq output-vars 'VALUES)
(cmperr "Used @(RETURN ...) in a C-INLINE form with no output values.")
(let ((ndx (or (second object) 0))
(l (length output-vars)))
(if (< ndx l)
(wt (nth ndx output-vars))
(cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values."
ndx l))))))
(#\#
(let* ((k (read-char s))
(next-char (peek-char nil s nil nil))

13
src/cmp/cmpbackend-cxx/cmppass2-special.lsp
View file

@ -18,16 +18,9 @@
(declare (ignore c1form))
(progv symbols values (c2expr body)))
(defun c2function (c1form kind funob fun)
(declare (ignore c1form funob))
(case kind
(GLOBAL
(unwind-exit `(FDEFINITION ,fun)))
(CLOSURE
;; XXX: we have some code after baboon – is CLOSURE legal or not?
(baboon :format-control "c2function: c1form is of unexpected kind.")
(new-local fun)
(unwind-exit `(MAKE-CCLOSURE ,fun)))))
(defun c2function (c1form fname)
(declare (ignore c1form))
(unwind-exit `(FDEFINITION ,fname)))
;;; Mechanism for sharing code.
(defun new-local (fun)

11
src/cmp/cmpbackend-cxx/cmppass2-var.lsp
View file

@ -133,10 +133,15 @@
;; 6) Close the C expression.
(close-inline-blocks)))
(defun c2var/location (c1form loc)
#+(or) (unwind-exit loc)
(defun c2location (c1form loc)
(unwind-exit (precise-loc-type loc (c1form-primary-type c1form))))
;;; When LOC is not NIL, then the variable is a constant.
(defun c2var (c1form var loc)
(if loc
(c2location loc (c1form-arg 0 loc))
(c2location c1form var)))
(defun c2setq (c1form vref form)
(declare (ignore c1form))
;; First comes the assignement
@ -144,7 +149,7 @@
(c2expr* form))
;; Then the returned value
(if (eq (c1form-name form) 'LOCATION)
(c2var/location form (c1form-arg 0 form))
(c2location form (c1form-arg 0 form))
(unwind-exit vref)))
(defun c2progv (c1form symbols values body)

4
src/cmp/cmpclos.lsp
View file

@ -101,7 +101,7 @@
(when (typep reader 'clos:standard-reader-method)
(let* ((slotd (clos:accessor-method-slot-definition reader))
(index (clos::safe-slot-definition-location slotd)))
(when (si::fixnump index)
(when (ext:fixnump index)
`(clos::safe-instance-ref ,object ,index))))))))
(defun try-optimize-slot-writer (orig-writers args)
@ -113,7 +113,7 @@
(when (typep writer 'clos:standard-writer-method)
(let* ((slotd (clos:accessor-method-slot-definition writer))
(index (clos::safe-slot-definition-location slotd)))
(when (si::fixnump index)
(when (ext:fixnump index)
`(si::instance-set ,(second args) ,index ,(first args)))))))))
#+(or)

10
src/cmp/cmpfun.lsp
View file

@ -166,10 +166,12 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
;;; searches for a (FUNCTION-BLOCK-NAME ...) declaration
(defun function-block-name-declaration (declarations)
(loop for i in declarations
if (and (consp i) (eql (car i) 'si::function-block-name)
(consp (cdr i)))
return (cadr i)
finally (return nil)))
do (when (and (consp i) (eql (car i) 'si:function-block-name))
(let ((name (second i))
(rest (cddr i)))
(unless (and (symbolp name) (null rest))
(cmperr "Invalid ~s declaration:~%~s" 'si:function-block-name i))
(return name)))))
(defun exported-fname (name)
(let (cname)

8
src/cmp/cmpglobals.lsp
View file

@ -22,7 +22,6 @@
(defvar *inline-max-depth* 3
"Depth at which inlining of functions stops.")
(defvar *inline-information* nil)
;;; --cmputil.lsp--
;;;
@ -33,6 +32,7 @@
(defvar *compile-file-position* -1)
(defvar *active-protection* nil)
(defvar *pending-actions* nil)
(defvar *empty-loc* (gensym))
(defvar *compiler-conditions* '()
"This variable determines whether conditions are printed or just accumulated.")
@ -266,9 +266,5 @@ be deleted if they have been opened with LoadLibrary.")
(*clines-string-list* '())
(si::*defun-inline-hook* 'maybe-install-inline-function)
(*machine* (or *machine* *default-machine*))
(*optimizable-constants* (make-optimizable-constants *machine*))
(*inline-information*
(ext:if-let ((r (machine-inline-information *machine*)))
(si:copy-hash-table r)
(make-inline-information *machine*)))))
(*optimizable-constants* (make-optimizable-constants *machine*))))

10
src/cmp/cmplocs.lsp
View file

@ -24,11 +24,13 @@
(permanent-p t)
(value nil))
;;; When the value is the "empty location" then it was created to be filled
;;; later and the real type of the object is not known. See DATA-EMPTY-LOC.
(defun vv-type (loc)
(let ((value (vv-value loc)))
(if (and value (not (ext:fixnump value)))
(type-of value)
t)))
(if (eq value *empty-loc*)
t
(type-of value))))
(defun loc-movable-p (loc)
(if (atom loc)
@ -225,7 +227,7 @@
(values t loc))
((vv-p loc)
(let ((value (vv-value loc)))
(if (or (null value) (ext:fixnump value))
(if (eq value *empty-loc*)
(values nil nil)
(values t value))))
((atom loc)

58
src/cmp/cmpopt-cons.lsp
View file

@ -6,40 +6,11 @@
;;;;
;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll
;;;;
;;;; 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 the file 'LICENSE' for the copyright details.
;;;;
;;;; See file '../Copyright' for full details.
(in-package "COMPILER")
(defun expand-simple-optimizer (values arg-types inline-form env)
(declare (si::c-local))
`(ffi:c-inline ,(if (policy-assume-right-type env)
values
(loop for v in values
for value-and-type in arg-types
collect (if (consp value-and-type)
`(ext:checked-value ,(second value-and-type) ,v)
v)))
,@inline-form))
(defun simple-optimizer-function (name args inline-form)
(declare (si::c-local))
(si:put-sysprop
name 'si::compiler-macro
(if (every #'symbolp args)
#'(lambda (whole env)
(if (policy-inline-accessors env)
`(ffi:c-inline ,(rest whole) ,@inline-form)
whole))
#'(lambda (whole env)
(if (policy-inline-accessors env)
(expand-simple-optimizer (rest whole) args inline-form env)
whole)))))
(defun si:cons-car (x)
(declare (type cons x) (optimize (safety 0) (speed 3)))
(car x))
@ -74,16 +45,25 @@
;;; RPLACA / RPLACD
;;;
(defmacro define-simple-optimizer (name args &rest inline-form)
`(simple-optimizer-function ',name ',args ',inline-form))
(define-compiler-macro rplaca (&whole whole place value)
(if (policy-inline-accessors)
`(ffi:c-inline (,(if (policy-assume-right-type)
place
`(ext:checked-value cons ,place))
,value)
(:object :object) :object
"(ECL_CONS_CAR(#0)=#1,#0)" :one-liner t)
whole))
(define-simple-optimizer rplaca ((c cons) value)
(:object :object) :object
"@0;(ECL_CONS_CAR(#0)=#1,#0)" :one-liner t)
(define-simple-optimizer rplacd ((c cons) value)
(:object :object) :object
"@0;(ECL_CONS_CDR(#0)=#1,#0)" :one-liner t)
(define-compiler-macro rplacd (&whole whole place value)
(if (policy-inline-accessors)
`(ffi:c-inline (,(if (policy-assume-right-type)
place
`(ext:checked-value cons ,place))
,value)
(:object :object) :object
"(ECL_CONS_CDR(#0)=#1,#0)" :one-liner t)
whole))
;;;
;;; NTH / NTHCDR

2
src/cmp/cmpopt-sequence.lsp
View file

@ -57,7 +57,7 @@
`(let* ((%seq ,seq)
(%iterator ,iterator))
(declare (optimize (safety 0)))
(if (si::fixnump %iterator)
(if (ext:fixnump %iterator)
;; Fixnum iterators are always fine
(aref %seq %iterator)
;; Error check in case we may have been passed an improper list

9
src/cmp/cmpopt.lsp
View file

@ -87,9 +87,9 @@
type
(first type))
'SI::DEFTYPE-DEFINITION))
(expand-typep form object `',(funcall function (if (atom type)
nil
(rest type)))
(expand-typep form object `(quote ,(funcall function (if (atom type)
nil
(rest type))))
env))
;;
;; There exists a function which checks for this type?
@ -162,7 +162,8 @@
;; Compound COMPLEX types.
((and (eq first 'COMPLEX)
(= (list-length type) 2))
`(and (typep (realpart ,object) ',(second type))
`(and (complexp ,object)
(typep (realpart ,object) ',(second type))
(typep (imagpart ,object) ',(second type))))
;;
;; (SATISFIES predicate)

2
src/cmp/cmppass1-data.lsp
View file

@ -77,7 +77,7 @@
(maybe-init location init-form)))))))
(defun data-empty-loc ()
(add-object 0 :duplicate t :permanent t))
(add-object *empty-loc* :duplicate t :permanent t))
;;; Note that we can't use GET-OBJECT to probe for referenced objects because
;;; ADD-OBJECT (when failed and :DUPLICATE is T) may return an object that is

20
src/cmp/cmppass1-eval.lsp
View file

@ -24,10 +24,16 @@
((eq form t) (c1t))
((keywordp form)
(make-c1form* 'LOCATION :type (object-type form)
:args (add-symbol form)))
((and (constantp form *cmp-env*)
(c1constant-value (symbol-value form))))
(t (c1var form))))
:args (add-symbol form)))
((constantp form *cmp-env*)
;; FIXME the compiler inlines some constants in the first pass.
;; This is about to be addressed soon. For now we respect that.
(let ((value (symbol-value form)))
(if (assoc value *optimizable-constants*)
(c1constant-symbol-value form value)
(c1var form (c1constant-symbol-value form value)))))
(t
(c1var form nil))))
((consp form)
(cmpck (not (si:proper-list-p form))
"Improper list found in lisp form~%~A" form)
@ -150,6 +156,12 @@
:args (add-object val)))
(t nil)))
;;; To inline a constant it must be possible to externalize its value or copies
;;; of the value must be EQL to each other.
(defun c1constant-symbol-value (name val)
(declare (ignore name))
(c1constant-value val))
#+sse2
(defun c1constant-value/sse (value)
(let* ((bytes (ext:sse-pack-to-vector value '(unsigned-byte 8)))

4
src/cmp/cmppass1-ffi.lsp
View file

@ -175,6 +175,6 @@
`(progn
(defun ,name ,(reverse arg-variables) ,@body)
(si:put-sysprop ',name :callback
(ffi:c-inline () () :object
,(format nil "ecl_make_foreign_data(@':pointer-void,0,(void*)~a)" c-name)
(ffi:c-inline (:pointer-void) (:object) :object
,(format nil "ecl_make_foreign_data(#0,0,(void*)~a)" c-name)
:one-liner t)))))))

21
src/cmp/cmppass1-special.lsp
View file

@ -64,17 +64,16 @@
(defun c1function (args)
(check-args-number 'FUNCTION args 1 1)
(let ((fun (car args)))
(cond ((si::valid-function-name-p fun)
(let ((funob (local-function-ref fun t)))
(if funob
(let* ((var (fun-var funob)))
(add-to-read-nodes var (make-c1form* 'VAR :args var)))
(make-c1form* 'FUNCTION
:type 'FUNCTION
:sp-change (not (and (symbolp fun)
(si:get-sysprop fun 'NO-SP-CHANGE)))
:args 'GLOBAL nil fun))))
((and (consp fun) (member (car fun) '(LAMBDA EXT::LAMBDA-BLOCK)))
(cond ((si:valid-function-name-p fun)
(ext:if-let ((funob (local-function-ref fun t)))
(let ((var (fun-var funob)))
(add-to-read-nodes var (make-c1form* 'VAR :args var nil)))
(make-c1form* 'FUNCTION
:type 'FUNCTION
:sp-change (not (and (symbolp fun)
(si:get-sysprop fun 'NO-SP-CHANGE)))
:args fun)))
((and (consp fun) (member (car fun) '(LAMBDA EXT:LAMBDA-BLOCK)))
(cmpck (endp (cdr fun))
"The lambda expression ~s is illegal." fun)
(let (name body)

5
src/cmp/cmppass1-var.lsp
View file

@ -242,11 +242,12 @@
:kind kind :ignorable ignorable
:ref 0)))))
(defun c1var (name)
;;; When LOC is not NIL then we deal with a constant.
(defun c1var (name loc)
(let* ((var (c1vref name))
(output (make-c1form* 'VAR
:type (var-type var)
:args var)))
:args var loc)))
(add-to-read-nodes var output)
output))

9
src/cmp/cmpprop.lsp
View file

@ -51,11 +51,12 @@
(declare (ignore rest))
(c1form-type form))
(defun p1var (form var)
(let* (;; Use the type of C1FORM because it might have been
;; coerced by a THE form.
(defun p1var (form var loc)
;; Use the type of C1FORM because it might have been coerced by a THE form.
(let* ((loc-type (if loc (values-type-primary-type (p1propagate loc)) t))
(var-type (var-type var))
(type (type-and var-type (c1form-primary-type form))))
(type (type-and (type-and loc-type var-type)
(c1form-primary-type form))))
(prop-message "~&;;; Querying variable ~A gives ~A" (var-name var) type)
type))

8
src/cmp/cmptables.lsp
View file

@ -24,7 +24,7 @@
(CL:PROGN body :pure)
;; sub-level forms
(LOCATION loc :pure :single-valued)
(VAR var :single-valued)
(VAR var value :single-valued)
(CL:SETQ var value-c1form :side-effects)
(CL:PSETQ var-list value-c1form-list :side-effects)
(CL:BLOCK blk-var progn-c1form :pure)
@ -62,7 +62,7 @@
(CL:MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects)
(CL:MULTIPLE-VALUE-BIND vars-list init-c1form body :pure)
(CL:FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued)
(CL:FUNCTION fname :single-valued)
(CL:RPLACD (dest-c1form value-c1form) :side-effects)
(SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure)
@ -240,8 +240,8 @@
(cl:tagbody . c2tagbody)
(cl:go . c2go)
(var . c2var/location)
(location . c2var/location)
(var . c2var)
(location . c2location)
(cl:setq . c2setq)
(cl:progv . c2progv)
(cl:psetq . c2psetq)

14
src/cmp/cmptype.lsp
View file

@ -42,20 +42,18 @@
(defun default-init (var &optional warn)
(declare (ignore warn))
(let ((new-value (cdr (assoc (var-type var)
'((fixnum . 0)
`((fixnum . 0)
(character . #\space)
(long-float . 0.0L1)
(double-float . 0.0D1)
(single-float . 0.0F1)
#+complex-float
(si:complex-single-float . #c(0.0f0 0.0f0))
#+complex-float
(si:complex-double-float . #c(0.0d0 0.0d0))
#+complex-float
(si:complex-single-float . #c(0.0l0 0.0l0)))
,@(when (member :complex-float *features*)
'((si:complex-single-float . #c(0.0f0 0.0f0))
(si:complex-double-float . #c(0.0d0 0.0d0))
(si:complex-single-float . #c(0.0l0 0.0l0)))))
:test #'subtypep))))
(if new-value
(c1constant-value new-value)
(c1constant-value new-value :always t)
(c1nil))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

13
src/cmp/cmptypes.lsp
View file

@ -49,16 +49,3 @@
(format t "~% ~D > ~A, parent ~A" *c1form-level* form (c1form-parents form))
(print-c1forms (c1form-args form))
form)))
(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
return-type ;;; Lisp type for the output
exact-return-type ;;; Only use this expansion when the output is
;;; declared to have a subtype of RETURN-TYPE
multiple-values ;;; Works with all destinations, including VALUES / RETURN
expansion ;;; C template containing the expansion
one-liner ;;; Whether the expansion spans more than one line
)

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

@ -48,9 +48,10 @@
"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-inl-sysfun.lsp"
"src:cmp;cmpbackend-cxx;cmpc-inl-lspfun.lsp"
"src:cmp;cmpbackend-cxx;cmpc-inliner.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"

7
src/lsp/ffi.lsp
View file

@ -477,12 +477,13 @@ translate ASCII and binary strings."
Converts a Lisp string to a foreign string. Memory should be freed
with free-foreign-object."
(let ((lisp-string (string string-designator)))
(c-inline (lisp-string) (t) t
(let ((lisp-string (string string-designator))
(foreign-type '(* :char)))
(c-inline (lisp-string foreign-type) (t t) t
"{
cl_object lisp_string = #0;
cl_index size = lisp_string->base_string.fillp;
cl_object output = ecl_allocate_foreign_data(@(* :char), size+1);
cl_object output = ecl_allocate_foreign_data(#1, size+1);
memcpy(output->foreign.data, lisp_string->base_string.self, size);
output->foreign.data[size] = '\\0';
@(return) = output;

4
src/lsp/top.lsp
View file

@ -843,7 +843,7 @@ Use special code 0 to cancel this operation.")
#-ecl-min
(defun decode-env-elt (env ndx)
(ffi:c-inline (env ndx) (:object :fixnum) :object
(ffi:c-inline (env ndx :utf-8) (:object :fixnum :object) :object
"
cl_object v = #0;
cl_index ndx = #1;
@ -851,7 +851,7 @@ Use special code 0 to cancel this operation.")
pinfo d = (pinfo)(v->vector.self.t[1]) + ndx;
cl_object name;
#ifdef ECL_UNICODE
name = ecl_decode_from_cstring(d->name,-1,@:utf-8);
name = ecl_decode_from_cstring(d->name,-1,#2);
if (!name)
#endif
name = ecl_make_constant_base_string(d->name,-1);

7
src/tests/normal-tests/compiler.lsp
View file

@ -2337,3 +2337,10 @@
(check-yfn (cmplambda* (a b) (multiple-value-call #'list (values a b) (nth-v3) (nth-v4))))
(check-yfn (cmplambda* (a b) (multiple-value-call #'list (values a b) (y-vals))))
(check-nfn (cmplambda* (a b) (multiple-value-call #'list (values a b) (n-vals)))))))
;;; Unreleased refactor branch had a regression where constants were not
;;; properly initialized in the LET form.
(test cmp.0096.c1var/location
(is (floatp (funcall (cmplambda ()
(let ((x most-positive-single-float))
x))))))