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

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.

src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp

@@ -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*))))

src/cmp/cmpenv-fun.lsp

@@ -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)))

src/cmp/cmpfun.lsp

@@ -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))))

src/cmp/cmpmain.lsp

@@ -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."

src/cmp/cmpopt-constant.lsp

@@ -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)))))

src/cmp/cmppass1-call.lsp

@@ -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

src/cmp/cmppass1-special.lsp

@@ -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))

src/cmp/proclamations.lsp

@@ -44,24 +44,64 @@
 
 (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))
-          ((:predicate :pure)
-           (si:put-sysprop name 'pure t)
-           (si:put-sysprop name 'no-side-effects t))
-          ((:no-side-effects :reader)
-           (si:put-sysprop name 'no-side-effects t))
-          (otherwise
-           (error "Unknown property ~S in function proclamation for ~S"
-                  p name)))))
+        do (case p
+             (:no-sp-change
+              (put-property name 'no-sp-change t *static-proclamations*))
+             ((:predicate :pure)
+              (put-property name 'pure t *static-proclamations*)
+              (put-property name 'no-side-effects t *static-proclamations*))
+             ((:no-side-effects :reader)
+              (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+)
-   do (apply #'parse-function-proclamation i))
+(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))