mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-24 21:41:29 -08:00
Code Issues Projects Releases Packages Wiki Activity

cmp: be explicit about symbol packages

Browse source 
In dispatch tables and other places where the symbol is a token of some
processing we try to be explicit about its home package (CL, SI, FFI, MP).
This commit is contained in:
Daniel Kochmański 2023-02-13 18:44:40 +01:00
parent 6ab1d0aded
commit e74826b9cd
18 changed files with 678 additions and 684 deletions
Download patch file Download diff file Expand all files Collapse all files

8
src/cmp/cmparray.lsp
View file

@ -232,21 +232,21 @@
;(trace c::expand-row-major-index c::expand-aset c::expand-aref)
(defmacro check-expected-rank (a expected-rank)
`(c-inline
`(ffi:c-inline
(,a ,expected-rank) (:object :fixnum) :void
"if (ecl_unlikely((#0)->array.rank != (#1)))
FEwrong_dimensions(#0,#1);"
:one-liner nil))
(defmacro check-index-in-bounds (array index limit)
`(c-inline
`(ffi:c-inline
(,array ,index ,limit) (:object :fixnum :fixnum) :void
"if (ecl_unlikely((#1)>=(#2)))
FEwrong_index(ECL_NIL,#0,-1,ecl_make_fixnum(#1),#2);"
:one-liner nil))
(defmacro check-vector-in-bounds (vector index)
`(c-inline
`(ffi:c-inline
(,vector ,index) (:object :fixnum) :void
"if (ecl_unlikely((#1)>=(#0)->vector.dim))
FEwrong_index(ECL_NIL,#0,-1,ecl_make_fixnum(#1),(#0)->vector.dim);"
@ -262,7 +262,7 @@
for c-code = (format nil "(#0)->array.dims[~D]" i)
collect `((:object) :fixnum ,c-code :one-liner t
:side-effects nil)))))
`(c-inline (,array) ,@(aref tails n))))
`(ffi:c-inline (,array) ,@(aref tails n))))
(defmacro array-dimension-fast (array n)
(if (typep n '(integer 0 #.(1- array-rank-limit)))

16
src/cmp/cmpct.lsp
View file

@ -24,8 +24,8 @@
(cond ((symbolp name)
(let* ((value (symbol-value name))
(type (lisp-type->rep-type (type-of value))))
(cons value `(c-inline () () ,type ,c-value
:one-liner t :side-effects nil))))
(cons value `(ffi:c-inline () () ,type ,c-value
:one-liner t :side-effects nil))))
((floatp name)
(let* ((value name)
(type (type-of value))
@ -54,12 +54,12 @@
'(
;; Order is important: on platforms where 0.0 and -0.0 are the same
;; the last one is prioritized.
(#.(coerce 0 'single-float) "cl_core.singlefloat_zero")
(#.(coerce 0 'double-float) "cl_core.doublefloat_zero")
(#.(coerce -0.0 'single-float) "cl_core.singlefloat_minus_zero")
(#.(coerce -0.0 'double-float) "cl_core.doublefloat_minus_zero")
(#.(coerce 0 'long-float) "cl_core.longfloat_zero")
(#.(coerce -0.0 'long-float) "cl_core.longfloat_minus_zero")
(#.(coerce 0 'cl:single-float) "cl_core.singlefloat_zero")
(#.(coerce 0 'cl:double-float) "cl_core.doublefloat_zero")
(#.(coerce -0.0 'cl:single-float) "cl_core.singlefloat_minus_zero")
(#.(coerce -0.0 'cl:double-float) "cl_core.doublefloat_minus_zero")
(#.(coerce 0 'cl:long-float) "cl_core.longfloat_zero")
(#.(coerce -0.0 'cl:long-float) "cl_core.longfloat_minus_zero")
;; We temporarily remove this constant, because the bytecodes compiler
;; does not know how to externalize it.

24
src/cmp/cmpenv-declare.lsp
View file

@ -80,16 +80,16 @@ and a possible documentation string (only accepted when DOC-P is true)."
(valid-type-specifier decl-name))))
"Syntax error in declaration ~s" decl)
do (case decl-name
(SPECIAL)
(IGNORE
(cl:SPECIAL)
(cl:IGNORE
(cmpassert (valid-form-p decl-args)
"Syntax error in declaration ~s" decl)
(setf ignored (parse-ignore-declaration decl-args -1 ignored)))
(IGNORABLE
(cl:IGNORABLE
(cmpassert (valid-form-p decl-args)
"Syntax error in declaration ~s" decl)
(setf ignored (parse-ignore-declaration decl-args 0 ignored)))
(TYPE
(cl:TYPE
(cmpassert (and (consp decl-args)
(valid-form-p (rest decl-args) #'symbolp))
"Syntax error in declaration ~s" decl)
@ -100,8 +100,8 @@ and a possible documentation string (only accepted when DOC-P is true)."
(cmpassert (valid-form-p decl-args #'symbolp)
"Syntax error in declaration ~s" decl)
(setf types (collect-declared 'OBJECT decl-args types)))
((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL
SI::C-GLOBAL DYNAMIC-EXTENT IGNORABLE VALUES
((cl:OPTIMIZE cl:FTYPE cl:INLINE cl:NOTINLINE cl:DECLARATION SI::C-LOCAL
SI::C-GLOBAL cl:DYNAMIC-EXTENT cl:VALUES
SI::NO-CHECK-TYPE POLICY-DEBUG-IHS-FRAME :READ-ONLY)
(push decl others))
(SI:FUNCTION-BLOCK-NAME)
@ -123,7 +123,7 @@ and a possible documentation string (only accepted when DOC-P is true)."
"Add to the environment one declarations which is not type, ignorable or
special variable declarations, as these have been extracted before."
(case (car decl)
(OPTIMIZE
(cl:OPTIMIZE
(cmp-env-add-optimizations (rest decl) env))
(POLICY-DEBUG-IHS-FRAME
(let ((flag (or (rest decl) '(t))))
@ -134,7 +134,7 @@ special variable declarations, as these have been extracted before."
env)
(cmp-env-add-declaration 'policy-debug-ihs-frame
flag env))))
(FTYPE
(cl:FTYPE
(if (atom (rest decl))
(cmpwarn "Syntax error in declaration ~a" decl)
(multiple-value-bind (type-name args)
@ -145,18 +145,18 @@ special variable declarations, as these have been extracted before."
(cmpwarn "In an FTYPE declaration, found ~A which is not a function type."
(second decl)))))
env)
(INLINE
(cl:INLINE
(loop for name in (rest decl) do (setf env (declare-inline name env)))
env)
(NOTINLINE
(cl:NOTINLINE
(loop for name in (rest decl) do (setf env (declare-notinline name env)))
env)
(DECLARATION
(cl:DECLARATION
(validate-alien-declaration (rest decl) #'cmperr)
(cmp-env-extend-declaration 'alien (rest decl) env si::*alien-declarations*))
((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE :READ-ONLY)
env)
((DYNAMIC-EXTENT IGNORABLE SI:FUNCTION-BLOCK-NAME)
((cl:DYNAMIC-EXTENT cl:IGNORABLE SI:FUNCTION-BLOCK-NAME)
;; FIXME! SOME ARE IGNORED!
env)
(otherwise

46
src/cmp/cmpenv-fun.lsp
View file

@ -64,37 +64,33 @@
env)
(defun get-arg-types (fname &optional (env *cmp-env*) (may-be-global t))
(let ((x (cmp-env-search-ftype fname env)))
(if x
(let ((arg-types (first x)))
(unless (eq arg-types '*)
(values arg-types t)))
(when may-be-global
(let ((fun (cmp-env-search-function fname env)))
(when (or (null fun) (and (fun-p fun) (fun-global fun)))
(si:get-sysprop fname 'PROCLAIMED-ARG-TYPES)))))))
(ext:if-let ((x (cmp-env-search-ftype fname env)))
(let ((arg-types (first x)))
(unless (eq arg-types '*)
(values arg-types t)))
(when may-be-global
(let ((fun (cmp-env-search-function fname env)))
(when (or (null fun) (and (fun-p fun) (fun-global fun)))
(si:get-sysprop fname 'PROCLAIMED-ARG-TYPES))))))
(defun get-return-type (fname &optional (env *cmp-env*))
(let ((x (cmp-env-search-ftype fname env)))
(if x
(let ((return-types (second x)))
(unless (eq return-types '*)
(values return-types t)))
(let ((fun (cmp-env-search-function fname env)))
(when (or (null fun) (and (fun-p fun) (fun-global fun)))
(si:get-sysprop fname 'PROCLAIMED-RETURN-TYPE))))))
(ext:if-let ((x (cmp-env-search-ftype fname env)))
(let ((return-types (second x)))
(unless (eq return-types '*)
(values return-types t)))
(let ((fun (cmp-env-search-function fname env)))
(when (or (null fun) (and (fun-p fun) (fun-global fun)))
(si:get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))))
(defun get-local-arg-types (fun &optional (env *cmp-env*))
(let ((x (cmp-env-search-ftype (fun-name fun) env)))
(if x
(values (first x) t)
(values nil nil))))
(ext:if-let ((x (cmp-env-search-ftype (fun-name fun) env)))
(values (first x) t)
(values nil nil)))
(defun get-local-return-type (fun &optional (env *cmp-env*))
(let ((x (cmp-env-search-ftype (fun-name fun) env)))
(if x
(values (second x) t)
(values nil nil))))
(ext:if-let ((x (cmp-env-search-ftype (fun-name fun) env)))
(values (second x) t)
(values nil nil)))
(defun get-proclaimed-narg (fun &optional (env *cmp-env*))
(multiple-value-bind (arg-list found)

29
src/cmp/cmpenv-proclaim.lsp
View file

@ -25,17 +25,16 @@
(in-package #-ecl-new "COMPILER" #+ecl-new "C-ENV")
#-:CCL
(defun proclaim (decl &aux decl-name)
(unless (listp decl)
(error "The proclamation specification ~s is not a list" decl))
(case (setf decl-name (car decl))
(SPECIAL
(cl:SPECIAL
(dolist (var (cdr decl))
(if (symbolp var)
(sys:*make-special var)
(error "Syntax error in proclamation ~s" decl))))
(OPTIMIZE
(cl:OPTIMIZE
(dolist (x (cdr decl))
(when (symbolp x) (setq x (list x 3)))
(if (or (not (consp x))
@ -50,11 +49,11 @@
(SPEED (setq *speed* (second x)))
(COMPILATION-SPEED (setq *speed* (- 3 (second x))))
(t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
(TYPE
(cl:TYPE
(if (consp (cdr decl))
(proclaim-var (second decl) (cddr decl))
(error "Syntax error in proclamation ~s" decl)))
(FTYPE
(cl:FTYPE
(if (atom (rest decl))
(error "Syntax error in proclamation ~a" decl)
(multiple-value-bind (type-name args)
@ -64,16 +63,16 @@
(proclaim-function v args))
(error "In an FTYPE proclamation, found ~A which is not a function type."
(second decl))))))
(INLINE
(cl:INLINE
(proclaim-inline (cdr decl)))
(NOTINLINE
(cl:NOTINLINE
(proclaim-notinline (cdr decl)))
((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE)
((OBJECT cl:IGNORE cl:DYNAMIC-EXTENT cl:IGNORABLE)
;; FIXME! IGNORED!
(dolist (var (cdr decl))
(unless (si::valid-function-name-p var)
(error "Not a valid function name ~s in ~s proclamation" var decl-name))))
(DECLARATION
(cl:DECLARATION
(validate-alien-declaration (rest decl) #'error)
(setf si::*alien-declarations* (append (rest decl) si:*alien-declarations*)))
(SI::C-EXPORT-FNAME
@ -91,12 +90,12 @@
(si:put-sysprop lisp-name 'Lfun c-name))))
(t
(error "Syntax error in proclamation ~s" decl)))))
((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER COMPILED-FUNCTION
COMPLEX CONS DOUBLE-FLOAT EXTENDED-CHAR FIXNUM FLOAT HASH-TABLE INTEGER KEYWORD LIST
LONG-FLOAT NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO RATIONAL
READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR
SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING
SYMBOL T VECTOR SIGNED-BYTE UNSIGNED-BYTE FUNCTION)
((cl:ARRAY cl:ATOM cl:BASE-CHAR cl:BIGNUM cl:BIT cl:BIT-VECTOR cl:CHARACTER cl:COMPILED-FUNCTION
cl:COMPLEX cl:CONS cl:DOUBLE-FLOAT cl:EXTENDED-CHAR cl:FIXNUM cl:FLOAT cl:HASH-TABLE cl:INTEGER cl:KEYWORD cl:LIST
cl:LONG-FLOAT cl:NIL cl:NULL cl:NUMBER cl:PACKAGE cl:PATHNAME cl:RANDOM-STATE cl:RATIO cl:RATIONAL
cl:READTABLE cl:SEQUENCE cl:SHORT-FLOAT cl:SIMPLE-ARRAY cl:SIMPLE-BIT-VECTOR
cl:SIMPLE-STRING cl:SIMPLE-VECTOR cl:SINGLE-FLOAT cl:STANDARD-CHAR cl:STREAM cl:STRING
cl:SYMBOL cl:T cl:VECTOR cl:SIGNED-BYTE cl:UNSIGNED-BYTE cl:FUNCTION)
(proclaim-var decl-name (cdr decl)))
(otherwise
(cond ((member (car decl) si:*alien-declarations*))

2
src/cmp/cmpmac.lsp
View file

@ -61,7 +61,7 @@
(cons (incf *last-label*) t))
(defun labelp (x)
(and (consp x) (integerp (si::cons-car x))))
(and (consp x) (integerp (si:cons-car x))))
(defun maybe-next-label ()
(if (labelp *exit*)

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

@ -40,11 +40,11 @@
(expand-simple-optimizer (rest whole) args inline-form env)
whole)))))
(defmacro cons-car (x)
(defmacro si:cons-car (x)
`(ffi:c-inline (,x) (:object) :object "ECL_CONS_CAR(#0)"
:one-liner t :side-effects nil))
(defmacro cons-cdr (x)
(defmacro si:cons-cdr (x)
`(ffi:c-inline (,x) (:object) :object "ECL_CONS_CDR(#0)"
:one-liner t :side-effects nil))
;;;
@ -139,9 +139,9 @@
(declare (:read-only ,@vars)) ; Beppe
(optional-type-check ,saved-place list)
(when ,saved-place
(let ((,store-var (cons-cdr ,saved-place)))
(let ((,store-var (si:cons-cdr ,saved-place)))
(declare (:read-only ,store-var))
,store-form
(setq ,saved-place (cons-car ,saved-place))))
(setq ,saved-place (si:cons-car ,saved-place))))
,saved-place)))
whole))

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

@ -61,7 +61,7 @@
;; Fixnum iterators are always fine
(aref %seq %iterator)
;; Error check in case we may have been passed an improper list
(cons-car (checked-value cons %iterator))))))
(si:cons-car (checked-value cons %iterator))))))
#+(or)
(define-compiler-macro si::seq-iterator-next (seq iterator)
@ -74,7 +74,7 @@
(declare (fixnum %iterator))
(and (< %iterator (length (truly-the vector %seq)))
%iterator))
(cons-cdr %iterator)))))
(si:cons-cdr %iterator)))))
(defmacro do-in-seq ((%elt %sequence &key %start %end end output) &body body)
(ext:with-unique-names (%iterator %counter)
@ -102,10 +102,10 @@
;;;
(defmacro do-in-list ((%elt %sublist %list &rest output) &body body)
`(do* ((,%sublist ,%list (cons-cdr ,%sublist)))
`(do* ((,%sublist ,%list (si:cons-cdr ,%sublist)))
((null ,%sublist) ,@output)
(let* ((,%sublist (optional-type-check ,%sublist cons))
(,%elt (cons-car ,%sublist)))
(,%elt (si:cons-car ,%sublist)))
,@body)))
(defmacro define-seq-compiler-macro (name lambda-list &body body)
@ -184,7 +184,7 @@
(ext:with-unique-names (%sublist %elt %car)
`(do-in-list (,%elt ,%sublist ,%list)
(when ,%elt
(let ((,%car (cons-car (optional-type-check ,%elt cons))))
(let ((,%car (si:cons-car (optional-type-check ,%elt cons))))
(when ,(funcall test-function %value
(funcall key-function %car))
(return ,%elt)))))))

2
src/cmp/cmppackage.lsp
View file

@ -16,7 +16,7 @@
(defpackage #:c
(:nicknames #:compiler)
(:use #:ffi #:ext #+threads #:mp #:cl)
(:use #:cl #:ext)
(:export
;; Flags controlling the compiler behavior.
#:*compiler-break-enable*

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

@ -30,7 +30,7 @@
(c1var form)))
(t (c1var form))))
((consp form)
(cmpck (not (si::proper-list-p form))
(cmpck (not (si:proper-list-p form))
"Improper list found in lisp form~%~A" form)
(let ((fun (car form)))
(cond ((let ((fd (gethash fun *c1-dispatch-table*)))
@ -129,7 +129,7 @@
x)))
((eq val nil) (c1nil))
((eq val t) (c1t))
((sys::fixnump val)
((ext:fixnump val)
(make-c1form* 'LOCATION :type 'FIXNUM :args (list 'FIXNUM-VALUE val)))
((characterp val)
(make-c1form* 'LOCATION :type 'CHARACTER
@ -164,13 +164,13 @@
(elt-type (ext:sse-pack-element-type value)))
(multiple-value-bind (wrapper rtype)
(case elt-type
(single-float (values "_mm_castsi128_ps" :float-sse-pack))
(double-float (values "_mm_castsi128_pd" :double-sse-pack))
(otherwise (values "" :int-sse-pack)))
`(c-inline () () ,rtype
,(format nil "~A(_mm_setr_epi8(~{~A~^,~}))"
wrapper (coerce bytes 'list))
:one-liner t :side-effects nil))))
(cl:single-float (values "_mm_castsi128_ps" :float-sse-pack))
(cl:double-float (values "_mm_castsi128_pd" :double-sse-pack))
(otherwise (values "" :int-sse-pack)))
`(ffi:c-inline () () ,rtype
,(format nil "~A(_mm_setr_epi8(~{~A~^,~}))"
wrapper (coerce bytes 'list))
:one-liner t :side-effects nil))))
(defun c1if (args)
(check-args-number 'IF args 2 3)

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

@ -18,7 +18,7 @@
;;; cmppass2-ffi and pushes directly to a backend-specific variable.
#+ (or)
(defun c1clines (args)
(make-c1form* 'clines :args args))
(make-c1form* 'ffi:clines :args args))
(defun c1c-inline (args)
;; We are on the safe side by assuming that the form has side effects
@ -29,23 +29,22 @@
args
(unless (= (length arguments) (length arg-types))
(cmperr "In a C-INLINE form the number of declare arguments and the number of supplied ones do not match:~%~S"
`(C-INLINE ,@args)))
`(ffi:c-inline ,@args)))
;; We cannot handle :cstrings as input arguments. :cstrings are
;; null-terminated strings, but not all of our lisp strings will
;; be null terminated. In particular, those with a fill pointer
;; will not.
(let ((ndx (position :cstring arg-types)))
(when ndx
(let* ((var (gensym))
(arguments (copy-list arguments))
(value (elt arguments ndx)))
(setf (elt arguments ndx) var
(elt arg-types ndx) :char*)
(return-from c1c-inline
(c1expr
`(ffi::with-cstring (,var ,value)
(c-inline ,arguments ,arg-types ,output-type ,c-expression
,@rest)))))))
(ext:when-let ((ndx (position :cstring arg-types)))
(let* ((var (gensym))
(arguments (copy-list arguments))
(value (elt arguments ndx)))
(setf (elt arguments ndx) var
(elt arg-types ndx) :char*)
(return-from c1c-inline
(c1expr
`(ffi::with-cstring (,var ,value)
(ffi:c-inline ,arguments ,arg-types ,output-type ,c-expression
,@rest))))))
;; Find out the output types of the inline form. The syntax is rather relaxed
;; output-type = lisp-type | c-type | (values {lisp-type | c-type}*)
(flet ((produce-type-pair (type)
@ -69,13 +68,13 @@
(listp arg-types)
(stringp c-expression))
(cmperr "C-INLINE: syntax error in ~S"
(list* 'c-inline args)))
(list* 'ffi:c-inline args)))
(unless (= (length arguments)
(length arg-types))
(cmperr "C-INLINE: wrong number of arguments in ~S"
(list* 'c-inline args)))
(list* 'ffi:c-inline args)))
(let* ((arguments (mapcar #'c1expr arguments))
(form (make-c1form* 'C-INLINE :type output-type
(form (make-c1form* 'ffi:c-inline :type output-type
:side-effects side-effects
:args arguments arg-types
output-rep-type

26
src/cmp/cmppass1-stack.lsp
View file

@ -30,13 +30,13 @@
:args body)))
(defun c1innermost-stack-frame (args)
`(c-inline () () :object "_ecl_inner_frame"
:one-liner t :side-effects nil))
`(ffi:c-inline () () :object "_ecl_inner_frame"
:one-liner t :side-effects nil))
(defun c1stack-push (args)
`(progn
(c-inline ,args (t t) :void "ecl_stack_frame_push(#0,#1)"
:one-liner t :side-effects t)
(ffi:c-inline ,args (t t) :void "ecl_stack_frame_push(#0,#1)"
:one-liner t :side-effects t)
1))
(defun c1stack-push-values (args)
@ -45,16 +45,16 @@
(make-c1form* 'STACK-PUSH-VALUES :type '(VALUES)
:args
(c1expr form)
(c1expr `(c-inline (,frame-var) (t)
:void "ecl_stack_frame_push_values(#0)"
:one-liner t :side-effects t)))))
(c1expr `(ffi:c-inline (,frame-var) (t)
:void "ecl_stack_frame_push_values(#0)"
:one-liner t :side-effects t)))))
(defun c1stack-pop (args)
`(c-inline ,args (t) (values &rest t)
"cl_env_copy->values[0]=ecl_stack_frame_pop_values(#0);"
:one-liner nil :side-effects t))
`(ffi:c-inline ,args (t) (values &rest t)
"cl_env_copy->values[0]=ecl_stack_frame_pop_values(#0);"
:one-liner nil :side-effects t))
(defun c1apply-from-stack-frame (args)
`(c-inline ,args (t t) (values &rest t)
"cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);"
:one-liner nil :side-effects t))
`(ffi:c-inline ,args (t t) (values &rest t)
"cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);"
:one-liner nil :side-effects t))

2
src/cmp/cmppass2-eval.lsp
View file

@ -199,7 +199,7 @@
(when (and (eq *destination* 'RETURN-OBJECT)
(rest forms)
(consp *current-form*)
(eq 'DEFUN (first *current-form*)))
(eq 'cl:DEFUN (first *current-form*)))
(cmpwarn "Trying to return multiple values. ~
~%;But ~a was proclaimed to have single value.~
~%;Only first one will be assured."

24
src/cmp/cmppass2-ffi.lsp
View file

@ -113,7 +113,7 @@
t
(case (first loc)
((CALL CALL-LOCAL) NIL)
((C-INLINE) (not (fifth loc))) ; side effects?
((ffi:c-inline) (not (fifth loc))) ; side effects?
(otherwise t))))
(defun loc-type (loc)
@ -132,10 +132,10 @@
(CSFLOAT-VALUE 'SI:COMPLEX-SINGLE-FLOAT)
(CDFLOAT-VALUE 'SI:COMPLEX-DOUBLE-FLOAT)
(CLFLOAT-VALUE 'SI:COMPLEX-LONG-FLOAT)
(C-INLINE (let ((type (first (second loc))))
(cond ((and (consp type) (eq (first type) 'VALUES)) T)
((lisp-type-p type) type)
(t (rep-type->lisp-type type)))))
(FFI:C-INLINE (let ((type (first (second loc))))
(cond ((and (consp type) (eq (first type) 'VALUES)) T)
((lisp-type-p type) type)
(t (rep-type->lisp-type type)))))
(BIND (var-type (second loc)))
(LCL (or (third loc) T))
(THE (second loc))
@ -159,10 +159,10 @@
(CSFLOAT-VALUE :csfloat)
(CDFLOAT-VALUE :cdfloat)
(CLFLOAT-VALUE :clfloat)
(C-INLINE (let ((type (first (second loc))))
(cond ((and (consp type) (eq (first type) 'VALUES)) :object)
((lisp-type-p type) (lisp-type->rep-type type))
(t type))))
(FFI:C-INLINE (let ((type (first (second loc))))
(cond ((and (consp type) (eq (first type) 'VALUES)) :object)
((lisp-type-p type) (lisp-type->rep-type type))
(t type))))
(BIND (var-rep-type (second loc)))
(LCL (lisp-type->rep-type (or (third loc) T)))
((JUMP-TRUE JUMP-FALSE) :bool)
@ -378,9 +378,9 @@
;; place where the value is used.
(when one-liner
(return-from produce-inline-loc
`(C-INLINE ,output-rep-type ,c-expression ,coerced-arguments ,side-effects
,(if (equalp output-rep-type '((VALUES &REST T)))
'VALUES NIL))))
`(ffi:c-inline ,output-rep-type ,c-expression ,coerced-arguments ,side-effects
,(if (equalp output-rep-type '((VALUES &REST T)))
'VALUES NIL))))
;; If the output is a in the VALUES vector, just write down the form and output
;; the location of the data.

16
src/cmp/cmppass2-loc.lsp
View file

@ -32,7 +32,7 @@
;;; ( FRAME ndx ) variable in local frame stack
;;; ( CALL-NORMAL fun locs 1st-type ) similar as CALL, but number of arguments is fixed
;;; ( CALL-INDIRECT fun narg args) similar as CALL, but unknown function
;;; ( C-INLINE output-type fun/string locs side-effects output-var )
;;; ( FFI:C-INLINE output-type fun/string locs side-effects output-var )
;;; ( COERCE-LOC representation-type location)
;;; ( FDEFINITION vv-index )
;;; ( MAKE-CCLOSURE cfun )
@ -107,8 +107,8 @@
(defun uses-values (loc)
(and (consp loc)
(or (member (car loc) '(CALL CALL-NORMAL CALL-INDIRECT) :test #'eq)
(and (eq (car loc) 'C-INLINE)
(eq (sixth loc) 'VALUES)))))
(and (eq (car loc) 'ffi:C-INLINE)
(eq (sixth loc) 'cl:VALUES)))))
(defun loc-immediate-value-p (loc)
(cond ((eq loc t)
@ -226,7 +226,7 @@
(loc-refers-to-special (third loc)))
((eq (setf loc (first loc)) 'BIND)
t)
((eq loc 'C-INLINE)
((eq loc 'ffi:C-INLINE)
t) ; We do not know, so guess yes
(t nil)))
@ -299,12 +299,12 @@
((member (setf name (first loc)) '(CALL CALL-NORMAL CALL-INDIRECT)
:test #'eq)
t)
((eq name 'THE)
((eq name 'cl:THE)
(loc-with-side-effects-p (third loc)))
((eq name 'FDEFINITION)
((eq name 'cl:FDEFINITION)
(policy-global-function-checking))
((eq name 'C-INLINE)
(or (eq (sixth loc) 'VALUES) ;; Uses VALUES
((eq name 'ffi:C-INLINE)
(or (eq (sixth loc) 'cl:VALUES) ;; Uses VALUES
(fifth loc))))) ;; or side effects
(defun set-trash-loc (loc)

2
src/cmp/cmpstructures.lsp
View file

@ -61,7 +61,7 @@
(t
`(,args ',structure-type ,slot-index)))))))
(define-compiler-macro si::structure-ref (&whole whole object structure-name index
(define-compiler-macro si:structure-ref (&whole whole object structure-name index
&environment env)
(if (and (policy-inline-slot-access env)
(constantp structure-name env)

246
src/cmp/cmptables.lsp
View file

@ -19,55 +19,55 @@
(defconstant +all-c1-forms+
'((LOCATION loc :pure :single-valued)
(VAR var :single-valued)
(SETQ var value-c1form :side-effects)
(PSETQ var-list value-c1form-list :side-effects)
(BLOCK blk-var progn-c1form :pure)
(PROGN body :pure)
(PROGV symbols values form :side-effects)
(TAGBODY tag-var tag-body :pure)
(RETURN-FROM blk-var return-type value :side-effects)
(FUNCALL fun-value (arg-value*) :side-effects)
(cl:SETQ var value-c1form :side-effects)
(cl:PSETQ var-list value-c1form-list :side-effects)
(cl:BLOCK blk-var progn-c1form :pure)
(cl:PROGN body :pure)
(cl:PROGV symbols values form :side-effects)
(cl:TAGBODY tag-var tag-body :pure)
(cl:RETURN-FROM blk-var return-type value :side-effects)
(cl:FUNCALL fun-value (arg-value*) :side-effects)
(CALL-LOCAL obj-fun (arg-value*) :side-effects)
(CALL-GLOBAL fun-name (arg-value*))
(CATCH catch-value body :side-effects)
(UNWIND-PROTECT protected-c1form body :side-effects)
(THROW catch-value output-value :side-effects)
(GO tag-var return-type :side-effects)
(C-INLINE (arg-c1form*)
(cl:CATCH catch-value body :side-effects)
(cl:UNWIND-PROTECT protected-c1form body :side-effects)
(cl:THROW catch-value output-value :side-effects)
(cl:GO tag-var return-type :side-effects)
(ffi:C-INLINE (arg-c1form*)
(arg-type-symbol*)
output-rep-type
c-expression-string
side-effects-p
one-liner-p)
(C-PROGN variables forms)
(ffi:C-PROGN variables forms)
(LOCALS local-fun-list body labels-p :pure)
(IF fmla-c1form true-c1form false-c1form :pure)
(cl:IF fmla-c1form true-c1form false-c1form :pure)
(FMLA-NOT fmla-c1form :pure)
(FMLA-AND * :pure)
(FMLA-OR * :pure)
(LAMBDA lambda-list doc body-c1form)
(LET* vars-list var-init-c1form-list decl-body-c1form :pure)
(VALUES values-c1form-list :pure)
(MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects)
(MULTIPLE-VALUE-BIND vars-list init-c1form body :pure)
(COMPILER-LET symbols values body)
(FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued)
(RPLACD (dest-c1form value-c1form) :side-effects)
(cl:LAMBDA lambda-list doc body-c1form)
(cl:LET* vars-list var-init-c1form-list decl-body-c1form :pure)
(cl:VALUES values-c1form-list :pure)
(cl:MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects)
(cl:MULTIPLE-VALUE-BIND vars-list init-c1form body :pure)
(ext:COMPILER-LET symbols values body)
(cl:FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued)
(cl:RPLACD (dest-c1form value-c1form) :side-effects)
(SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure)
(SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects)
(WITH-STACK body :side-effects)
(STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects)
(STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects)
(ORDINARY c1form :pure)
(LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued)
(cl:LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued)
(SI:FSET function-object vv-loc macro-p pprint-p lambda-form
:side-effects)
(MAKE-FORM vv-loc value-c1form :side-effects)
(INIT-FORM vv-loc value-c1form :side-effects)
(EXT:COMPILER-TYPECASE var expressions)
(CHECKED-VALUE type value-c1form let-form))))
(ext:COMPILER-TYPECASE var expressions)
(ext:CHECKED-VALUE type value-c1form let-form))))
(defconstant +c1-form-hash+
#.(loop with hash = (make-hash-table :size 128 :test #'eq)
@ -86,47 +86,47 @@
finally (return hash)))
(defconstant +c1-dispatch-alist+
'((block . c1block) ; c1special
(return-from . c1return-from) ; c1special
(funcall . c1funcall) ; c1
(catch . c1catch) ; c1special
(unwind-protect . c1unwind-protect) ; c1special
(throw . c1throw) ; c1special
'((cl:block . c1block) ; c1special
(cl:return-from . c1return-from) ; c1special
(cl:funcall . c1funcall) ; c1
(cl:catch . c1catch) ; c1special
(cl:unwind-protect . c1unwind-protect) ; c1special
(cl:throw . c1throw) ; c1special
(ffi:defcallback . c1-defcallback) ; c1
(progn . c1progn) ; c1special
(cl:progn . c1progn) ; c1special
(ext:with-backend . c1with-backend) ; c1special
(ffi:clines . c1clines) ; c1special
(ffi:c-inline . c1c-inline) ; c1special
(ffi:c-progn . c1c-progn) ; c1special
(flet . c1flet) ; c1special
(labels . c1labels) ; c1special
(locally . c1locally) ; c1special
(macrolet . c1macrolet) ; c1special
(symbol-macrolet . c1symbol-macrolet) ; c1special
(cl:flet . c1flet) ; c1special
(cl:labels . c1labels) ; c1special
(cl:locally . c1locally) ; c1special
(cl:macrolet . c1macrolet) ; c1special
(cl:symbol-macrolet . c1symbol-macrolet) ; c1special
(if . c1if) ; c1special
(not . c1not) ; c1special
(and . c1and) ; c1special
(or . c1or) ; c1special
(cl:if . c1if) ; c1special
(cl:not . c1not) ; c1special
(cl:and . c1and) ; c1special
(cl:or . c1or) ; c1special
(let . c1let) ; c1special
(let* . c1let*) ; c1special
(cl:let . c1let) ; c1special
(cl:let* . c1let*) ; c1special
(multiple-value-call . c1multiple-value-call) ; c1special
(multiple-value-prog1 . c1multiple-value-prog1) ; c1special
(values . c1values) ; c1
(multiple-value-setq . c1multiple-value-setq) ; c1
(multiple-value-bind . c1multiple-value-bind) ; c1
(cl:multiple-value-call . c1multiple-value-call) ; c1special
(cl:multiple-value-prog1 . c1multiple-value-prog1) ; c1special
(cl:values . c1values) ; c1
(cl:multiple-value-setq . c1multiple-value-setq) ; c1
(cl:multiple-value-bind . c1multiple-value-bind) ; c1
(ext:compiler-typecase . c1compiler-typecase) ; c1special
(checked-value . c1checked-value) ; c1special
(ext:checked-value . c1checked-value) ; c1special
(quote . c1quote) ; c1special
(function . c1function) ; c1special
(the . c1the) ; c1special
(cl:quote . c1quote) ; c1special
(cl:function . c1function) ; c1special
(cl:the . c1the) ; c1special
(ext:truly-the . c1truly-the) ; c1special
(eval-when . c1eval-when) ; c1special
(declare . c1declare) ; c1special
(cl:eval-when . c1eval-when) ; c1special
(cl:declare . c1declare) ; c1special
(ext:compiler-let . c1compiler-let) ; c1special
(with-stack . c1with-stack) ; c1
@ -134,30 +134,30 @@
(stack-push . c1stack-push) ; c1
(stack-push-values . c1stack-push-values) ; c1
(stack-pop . c1stack-pop) ; c1
(si::apply-from-stack-frame . c1apply-from-stack-frame) ; c1
(si:apply-from-stack-frame . c1apply-from-stack-frame) ; c1
(tagbody . c1tagbody) ; c1special
(go . c1go) ; c1special
(cl:tagbody . c1tagbody) ; c1special
(cl:go . c1go) ; c1special
(setq . c1setq) ; c1special
(progv . c1progv) ; c1special
(psetq . c1psetq) ; c1special
(cl:setq . c1setq) ; c1special
(cl:progv . c1progv) ; c1special
(cl:psetq . c1psetq) ; c1special
(load-time-value . c1load-time-value) ; c1
(cl:load-time-value . c1load-time-value) ; c1
(apply . c1apply) ; c1
(cl:apply . c1apply) ; c1
))
(defconstant +t1-dispatch-alist+
'((ext:with-backend . c1with-backend) ; t1
(defmacro . t1defmacro)
(cl:defmacro . t1defmacro)
(si:compiler-let . c1compiler-let)
(eval-when . c1eval-when)
(progn . c1progn)
(macrolet . c1macrolet)
(locally . c1locally)
(symbol-macrolet . c1symbol-macrolet)
(cl:eval-when . c1eval-when)
(cl:progn . c1progn)
(cl:macrolet . c1macrolet)
(cl:locally . c1locally)
(cl:symbol-macrolet . c1symbol-macrolet)
(si:fset . t1fset)
))
@ -166,12 +166,12 @@
(jump-true . set-jump-true)
(jump-false . set-jump-false)
(values . set-values-loc)
(cl:values . set-values-loc)
(value0 . set-value0-loc)
(return . set-return-loc)
(cl:return . set-return-loc)
(trash . set-trash-loc)
(the . set-the-loc)
(cl:the . set-the-loc)
))
(defconstant +wt-loc-dispatch-alist+
@ -193,117 +193,117 @@
(character-value . wt-character)
(value . wt-value)
(keyvars . wt-keyvars)
(the . wt-the)
(cl:the . wt-the)
(fdefinition . wt-fdefinition)
(cl:fdefinition . wt-fdefinition)
(make-cclosure . wt-make-closure)
(structure-ref . wt-structure-ref)
(si:structure-ref . wt-structure-ref)
(nil . "ECL_NIL")
(t . "ECL_T")
(return . "value0")
(values . "cl_env_copy->values[0]")
(cl:nil . "ECL_NIL")
(cl:t . "ECL_T")
(cl:return . "value0")
(cl:values . "cl_env_copy->values[0]")
(va-arg . "va_arg(args,cl_object)")
(cl-va-arg . "ecl_va_arg(args)")
(value0 . "value0")
))
(defconstant +c2-dispatch-alist+
'((block . c2block)
(return-from . c2return-from)
(funcall . c2funcall)
'((cl:block . c2block)
(cl:return-from . c2return-from)
(cl:funcall . c2funcall)
(call-global . c2call-global)
(catch . c2catch)
(unwind-protect . c2unwind-protect)
(throw . c2throw)
(progn . c2progn)
(cl:catch . c2catch)
(cl:unwind-protect . c2unwind-protect)
(cl:throw . c2throw)
(cl:progn . c2progn)
(ffi:c-inline . c2c-inline)
(ffi:c-progn . c2c-progn)
(locals . c2locals)
(call-local . c2call-local)
(if . c2if)
(cl:if . c2if)
(fmla-not . c2fmla-not)
(fmla-and . c2fmla-and)
(fmla-or . c2fmla-or)
(let* . c2let*)
(cl:let* . c2let*)
(values . c2values)
(multiple-value-setq . c2multiple-value-setq)
(multiple-value-bind . c2multiple-value-bind)
(cl:values . c2values)
(cl:multiple-value-setq . c2multiple-value-setq)
(cl:multiple-value-bind . c2multiple-value-bind)
(function . c2function)
(cl:function . c2function)
(si:compiler-let . c2compiler-let)
(with-stack . c2with-stack)
(stack-push-values . c2stack-push-values)
(tagbody . c2tagbody)
(go . c2go)
(cl:tagbody . c2tagbody)
(cl:go . c2go)
(var . c2var/location)
(location . c2var/location)
(setq . c2setq)
(progv . c2progv)
(psetq . c2psetq)
(cl:setq . c2setq)
(cl:progv . c2progv)
(cl:psetq . c2psetq)
(si:fset . c2fset)
(ext:compiler-typecase . c2compiler-typecase)
(checked-value . c2checked-value)
(ext:checked-value . c2checked-value)
))
(defconstant +t2-dispatch-alist+
'((si:compiler-let . t2compiler-let)
(progn . t2progn)
(cl:progn . t2progn)
(ordinary . t2ordinary)
(load-time-value . t2load-time-value)
(cl:load-time-value . t2load-time-value)
(make-form . t2make-form)
(init-form . t2init-form)
(si:fset . t2fset)
))
(defconstant +p1-dispatch-alist+
'((block . p1block)
(return-from . p1return-from)
'((cl:block . p1block)
(cl:return-from . p1return-from)
(call-global . p1call-global)
(call-local . p1call-local)
(catch . p1catch)
(throw . p1throw)
(if . p1if)
(cl:catch . p1catch)
(cl:throw . p1throw)
(cl:if . p1if)
(fmla-not . p1fmla-not)
(fmla-and . p1fmla-and)
(fmla-or . p1fmla-or)
(lambda . p1lambda)
(let* . p1let*)
(cl:lambda . p1lambda)
(cl:let* . p1let*)
(locals . p1locals)
(multiple-value-bind . p1multiple-value-bind)
(multiple-value-setq . p1multiple-value-setq)
(progn . p1progn)
(progv . p1progv)
(setq . p1setq)
(psetq . p1psetq)
(tagbody . p1tagbody)
(go . p1go)
(unwind-protect . p1unwind-protect)
(cl:multiple-value-bind . p1multiple-value-bind)
(cl:multiple-value-setq . p1multiple-value-setq)
(cl:progn . p1progn)
(cl:progv . p1progv)
(cl:setq . p1setq)
(cl:psetq . p1psetq)
(cl:tagbody . p1tagbody)
(cl:go . p1go)
(cl:unwind-protect . p1unwind-protect)
(ordinary . p1ordinary)
(sys::fset . p1fset)
(si:fset . p1fset)
(var . p1var)
(values . p1values)
(cl:values . p1values)
(location . p1trivial) ;; Some of these can be improved
(ffi:c-inline . p1trivial)
(ffi:c-progn . p1trivial)
(function . p1trivial)
(funcall . p1trivial)
(load-time-value . p1trivial)
(cl:function . p1trivial)
(cl:funcall . p1trivial)
(cl:load-time-value . p1trivial)
(make-form . p1trivial)
(init-form . p1trivial)
(c::with-stack . p1with-stack)
(c::stack-push-values . p1stack-push-values)
(ext:compiler-typecase . p1compiler-typecase)
(checked-value . p1checked-value)
(ext:checked-value . p1checked-value)
))
(defun make-dispatch-table (alist)

850
src/cmp/sysfun.lsp
View file

File diff suppressed because it is too large Load diff