mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-06 02:40:26 -08:00
Code Issues Projects Releases Packages Wiki Activity

cmp: move proclamations from system-properties into a compiler specific storage

Browse source 
This allows us to switch out the proclamations when cross-compiling so
that target specific functions are declared correctly.

This was a problem for cross compilation with mismatching thread
support, so we can now allow that.
This commit is contained in:
Marius Gerbershagen 2025-11-01 12:59:44 +01:00
parent c5f6cd0246
commit f099a9082a
8 changed files with 78 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -88,7 +88,7 @@
:arg-types arg-types
:exact-return-type exact-return-type
:multiple-values multiple-values
;; :side-effects (not (si:get-sysprop name 'no-side-effects))
;; :side-effects (function-may-have-side-effects name)
:one-liner one-liner
:expansion expansion)))
(push inline-info (gethash (list name safety) *inline-information*))))

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

@ -24,7 +24,7 @@
;;; The valid return type declaration is:
;;; (( VALUES {type}* )) or ( {type}* ).
(defun proclaim-function (fname decl)
(defun proclaim-function (fname decl &optional destination)
(if (si:valid-function-name-p fname)
(let* ((arg-types '*)
(return-types '*)
@ -43,12 +43,12 @@
(when (eq arg-types '())
(setf arg-types '(&optional)))
(if (eq arg-types '*)
(si:rem-sysprop fname 'PROCLAIMED-ARG-TYPES)
(si:put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types))
(rem-property fname 'PROCLAIMED-ARG-TYPES destination)
(put-property fname 'PROCLAIMED-ARG-TYPES arg-types destination))
(if (member return-types '(* (VALUES &rest t))
:test #'equalp)
(si:rem-sysprop fname 'PROCLAIMED-RETURN-TYPE)
(si:put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)))
(rem-property fname 'PROCLAIMED-RETURN-TYPE destination)
(put-property fname 'PROCLAIMED-RETURN-TYPE return-types destination)))
(warn "The function proclamation ~s ~s is not valid." fname decl)))
(defun add-function-declaration (fname ftype &optional (env *cmp-env*))
@ -68,7 +68,7 @@
(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))))))
(get-global-property fname 'PROCLAIMED-ARG-TYPES))))))
(defun get-return-type (fname &optional (env *cmp-env*))
(ext:if-let ((x (cmp-env-search-ftype fname env)))
@ -77,7 +77,7 @@
(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)))))
(get-global-property fname 'PROCLAIMED-RETURN-TYPE)))))
(defun get-local-arg-types (fun &optional (env *cmp-env*))
(ext:if-let ((x (cmp-env-search-ftype (fun-name fun) env)))

7
src/cmp/cmpfun.lsp
View file

@ -175,10 +175,3 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(if (and (symbolp name) (setf cname (si:get-sysprop name 'Lfun)))
(values cname t)
(values (next-cfun "L~D~A" name) nil))))
(defun function-may-have-side-effects (fname)
(not (si:get-sysprop fname 'no-side-effects)))
(defun function-may-change-sp (fname)
(not (or (si:get-sysprop fname 'no-side-effects)
(si:get-sysprop fname 'no-sp-change))))

2
src/cmp/cmpmain.lsp
View file

@ -355,7 +355,7 @@ from the C language code. NIL means \"do not create the file\"."
(error "Cannot cross compile as the target ECL version ~a does not match the host ECL version ~a"
*target-lisp-implementation-version* (lisp-implementation-version)))
(let* ((features-to-match '(#-unicode :unicode #-clos :clos
#-threads :threads #-dlopen :dlopen))
#-dlopen :dlopen))
(missing-features (intersection features-to-match *features*)))
(unless (null missing-features)
(warn "Cross compiling to a target with ~{~#[~;~(~a~)~;~(~a~) and ~(~a~)~:;~@{~(~a~)~#[~; and ~:;, ~]~}~]~} support from a host ECL which doesn't include these features is unsupported. Please use a host with matching feature set."

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

@ -17,7 +17,7 @@
(and (consp form)
(let ((head (car form)))
(or (member head '(IF OR AND NULL NOT PROGN))
(and (si:get-sysprop head 'pure)
(and (function-is-pure head)
(inline-possible head))))
(loop for c in (rest form)
always (constant-expression-p c env)))))

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

@ -251,7 +251,7 @@
:args (c1expr `(function ,fname)) forms fname :global)))
(defun c1call-constant-fold (fname forms)
(when (and (si:get-sysprop fname 'pure)
(when (and (function-is-pure fname)
(policy-evaluate-forms)
(inline-possible fname))
(handler-case

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

@ -67,7 +67,7 @@
(make-c1form* 'FUNCTION
:type 'FUNCTION
:sp-change (not (and (symbolp fun)
(si:get-sysprop fun 'NO-SP-CHANGE)))
(function-no-sp-change fun)))
:args fun)))
((and (consp fun) (member (car fun) '(LAMBDA EXT:LAMBDA-BLOCK)))
(cmpck (endp (cdr fun))

68
src/cmp/proclamations.lsp
View file

@ -44,25 +44,65 @@
(in-package "C")
(defun put-property (symbol property value collection)
(if collection
(setf (getf (gethash symbol collection) property) value)
(si:put-sysprop symbol property value)))
(defun rem-property (symbol property collection)
(if collection
(remf (gethash symbol collection) property)
(si:rem-sysprop symbol property)))
(let ((not-found (cons nil nil)))
(defun get-property (symbol property collection)
(if collection
(let ((value
(getf (gethash symbol collection) property not-found)))
(if (eq value not-found)
(values nil nil)
(values value t)))
(si:get-sysprop symbol property)))
(defun get-global-property (symbol property)
(let ((value (getf (gethash symbol *static-proclamations*)
property not-found)))
(if (eq value not-found)
(si:get-sysprop symbol property)
(values value t)))))
(defun function-is-pure (fname)
(get-property fname 'pure *static-proclamations*))
(defun function-may-have-side-effects (fname)
(not (get-property fname 'no-side-effects *static-proclamations*)))
(defun function-may-change-sp (fname)
(not (or (get-property fname 'no-side-effects *static-proclamations*)
(get-property fname 'no-sp-change *static-proclamations*))))
(defun function-no-sp-change (fname)
(get-property fname 'no-sp-change *static-proclamations*))
(defun parse-function-proclamation
(name arg-types return-type &rest properties)
(when (si:get-sysprop name 'proclaimed-arg-types)
(when (get-property name 'proclaimed-arg-types *static-proclamations*)
(warn "Duplicate proclamation for ~A" name))
(proclaim-function
name (list arg-types return-type))
(proclaim-function name (list arg-types return-type) *static-proclamations*)
(loop for p in properties
do (case p
(:no-sp-change
(si:put-sysprop name 'no-sp-change t))
(put-property name 'no-sp-change t *static-proclamations*))
((:predicate :pure)
(si:put-sysprop name 'pure t)
(si:put-sysprop name 'no-side-effects t))
(put-property name 'pure t *static-proclamations*)
(put-property name 'no-side-effects t *static-proclamations*))
((:no-side-effects :reader)
(si:put-sysprop name 'no-side-effects t))
(put-property name 'no-side-effects t *static-proclamations*))
(otherwise
(error "Unknown property ~S in function proclamation for ~S"
p name)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; AUXILIARY TYPES
;;
@ -1582,9 +1622,17 @@
(proclamation ext:non-negative-long-float-p (t) gen-bool :pure)
(proclamation ext:non-positive-long-float-p (t) gen-bool :pure)
(proclamation ext:positive-long-float-p (t) gen-bool :pure)
))
))) ; eval-when
(loop for i in '#.(mapcar #'rest +proclamations+)
(defun collect-proclamations ()
(let ((*static-proclamations* (make-hash-table :test 'equal :size 1024)))
(declare (special *static-proclamations*))
(loop for i in (mapcar #'rest +proclamations+)
do (apply #'parse-function-proclamation i))
*static-proclamations*))
) ; eval-when
;;; The declarations from proclamations.lsp are collected in
;;; *STATIC-PROCLAMATIONS* instead of the main system properties to
;;; allow for switching them out for cross compilation.
(defconfig *static-proclamations* #.(collect-proclamations))