From 7b565166797f37f04cd86d6b5065eaf9c955ffea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 25 Jan 2023 13:37:11 +0100 Subject: [PATCH 01/33] cosmetic: improve cmpenv comments to include the qualifier :declare --- src/c/compiler.d | 2 ++ src/cmp/cmpglobals.lsp | 4 +++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 097a93bc5..9be698e23 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -377,11 +377,13 @@ asm_op2c(cl_env_ptr env, int code, cl_object o) { * (:function function-name used-p [location]) | * (var-name {:special | nil} bound-p [location]) | * (symbol si::symbol-macro macro-function) | + * (:declare type arguments) | * SI:FUNCTION-BOUNDARY | * SI:UNWIND-PROTECT-BOUNDARY * (:declare declaration-arguments*) * macro-record = (function-name FUNCTION [| function-object]) | * (macro-name si::macro macro-function) | + * (:declare name declaration) | * SI:FUNCTION-BOUNDARY | * SI:UNWIND-PROTECT-BOUNDARY * diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 24c621179..f94604d0b 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -166,11 +166,13 @@ variable-record = (:block block-name) | (:function function-name) | (var-name {:special | nil} bound-p) | (symbol si::symbol-macro macro-function) | + (:declare type arguments) | SI:FUNCTION-BOUNDARY | SI:UNWIND-PROTECT-BOUNDARY macro-record = (function-name function) | - (macro-name si::macro macro-function) + (macro-name si::macro macro-function) | + (:declare name declaration) | SI:FUNCTION-BOUNDARY | SI:UNWIND-PROTECT-BOUNDARY -- GitLab From edb19dcf754873edb12bee8e74eaf14b5c0cbc0a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 25 Jan 2023 13:48:26 +0100 Subject: [PATCH 02/33] cmp: cleanup: remove unused special variables It is worth noting that *active-protection* and *pending-actions* are generally not used too (because *pending-actions* are never modified), but if we want to add some useful semantics to with-compilation-unit one day then we'll need both. --- src/cmp/cmpglobals.lsp | 12 ------------ src/cmp/cmpmac.lsp | 3 --- src/cmp/cmppass1-top.lsp | 1 - 3 files changed, 16 deletions(-) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index f94604d0b..3519d092c 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -45,7 +45,6 @@ (defvar *current-form* '|compiler preprocess|) (defvar *current-toplevel-form* '|compiler preprocess|) (defvar *compile-file-position* -1) -(defvar *first-error* t) (defvar *active-protection* nil) (defvar *pending-actions* nil) @@ -99,9 +98,6 @@ running the compiler. It may be updated by running ") (defvar *space* 0) (defvar *debug* 0) -;;; Emit automatic CHECK-TYPE forms for function arguments in lambda forms. -(defvar *automatic-check-type-in-lambda* t) - ;;; ;;; Compiled code uses the following kinds of variables: ;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl) @@ -125,7 +121,6 @@ running the compiler. It may be updated by running ") (defvar *aux-closure* nil) ; stack allocated closure needed for indirect calls (defvar *ihs-used-p* nil) ; function must be registered in IHS? -(defvar *next-cmacro* 0) ; holds the last cmacro number used. (defvar *next-cfun* 0) ; holds the last cfun used. ;;; @@ -136,8 +131,6 @@ running the compiler. It may be updated by running ") ;;; (defvar *tail-recursion-info* nil) -(defvar *allow-c-local-declaration* t) - ;;; --cmpexit.lsp-- ;;; ;;; *last-label* holds the label# of the last used label. @@ -278,10 +271,6 @@ lines are inserted, but the order is preserved") (defvar *compiler-constants* nil) ; a vector with all constants ; only used in COMPILE -(defvar *proclaim-fixed-args* nil) ; proclaim automatically functions - ; with fixed number of arguments. - ; watch out for multiple values. - (defvar *global-vars* nil) ; variables declared special (defvar *global-funs* nil) ; holds { fun }* (defvar *use-c-global* nil) ; honor si::c-global declaration @@ -324,7 +313,6 @@ be deleted if they have been opened with LoadLibrary.") (*cmp-env* nil) (*max-temp* 0) (*temp* 0) - (*next-cmacro* 0) (*next-cfun* 0) (*last-label* 0) (*load-objects* (make-hash-table :size 128 :test #'equal)) diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp index 2d8f12567..8c80c706a 100644 --- a/src/cmp/cmpmac.lsp +++ b/src/cmp/cmpmac.lsp @@ -53,9 +53,6 @@ (defun same-fname-p (name1 name2) (equal name1 name2)) -;;; from cmpenv.lsp -(defmacro next-cmacro () '(incf *next-cmacro*)) - ;;; from cmplabel.lsp (defun next-label () (cons (incf *last-label*) nil)) diff --git a/src/cmp/cmppass1-top.lsp b/src/cmp/cmppass1-top.lsp index afa374ad2..ee4fed445 100644 --- a/src/cmp/cmppass1-top.lsp +++ b/src/cmp/cmppass1-top.lsp @@ -27,7 +27,6 @@ (defun t1expr* (form &aux (*current-toplevel-form* (list* form *current-toplevel-form*)) (*current-form* form) - (*first-error* t) (*setjmps* 0)) (setq form (chk-symbol-macrolet form)) (when (consp form) -- GitLab From acd1dd3c07beda08244cab9bf831804804d81e69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Feb 2023 17:49:43 +0100 Subject: [PATCH 03/33] cmp: don't import symbols from the SYSTEM package Use proper package accessors instead. This was mostly already done. Removal of package imports make it easier to tell when symbols do not belong to cmp. --- src/cmp/cmpenv-api.lsp | 16 ++++++++-------- src/cmp/cmpenv-fun.lsp | 19 +++++++++---------- src/cmp/cmpglobals.lsp | 8 ++++---- src/cmp/cmpmain.lsp | 2 +- src/cmp/cmppackage.lsp | 6 +----- src/cmp/cmppass1-data.lsp | 6 +++--- src/cmp/cmppass2-data.lsp | 6 +++--- src/cmp/cmptables.lsp | 6 +++--- src/cmp/cmputil.lsp | 2 +- src/cmp/proclamations.lsp | 10 +++++----- 10 files changed, 38 insertions(+), 43 deletions(-) diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index 8967c1d64..e2c88b19c 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -53,9 +53,9 @@ the closure in let/flet forms for variables/functions it closes over." ,@record-def)) ,definition)))) ((and (listp record) (symbolp (car record))) - (cond ((eq (car record) 'si::macro) + (cond ((eq (car record) 'si:macro) (cmp-env-register-macro (cddr record) (cadr record) env)) - ((eq (car record) 'si::symbol-macro) + ((eq (car record) 'si:symbol-macro) (cmp-env-register-symbol-macro-function (cddr record) (cadr record) env)) (t (setf definition @@ -137,7 +137,7 @@ the closure in let/flet forms for variables/functions it closes over." (values)) (defun cmp-env-register-macro (name function &optional (env *cmp-env*)) - (push (list name 'si::macro function) + (push (list name 'si:macro function) (cmp-env-functions env)) env) @@ -154,7 +154,7 @@ the closure in let/flet forms for variables/functions it closes over." (defun cmp-env-register-symbol-macro-function (name function &optional (env *cmp-env*)) (when (or (constant-variable-p name) (special-variable-p name)) (cmperr "Cannot bind the special or constant variable ~A with symbol-macrolet." name)) - (push (list name 'si::symbol-macro function) + (push (list name 'si:symbol-macro function) (cmp-env-variables env)) env) @@ -211,12 +211,12 @@ the closure in let/flet forms for variables/functions it closes over." (when (member name (second record) :test #'eql) (setf found record) (return))) - ((eq name 'si::symbol-macro) - (when (eq (second record) 'si::symbol-macro) + ((eq name 'si:symbol-macro) + (when (eq (second record) 'si:symbol-macro) (setf found record)) (return)) (t - (when (not (eq (second record) 'si::symbol-macro)) + (when (not (eq (second record) 'si:symbol-macro)) (setf found record)) (return)))) (values (first (last found)) cfb unw))) @@ -228,7 +228,7 @@ the closure in let/flet forms for variables/functions it closes over." (cmp-env-search-variables :tag name env)) (defun cmp-env-search-symbol-macro (name &optional (env *cmp-env*)) - (cmp-env-search-variables name 'si::symbol-macro env)) + (cmp-env-search-variables name 'si:symbol-macro env)) (defun cmp-env-search-var (name &optional (env *cmp-env*)) (cmp-env-search-variables name t env)) diff --git a/src/cmp/cmpenv-fun.lsp b/src/cmp/cmpenv-fun.lsp index 479d31ab9..211426b97 100644 --- a/src/cmp/cmpenv-fun.lsp +++ b/src/cmp/cmpenv-fun.lsp @@ -72,7 +72,7 @@ (when may-be-global (let ((fun (cmp-env-search-function fname env))) (when (or (null fun) (and (fun-p fun) (fun-global fun))) - (sys:get-sysprop fname 'PROCLAIMED-ARG-TYPES))))))) + (si:get-sysprop fname 'PROCLAIMED-ARG-TYPES))))))) (defun get-return-type (fname &optional (env *cmp-env*)) (let ((x (cmp-env-search-ftype fname env))) @@ -82,7 +82,7 @@ (values return-types t))) (let ((fun (cmp-env-search-function fname env))) (when (or (null fun) (and (fun-p fun) (fun-global fun))) - (sys:get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))))) + (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))) @@ -131,30 +131,30 @@ (dolist (fun fname-list) (unless (si::valid-function-name-p fun) (error "Not a valid function name ~s in INLINE proclamation" fun)) - (unless (sys:get-sysprop fun 'INLINE) - (sys:put-sysprop fun 'INLINE t) - (sys:rem-sysprop fun 'NOTINLINE)))) + (unless (si:get-sysprop fun 'INLINE) + (si:put-sysprop fun 'INLINE t) + (si:rem-sysprop fun 'NOTINLINE)))) (defun proclaim-notinline (fname-list) (dolist (fun fname-list) (unless (si::valid-function-name-p fun) (error "Not a valid function name ~s in NOTINLINE proclamation" fun)) - (sys:rem-sysprop fun 'INLINE) - (sys:put-sysprop fun 'NOTINLINE t))) + (si:rem-sysprop fun 'INLINE) + (si:put-sysprop fun 'NOTINLINE t))) (defun declared-inline-p (fname &optional (env *cmp-env*)) (let* ((x (cmp-env-search-declaration 'inline env)) (flag (assoc fname x :test #'same-fname-p))) (if flag (cdr flag) - (sys:get-sysprop fname 'INLINE)))) + (si:get-sysprop fname 'INLINE)))) (defun declared-notinline-p (fname &optional (env *cmp-env*)) (let* ((x (cmp-env-search-declaration 'inline env)) (flag (assoc fname x :test #'same-fname-p))) (if flag (null (cdr flag)) - (sys:get-sysprop fname 'NOTINLINE)))) + (si:get-sysprop fname 'NOTINLINE)))) (defun inline-possible (fname &optional (env *cmp-env*)) (not (declared-notinline-p fname env))) @@ -176,4 +176,3 @@ ;; locally we don't keep the definition. `(eval-when (:load-toplevel :execute) (si:put-sysprop ',fname 'inline ',form)))) - diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 3519d092c..d66ba333b 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -158,13 +158,13 @@ variable-record = (:block block-name) | (:tag ({tag-name}*)) | (:function function-name) | (var-name {:special | nil} bound-p) | - (symbol si::symbol-macro macro-function) | + (symbol si:symbol-macro macro-function) | (:declare type arguments) | SI:FUNCTION-BOUNDARY | SI:UNWIND-PROTECT-BOUNDARY macro-record = (function-name function) | - (macro-name si::macro macro-function) | + (macro-name si:macro macro-function) | (:declare name declaration) | SI:FUNCTION-BOUNDARY | SI:UNWIND-PROTECT-BOUNDARY @@ -179,7 +179,7 @@ that compared with the bytecodes compiler, these records contain an additional variable, block, tag or function object at the end.") (defvar *cmp-env-root* - (cons nil (list (list '#:no-macro 'si::macro (constantly nil)))) + (cons nil (list (list '#:no-macro 'si:macro (constantly nil)))) "This is the common environment shared by all toplevel forms. It can only be altered by DECLAIM forms and it is used to initialize the value of *CMP-ENV*.") @@ -268,7 +268,7 @@ lines are inserted, but the order is preserved") (defvar *static-constants* nil) ; constants that can be built as C values ; holds { ( object c-variable constant ) }* -(defvar *compiler-constants* nil) ; a vector with all constants +(defvar si:*compiler-constants* nil) ; a vector with all constants ; only used in COMPILE (defvar *global-vars* nil) ; variables declared special diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index f3080a20f..2ff7cba39 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -745,7 +745,7 @@ compiled successfully, returns the pathname of the compiled file" (*package* *package*) (*compile-print* nil) (*print-pretty* nil) - (*compiler-constants* t)) + (si:*compiler-constants* t)) "Args: (name &optional definition) If DEFINITION is NIL, NAME must be the name of a not-yet-compiled function. diff --git a/src/cmp/cmppackage.lsp b/src/cmp/cmppackage.lsp index 0c4737ff0..7db57fce6 100644 --- a/src/cmp/cmppackage.lsp +++ b/src/cmp/cmppackage.lsp @@ -51,10 +51,6 @@ #:compiler-message-form ;; Other operators. #:install-c-compiler - #:update-compiler-features) - (:import-from #:si - #:get-sysprop #:put-sysprop #:rem-sysprop #:macro - #:*compiler-constants* #:register-global - #:cmp-env-register-macrolet #:compiler-let)) + #:update-compiler-features)) (ext:package-lock '#:cl nil) diff --git a/src/cmp/cmppass1-data.lsp b/src/cmp/cmppass1-data.lsp index 8f9be2886..1e9d2ff03 100644 --- a/src/cmp/cmppass1-data.lsp +++ b/src/cmp/cmppass1-data.lsp @@ -90,14 +90,14 @@ (when used-p (setf (vv-used-p vv) t)) (return-from add-object vv)) - (when (and (null *compiler-constants*) - (si::need-to-make-load-form-p object)) + (when (and (null si:*compiler-constants*) + (si:need-to-make-load-form-p object)) ;; All objects created with MAKE-LOAD-FORM go into the permanent storage to ;; prevent two non-eq instances of the same object in the permanent and ;; temporary storage from being created (we can't move objects from the ;; temporary into the permanent storage once they have been created). (setf load-form-p t permanent t)) - (let* ((test (if *compiler-constants* 'eq 'equal-with-circularity)) + (let* ((test (if si:*compiler-constants* 'eq 'equal-with-circularity)) (item (if permanent (find object *permanent-objects* :test test :key #'vv-value) (or (find object *permanent-objects* :test test :key #'vv-value) diff --git a/src/cmp/cmppass2-data.lsp b/src/cmp/cmppass2-data.lsp index a83a54d08..8574a8dd5 100644 --- a/src/cmp/cmppass2-data.lsp +++ b/src/cmp/cmppass2-data.lsp @@ -17,8 +17,8 @@ (in-package "COMPILER") (defun data-dump-array () - (cond (*compiler-constants* - (setf *compiler-constants* (concatenate 'vector (data-get-all-objects))) + (cond (si:*compiler-constants* + (setf si:*compiler-constants* (concatenate 'vector (data-get-all-objects))) "") #+externalizable ((plusp (data-size)) @@ -219,7 +219,7 @@ ;; fields. SSE uses always unboxed static constants. No reference is kept to ;; them -- it is thus safe to use them even on code that might be unloaded. (unless (or #+msvc t - *compiler-constants* + si:*compiler-constants* (and (not *use-static-constants-p*) #+sse2 (not (typep object 'ext:sse-pack))) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index e649bf883..94625be54 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -152,7 +152,7 @@ '((ext:with-backend . c1with-backend) ; t1 (defmacro . t1defmacro) - (compiler-let . c1compiler-let) + (si:compiler-let . c1compiler-let) (eval-when . c1eval-when) (progn . c1progn) (macrolet . c1macrolet) @@ -235,7 +235,7 @@ (multiple-value-bind . c2multiple-value-bind) (function . c2function) - (ext:compiler-let . c2compiler-let) + (si:compiler-let . c2compiler-let) (with-stack . c2with-stack) (stack-push-values . c2stack-push-values) @@ -256,7 +256,7 @@ )) (defconstant +t2-dispatch-alist+ - '((compiler-let . t2compiler-let) + '((si:compiler-let . t2compiler-let) (progn . t2progn) (ordinary . t2ordinary) (load-time-value . t2load-time-value) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 614e99700..3d5c438a9 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -517,7 +517,7 @@ keyword argument, the compiler-macro declines to provide an expansion. (setq lambda-list (nconc (ldiff lambda-list env) (cddr env)))) ;; 2. parse the remaining lambda-list (multiple-value-bind (reqs opts rest key-flag keywords allow-other-keys auxs) - (si::process-lambda-list lambda-list 'si::macro) + (si::process-lambda-list lambda-list 'si:macro) (when (and rest (or key-flag allow-other-keys)) (error "define-compiler-macro* can't deal with lambda-lists with both &key and &rest arguments")) ;; utility functions diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 97d663b0f..849258d6c 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -46,19 +46,19 @@ (defun parse-function-proclamation (name arg-types return-type &rest properties) - (when (sys:get-sysprop name 'proclaimed-arg-types) + (when (si:get-sysprop name 'proclaimed-arg-types) (warn "Duplicate proclamation for ~A" name)) (proclaim-function name (list arg-types return-type)) (loop for p in properties do (case p (:no-sp-change - (sys:put-sysprop name 'no-sp-change t)) + (si:put-sysprop name 'no-sp-change t)) ((:predicate :pure) - (sys:put-sysprop name 'pure t) - (sys:put-sysprop name 'no-side-effects t)) + (si:put-sysprop name 'pure t) + (si:put-sysprop name 'no-side-effects t)) ((:no-side-effects :reader) - (sys:put-sysprop name 'no-side-effects t)) + (si:put-sysprop name 'no-side-effects t)) (otherwise (error "Unknown property ~S in function proclamation for ~S" p name))))) -- GitLab From ee9e72e5aa4ffd8c670a1e97f5e71e34be035a0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Feb 2023 18:14:48 +0100 Subject: [PATCH 04/33] cmp: use cmutil extensions by invoking them with prefix ext --- src/cmp/cmpenv-declare.lsp | 2 +- src/cmp/cmppass1-data.lsp | 4 ++-- src/cmp/cmppass1-eval.lsp | 2 +- src/cmp/cmppass1-ffi.lsp | 2 +- src/cmp/cmppass2-data.lsp | 4 ++-- src/cmp/cmppass2-ffi.lsp | 2 +- src/cmp/cmppass2-top.lsp | 2 +- src/cmp/cmpprop.lsp | 2 +- src/cmp/cmputil.lsp | 2 +- 9 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/cmp/cmpenv-declare.lsp b/src/cmp/cmpenv-declare.lsp index a7b6c75bb..be2f63992 100644 --- a/src/cmp/cmpenv-declare.lsp +++ b/src/cmp/cmpenv-declare.lsp @@ -168,7 +168,7 @@ special variable declarations, as these have been extracted before." env))))) (defun symbol-macro-declaration-p (name type) - (when-let ((record (cmp-env-search-symbol-macro name))) + (ext:when-let ((record (cmp-env-search-symbol-macro name))) (let* ((expression (funcall record name nil))) (cmp-env-register-symbol-macro name `(the ,type ,expression))) t)) diff --git a/src/cmp/cmppass1-data.lsp b/src/cmp/cmppass1-data.lsp index 1e9d2ff03..89f57cc54 100644 --- a/src/cmp/cmppass1-data.lsp +++ b/src/cmp/cmppass1-data.lsp @@ -86,7 +86,7 @@ *permanent-data*)) &aux load-form-p) ;; FIXME add-static-constant is tied to the C target. - (when-let ((vv (add-static-constant object))) + (ext:when-let ((vv (add-static-constant object))) (when used-p (setf (vv-used-p vv) t)) (return-from add-object vv)) @@ -147,7 +147,7 @@ ;; can reuse keywords lists from other functions when they coincide with ours. ;; We search for keyword lists that are similar. However, the list *OBJECTS* ;; contains elements in decreasing order!!! - (if-let ((x (search keywords *permanent-objects* + (ext:if-let ((x (search keywords *permanent-objects* :test #'(lambda (k record) (eq k (vv-value record)))))) (elt *permanent-objects* x) (prog1 (add-object (pop keywords) :duplicate t :permanent t) diff --git a/src/cmp/cmppass1-eval.lsp b/src/cmp/cmppass1-eval.lsp index 02aba9676..55d17cd09 100644 --- a/src/cmp/cmppass1-eval.lsp +++ b/src/cmp/cmppass1-eval.lsp @@ -120,7 +120,7 @@ (defun c1constant-value (val &key always only-small-values) (cond ;; FIXME includes in c1 pass. - ((when-let ((x (assoc val *optimizable-constants*))) + ((ext:when-let ((x (assoc val *optimizable-constants*))) (pushnew "#include " *clines-string-list*) (pushnew "#include " *clines-string-list*) (setf x (cdr x)) diff --git a/src/cmp/cmppass1-ffi.lsp b/src/cmp/cmppass1-ffi.lsp index d3c19ae3e..45cca79be 100644 --- a/src/cmp/cmppass1-ffi.lsp +++ b/src/cmp/cmppass1-ffi.lsp @@ -134,7 +134,7 @@ (:void . "ECL_FFI_VOID"))) (defun foreign-elt-type-code (type) - (if-let ((x (assoc type +foreign-elt-type-codes+))) + (ext:if-let ((x (assoc type +foreign-elt-type-codes+))) (cdr x) (cmperr "DEFCALLBACK: ~a is not a valid elementary FFI type." type))) diff --git a/src/cmp/cmppass2-data.lsp b/src/cmp/cmppass2-data.lsp index 8574a8dd5..c287d05d6 100644 --- a/src/cmp/cmppass2-data.lsp +++ b/src/cmp/cmppass2-data.lsp @@ -224,9 +224,9 @@ #+sse2 (not (typep object 'ext:sse-pack))) (not (listp *static-constants*))) - (if-let ((record (find object *static-constants* :key #'first :test #'equal))) + (ext:if-let ((record (find object *static-constants* :key #'first :test #'equal))) (second record) - (when-let ((builder (static-constant-expression object))) + (ext:when-let ((builder (static-constant-expression object))) (let ((c-name (format nil "_ecl_static_~D" (length *static-constants*)))) (push (list object c-name builder) *static-constants*) (make-vv :location c-name :value object)))))) diff --git a/src/cmp/cmppass2-ffi.lsp b/src/cmp/cmppass2-ffi.lsp index 09d367cf2..d9f583e8e 100644 --- a/src/cmp/cmppass2-ffi.lsp +++ b/src/cmp/cmppass2-ffi.lsp @@ -23,7 +23,7 @@ (gethash rep-type (machine-rep-type-hash *machine*))) (defun rep-type-record (rep-type) - (if-let ((record (gethash rep-type (machine-rep-type-hash *machine*)))) + (ext:if-let ((record (gethash rep-type (machine-rep-type-hash *machine*)))) record (cmperr "Not a valid C type name ~A" rep-type))) diff --git a/src/cmp/cmppass2-top.lsp b/src/cmp/cmppass2-top.lsp index 8ba0c8c4c..334484a1b 100644 --- a/src/cmp/cmppass2-top.lsp +++ b/src/cmp/cmppass2-top.lsp @@ -5,7 +5,7 @@ (defun t2expr (form) (when form - (if-let ((def (gethash (c1form-name form) *t2-dispatch-table*))) + (ext:if-let ((def (gethash (c1form-name form) *t2-dispatch-table*))) (let ((*compile-file-truename* (c1form-file form)) (*compile-file-position* (c1form-file-position form)) (*current-toplevel-form* (c1form-form form)) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 1ff327d6a..1d4f3b010 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -37,7 +37,7 @@ (*current-form* (c1form-form form)) (*current-toplevel-form* (c1form-toplevel-form form)) (name (c1form-name form))) - (when-let ((propagator (gethash name *p1-dispatch-table*))) + (ext:when-let ((propagator (gethash name *p1-dispatch-table*))) (prop-message "~&;;; Entering type propagation for ~A" name) (multiple-value-bind (new-type assumptions) (apply propagator form assumptions (c1form-args form)) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 3d5c438a9..4a79f1978 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -511,7 +511,7 @@ keyword argument, the compiler-macro declines to provide an expansion. (when (eq (first lambda-list) '&whole) (push `(,(second lambda-list) ,whole) bindings-for-body) (setf lambda-list (cddr lambda-list))) - (when-let ((env (member '&environment lambda-list))) + (ext:when-let ((env (member '&environment lambda-list))) (push '&environment new-lambda-list) (push (second env) new-lambda-list) (setq lambda-list (nconc (ldiff lambda-list env) (cddr env)))) -- GitLab From 2cbd91c3ac2e96eae8340a46ccf2b90244464b30 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Feb 2023 18:24:07 +0100 Subject: [PATCH 05/33] cmp: define-policy: use explicit package accessors --- src/c/symbols_list.h | 26 ++++++++++++++++++------- src/cmp/cmppolicy.lsp | 45 ++++++++++++++++++++----------------------- 2 files changed, 40 insertions(+), 31 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index e6334e529..5379959ac 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -2149,8 +2149,6 @@ cl_symbols[] = { {EXT_ "UNIX-SIGNAL-RECEIVED-CODE" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {KEY_ "CODE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, -{EXT_ "ASSUME-RIGHT-TYPE" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, - {SYS_ "FLOAT-TO-DIGITS" ECL_FUN("si_float_to_digits", si_float_to_digits, 4) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "FLOAT-TO-STRING-FREE" ECL_FUN("si_float_to_string_free", si_float_to_string_free, 4) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "INTEGER-TO-STRING" ECL_FUN("si_integer_to_string", si_integer_to_string, 5) ECL_VAR(SI_ORDINARY, OBJNULL)}, @@ -2328,14 +2326,28 @@ cl_symbols[] = { {SYS_ "SETF-DEFINITION" ECL_FUN("si_setf_definition", ECL_NAME(si_setf_definition), 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, {EXT_ "ASSUME-NO-ERRORS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, -{EXT_ "ASSUME-TYPES-DONT-CHANGE" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, -{EXT_ "CHECK-ARGUMENTS-TYPE" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, -{EXT_ "INLINE-ACCESSORS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, -{EXT_ "INLINE-TYPE-CHECKS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, -{EXT_ "EVALUATE-FORMS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "ASSUME-RIGHT-TYPE" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "TYPE-ASSERTIONS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "CHECK-STACK-OVERFLOW" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "CHECK-ARGUMENTS-TYPE" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "ARRAY-BOUNDS-CHECK" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "GLOBAL-VAR-CHECKING" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "GLOBAL-FUNCTION-CHECKING" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "CHECK-NARGS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "THE-IS-CHECKED" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, + +{EXT_ "ASSUME-TYPES-DONT-CHANGE" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "INLINE-SLOT-ACCESS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "INLINE-ACCESSORS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "INLINE-BIT-OPERATIONS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "OPEN-CODE-AREF/ASET" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "EVALUATE-FORMS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "USE-DIRECT-C-CALL" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "INLINE-TYPE-CHECKS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "INLINE-SEQUENCE-FUNCTIONS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, + +{EXT_ "DEBUG-VARIABLE-BINDINGS" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{EXT_ "DEBUG-IHS-FRAME" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {KEY_ "VALUE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "KEY-AND-VALUE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index 981b3251e..9ef3d738d 100644 --- a/src/cmp/cmppolicy.lsp +++ b/src/cmp/cmppolicy.lsp @@ -160,9 +160,6 @@ (intern (concatenate 'string "POLICY-" (symbol-name base)) (find-package "C"))) (defmacro define-policy (&whole whole name &rest conditions) - (unintern name) - (import name (find-package "EXT")) - (export name (find-package "EXT")) (let* ((test (ash 1 +last-optimization-bit+)) (declaration-name (policy-declaration-name name)) (function-name (policy-function-name name)) @@ -240,76 +237,76 @@ ;; ERROR CHECKING POLICY ;; -(define-policy assume-no-errors :off safety 1) +(define-policy ext:assume-no-errors :off safety 1) -(define-policy assume-right-type :alias assume-no-errors) +(define-policy ext:assume-right-type :alias ext:assume-no-errors) -(define-policy type-assertions :anti-alias assume-no-errors +(define-policy ext:type-assertions :anti-alias ext:assume-no-errors "Generate type assertions when inlining accessors and other functions.") -(define-policy check-stack-overflow :on safety 2 +(define-policy ext:check-stack-overflow :on safety 2 "Add a stack check to every function") -(define-policy check-arguments-type :on safety 1 +(define-policy ext:check-arguments-type :on safety 1 "Generate CHECK-TYPE forms for function arguments with type declarations") -(define-policy array-bounds-check :on safety 1 +(define-policy ext:array-bounds-check :on safety 1 "Check out of bounds access to arrays") -(define-policy global-var-checking :on safety 3 +(define-policy ext:global-var-checking :on safety 3 "Read the value of a global variable even if it is discarded, ensuring it is bound") -(define-policy global-function-checking :on safety 3 +(define-policy ext:global-function-checking :on safety 3 "Read the binding of a global function even if it is discarded") -(define-policy check-nargs :on safety 1 :only-on check-arguments-type 1 +(define-policy ext:check-nargs :on safety 1 :only-on ext:check-arguments-type 1 "Check that the number of arguments a function receives is within bounds") -(define-policy the-is-checked :on safety 1 +(define-policy ext:the-is-checked :on safety 1 "THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE.") ;; ;; INLINING POLICY ;; -(define-policy assume-types-dont-change :off safety 1 +(define-policy ext:assume-types-dont-change :off safety 1 "Assume that type and class definitions will not change") -(define-policy inline-slot-access :on speed 1 :off debug 2 :off safety 2 +(define-policy ext:inline-slot-access :on speed 1 :off debug 2 :off safety 2 "Inline access to structures and sealed classes") -(define-policy inline-accessors :off debug 2 :off space 2 +(define-policy ext:inline-accessors :off debug 2 :off space 2 "Inline access to object slots, including conses and arrays") -(define-policy inline-bit-operations :off space 2 +(define-policy ext:inline-bit-operations :off space 2 "Inline LDB and similar functions") -(define-policy open-code-aref/aset :alias inline-accessors +(define-policy ext:open-code-aref/aset :alias ext:inline-accessors "Inline access to arrays") -(define-policy evaluate-forms :off debug 1 +(define-policy ext:evaluate-forms :off debug 1 "Pre-evaluate a function that takes constant arguments") -(define-policy use-direct-C-call :off debug 2 +(define-policy ext:use-direct-C-call :off debug 2 "Emit direct calls to a function whose C name is known") -(define-policy inline-type-checks :off space 2 +(define-policy ext:inline-type-checks :off space 2 "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP, INTGERP, STRINGP.") -(define-policy inline-sequence-functions :off space 2 +(define-policy ext:inline-sequence-functions :off space 2 "Inline functions such as MAP, MEMBER, FIND, etc") ;; ;; DEBUG POLICY ;; -(define-policy debug-variable-bindings :on debug 3 +(define-policy ext:debug-variable-bindings :on debug 3 :requires (policy-debug-ihs-frame env) ;; We can only create variable bindings when the function has an IHS frame!!! "Create a debug vector with the bindings of each LET/LET*/LAMBDA form?") -(define-policy debug-ihs-frame :on debug 3 +(define-policy ext:debug-ihs-frame :on debug 3 "Let the functions appear in backtraces") ); eval-when -- GitLab From 6ab1d0adedc5c407bf1b36a5222cbe29f0eef2e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Feb 2023 18:36:03 +0100 Subject: [PATCH 06/33] cmp: constants: be explicit about the package --- src/cmp/cmpct.lsp | 82 ++++++++++++++++++++++----------------------- src/cmp/cmputil.lsp | 2 +- 2 files changed, 42 insertions(+), 42 deletions(-) diff --git a/src/cmp/cmpct.lsp b/src/cmp/cmpct.lsp index 5d37608b6..5f4a1c7ed 100644 --- a/src/cmp/cmpct.lsp +++ b/src/cmp/cmpct.lsp @@ -30,9 +30,9 @@ (let* ((value name) (type (type-of value)) (loc-type (case type - (single-float 'single-float-value) - (double-float 'double-float-value) - (long-float 'long-float-value) + (cl:single-float 'single-float-value) + (cl:double-float 'double-float-value) + (cl:long-float 'long-float-value) (si:complex-single-float 'csfloat-value) (si:complex-double-float 'cdfloat-value) (si:complex-long-float 'clfloat-value))) @@ -74,45 +74,45 @@ ) (when (eq machine *default-machine*) ;; Constants which are not portable - `((MOST-POSITIVE-SHORT-FLOAT "FLT_MAX") - (MOST-POSITIVE-SINGLE-FLOAT "FLT_MAX") - - (MOST-NEGATIVE-SHORT-FLOAT "-FLT_MAX") - (MOST-NEGATIVE-SINGLE-FLOAT "-FLT_MAX") - - (LEAST-POSITIVE-SHORT-FLOAT "FLT_TRUE_MIN") - (LEAST-POSITIVE-SINGLE-FLOAT "FLT_TRUE_MIN") - (LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT "FLT_MIN") - (LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" FLT_MIN") - - (LEAST-NEGATIVE-SHORT-FLOAT "-FLT_TRUE_MIN") - (LEAST-NEGATIVE-SINGLE-FLOAT "-FLT_TRUE_MIN") - (LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT "-FLT_MIN") - (LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT "-FLT_MIN") - - (MOST-POSITIVE-DOUBLE-FLOAT "DBL_MAX") - (MOST-NEGATIVE-DOUBLE-FLOAT "-DBL_MAX") - (LEAST-POSITIVE-DOUBLE-FLOAT "DBL_TRUE_MIN") - (LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT "DBL_MIN") - (LEAST-NEGATIVE-DOUBLE-FLOAT "-DBL_TRUE_MIN") - (LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT "-DBL_MIN") + `((cl:most-positive-short-float "FLT_MAX") + (cl:most-positive-single-float "FLT_MAX") + + (cl:most-negative-short-float "-FLT_MAX") + (cl:most-negative-single-float "-FLT_MAX") + + (cl:least-positive-short-float "FLT_TRUE_MIN") + (cl:least-positive-single-float "FLT_TRUE_MIN") + (cl:least-positive-normalized-short-float "FLT_MIN") + (cl:least-positive-normalized-single-float" FLT_MIN") + + (cl:least-negative-short-float "-FLT_TRUE_MIN") + (cl:least-negative-single-float "-FLT_TRUE_MIN") + (cl:least-negative-normalized-short-float "-FLT_MIN") + (cl:least-negative-normalized-single-float "-FLT_MIN") + + (cl:most-positive-double-float "DBL_MAX") + (cl:most-negative-double-float "-DBL_MAX") + (cl:least-positive-double-float "DBL_TRUE_MIN") + (cl:least-positive-normalized-double-float "DBL_MIN") + (cl:least-negative-double-float "-DBL_TRUE_MIN") + (cl:least-negative-normalized-double-float "-DBL_MIN") #+ieee-floating-point - ,@'((SHORT-FLOAT-POSITIVE-INFINITY "INFINITY") - (SINGLE-FLOAT-POSITIVE-INFINITY "INFINITY") - (DOUBLE-FLOAT-POSITIVE-INFINITY "INFINITY") - - (SHORT-FLOAT-NEGATIVE-INFINITY "-INFINITY") - (SINGLE-FLOAT-NEGATIVE-INFINITY "-INFINITY") - (DOUBLE-FLOAT-NEGATIVE-INFINITY "-INFINITY")) - - ,@'((MOST-POSITIVE-LONG-FLOAT "LDBL_MAX") - (MOST-NEGATIVE-LONG-FLOAT "-LDBL_MAX") - (LEAST-POSITIVE-LONG-FLOAT "LDBL_TRUE_MIN") - (LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" LDBL_MIN") - (LEAST-NEGATIVE-LONG-FLOAT "-LDBL_TRUE_MIN") - (LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT "-LDBL_MIN") + ,@'((ext:short-float-positive-infinity "INFINITY") + (ext:single-float-positive-infinity "INFINITY") + (ext:double-float-positive-infinity "INFINITY") + + (ext:short-float-negative-infinity "-INFINITY") + (ext:single-float-negative-infinity "-INFINITY") + (ext:double-float-negative-infinity "-INFINITY")) + + ,@'((cl:most-positive-long-float "LDBL_MAX") + (cl:most-negative-long-float "-LDBL_MAX") + (cl:least-positive-long-float "LDBL_TRUE_MIN") + (cl:least-positive-normalized-long-float" LDBL_MIN") + (cl:least-negative-long-float "-LDBL_TRUE_MIN") + (cl:least-negative-normalized-long-float "-LDBL_MIN") #+ieee-floating-point - (LONG-FLOAT-POSITIVE-INFINITY "INFINITY") + (ext:long-float-positive-infinity "INFINITY") #+ieee-floating-point - (LONG-FLOAT-NEGATIVE-INFINITY "-INFINITY")))))) + (ext:long-float-negative-infinity "-INFINITY")))))) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 4a79f1978..9b6a92f2e 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -211,7 +211,7 @@ (compiler-error #'handle-compiler-error) (compiler-internal-error #'handle-compiler-internal-error) (serious-condition #'handle-compiler-internal-error)) - (mp:with-lock (+load-compile-lock+) + (mp:with-lock (mp:+load-compile-lock+) (let ,+init-env-form+ (with-compilation-unit () ,@body)))) -- GitLab From e74826b9cd4cef9c6f0b750b5be3fc89bfe8a6ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Feb 2023 18:44:40 +0100 Subject: [PATCH 07/33] cmp: be explicit about symbol packages 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). --- src/cmp/cmparray.lsp | 8 +- src/cmp/cmpct.lsp | 16 +- src/cmp/cmpenv-declare.lsp | 24 +- src/cmp/cmpenv-fun.lsp | 46 +- src/cmp/cmpenv-proclaim.lsp | 29 +- src/cmp/cmpmac.lsp | 2 +- src/cmp/cmpopt-cons.lsp | 8 +- src/cmp/cmpopt-sequence.lsp | 10 +- src/cmp/cmppackage.lsp | 2 +- src/cmp/cmppass1-eval.lsp | 18 +- src/cmp/cmppass1-ffi.lsp | 33 +- src/cmp/cmppass1-stack.lsp | 26 +- src/cmp/cmppass2-eval.lsp | 2 +- src/cmp/cmppass2-ffi.lsp | 24 +- src/cmp/cmppass2-loc.lsp | 16 +- src/cmp/cmpstructures.lsp | 2 +- src/cmp/cmptables.lsp | 252 +++++----- src/cmp/sysfun.lsp | 912 ++++++++++++++++++------------------ 18 files changed, 712 insertions(+), 718 deletions(-) diff --git a/src/cmp/cmparray.lsp b/src/cmp/cmparray.lsp index e1e6e7713..191931b59 100644 --- a/src/cmp/cmparray.lsp +++ b/src/cmp/cmparray.lsp @@ -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))) diff --git a/src/cmp/cmpct.lsp b/src/cmp/cmpct.lsp index 5f4a1c7ed..09a4265ec 100644 --- a/src/cmp/cmpct.lsp +++ b/src/cmp/cmpct.lsp @@ -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. diff --git a/src/cmp/cmpenv-declare.lsp b/src/cmp/cmpenv-declare.lsp index be2f63992..ff0a9d47e 100644 --- a/src/cmp/cmpenv-declare.lsp +++ b/src/cmp/cmpenv-declare.lsp @@ -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 diff --git a/src/cmp/cmpenv-fun.lsp b/src/cmp/cmpenv-fun.lsp index 211426b97..0d5522672 100644 --- a/src/cmp/cmpenv-fun.lsp +++ b/src/cmp/cmpenv-fun.lsp @@ -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) diff --git a/src/cmp/cmpenv-proclaim.lsp b/src/cmp/cmpenv-proclaim.lsp index 2d955b1e7..171329502 100644 --- a/src/cmp/cmpenv-proclaim.lsp +++ b/src/cmp/cmpenv-proclaim.lsp @@ -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*)) diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp index 8c80c706a..82c46afd4 100644 --- a/src/cmp/cmpmac.lsp +++ b/src/cmp/cmpmac.lsp @@ -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*) diff --git a/src/cmp/cmpopt-cons.lsp b/src/cmp/cmpopt-cons.lsp index fbf43a085..4dd6e2b0b 100644 --- a/src/cmp/cmpopt-cons.lsp +++ b/src/cmp/cmpopt-cons.lsp @@ -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)) diff --git a/src/cmp/cmpopt-sequence.lsp b/src/cmp/cmpopt-sequence.lsp index 259ff8f3e..43de356e0 100644 --- a/src/cmp/cmpopt-sequence.lsp +++ b/src/cmp/cmpopt-sequence.lsp @@ -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))))))) diff --git a/src/cmp/cmppackage.lsp b/src/cmp/cmppackage.lsp index 7db57fce6..6f29de4ce 100644 --- a/src/cmp/cmppackage.lsp +++ b/src/cmp/cmppackage.lsp @@ -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* diff --git a/src/cmp/cmppass1-eval.lsp b/src/cmp/cmppass1-eval.lsp index 55d17cd09..b19a8046b 100644 --- a/src/cmp/cmppass1-eval.lsp +++ b/src/cmp/cmppass1-eval.lsp @@ -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) diff --git a/src/cmp/cmppass1-ffi.lsp b/src/cmp/cmppass1-ffi.lsp index 45cca79be..bc9ffa75d 100644 --- a/src/cmp/cmppass1-ffi.lsp +++ b/src/cmp/cmppass1-ffi.lsp @@ -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 diff --git a/src/cmp/cmppass1-stack.lsp b/src/cmp/cmppass1-stack.lsp index 8a924cfd6..f45ed4ecc 100644 --- a/src/cmp/cmppass1-stack.lsp +++ b/src/cmp/cmppass1-stack.lsp @@ -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)) diff --git a/src/cmp/cmppass2-eval.lsp b/src/cmp/cmppass2-eval.lsp index 90dc8dfe9..a65e9d15b 100644 --- a/src/cmp/cmppass2-eval.lsp +++ b/src/cmp/cmppass2-eval.lsp @@ -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." diff --git a/src/cmp/cmppass2-ffi.lsp b/src/cmp/cmppass2-ffi.lsp index d9f583e8e..b722fac2a 100644 --- a/src/cmp/cmppass2-ffi.lsp +++ b/src/cmp/cmppass2-ffi.lsp @@ -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. diff --git a/src/cmp/cmppass2-loc.lsp b/src/cmp/cmppass2-loc.lsp index a1fa9fd87..8ec8ca84d 100644 --- a/src/cmp/cmppass2-loc.lsp +++ b/src/cmp/cmppass2-loc.lsp @@ -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) diff --git a/src/cmp/cmpstructures.lsp b/src/cmp/cmpstructures.lsp index 68755afa8..e3d25af4f 100644 --- a/src/cmp/cmpstructures.lsp +++ b/src/cmp/cmpstructures.lsp @@ -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) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 94625be54..c009a8511 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -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 - - (if . c1if) ; c1special - (not . c1not) ; c1special - (and . c1and) ; c1special - (or . c1or) ; c1special - - (let . c1let) ; c1special - (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:flet . c1flet) ; c1special + (cl:labels . c1labels) ; c1special + (cl:locally . c1locally) ; c1special + (cl:macrolet . c1macrolet) ; c1special + (cl:symbol-macrolet . c1symbol-macrolet) ; c1special + + (cl:if . c1if) ; c1special + (cl:not . c1not) ; c1special + (cl:and . c1and) ; c1special + (cl:or . c1or) ; c1special + + (cl:let . c1let) ; c1special + (cl:let* . c1let*) ; c1special + + (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) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 8ff029cc4..f17ea2d8c 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -31,61 +31,61 @@ ;;; ALL FUNCTION DECLARATIONS AND INLINE FORMS ;;; -(def-inline aref :unsafe (t t t) t "@0;ecl_aref_unsafe(#0,ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2))") -(def-inline aref :unsafe ((array t) t t) t "@0;(#0)->array.self.t[ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2)]") -(def-inline aref :unsafe ((array bit) t t) :fixnum "@0;ecl_aref_bv(#0,ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2))") -(def-inline aref :unsafe ((array t) fixnum fixnum) t "@0;(#0)->array.self.t[#1*(#0)->array.dims[1]+#2]") -(def-inline aref :unsafe ((array bit) fixnum fixnum) :fixnum "@0;ecl_aref_bv(#0,(#1)*(#0)->array.dims[1]+#2)") -(def-inline aref :unsafe ((array base-char) fixnum fixnum) :unsigned-char "@0;(#0)->base_string.self[#1*(#0)->array.dims[1]+#2]") -(def-inline aref :unsafe ((array double-float) fixnum fixnum) :double "@0;(#0)->array.self.df[#1*(#0)->array.dims[1]+#2]") -(def-inline aref :unsafe ((array single-float) fixnum fixnum) :float "@0;(#0)->array.self.sf[#1*(#0)->array.dims[1]+#2]") -(def-inline aref :unsafe ((array long-float) fixnum fixnum) :long-double "@0;(#0)->array.self.lf[#1*(#0)->array.dims[1]+#2]") -#+complex-float (def-inline aref :unsafe ((array si:complex-single-float) fixnum fixnum) :csfloat "@0;(#0)->array.self.csf[#1*(#0)->array.dims[1]+#2]") -#+complex-float (def-inline aref :unsafe ((array si:complex-double-float) fixnum fixnum) :cdfloat "@0;(#0)->array.self.cdf[#1*(#0)->array.dims[1]+#2]") -#+complex-float (def-inline aref :unsafe ((array si:complex-long-float) fixnum fixnum) :clfloat "@0;(#0)->array.self.clf[#1*(#0)->array.dims[1]+#2]") - -(def-inline aref :unsafe ((array fixnum) fixnum fixnum) :fixnum "@0;(#0)->array.self.fix[#1*(#0)->array.dims[1]+#2]") - -(def-inline aref :always (t t) t "ecl_aref1(#0,ecl_to_size(#1))") -(def-inline aref :always (t fixnum) t "ecl_aref1(#0,#1)") -(def-inline aref :unsafe (t t) t "ecl_aref1(#0,ecl_fixnum(#1))") -(def-inline aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))") -(def-inline aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") +(def-inline cl:aref :unsafe (t t t) t "@0;ecl_aref_unsafe(#0,ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2))") +(def-inline cl:aref :unsafe ((array t) t t) t "@0;(#0)->array.self.t[ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2)]") +(def-inline cl:aref :unsafe ((array bit) t t) :fixnum "@0;ecl_aref_bv(#0,ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2))") +(def-inline cl:aref :unsafe ((array t) fixnum fixnum) t "@0;(#0)->array.self.t[#1*(#0)->array.dims[1]+#2]") +(def-inline cl:aref :unsafe ((array bit) fixnum fixnum) :fixnum "@0;ecl_aref_bv(#0,(#1)*(#0)->array.dims[1]+#2)") +(def-inline cl:aref :unsafe ((array base-char) fixnum fixnum) :unsigned-char "@0;(#0)->base_string.self[#1*(#0)->array.dims[1]+#2]") +(def-inline cl:aref :unsafe ((array double-float) fixnum fixnum) :double "@0;(#0)->array.self.df[#1*(#0)->array.dims[1]+#2]") +(def-inline cl:aref :unsafe ((array single-float) fixnum fixnum) :float "@0;(#0)->array.self.sf[#1*(#0)->array.dims[1]+#2]") +(def-inline cl:aref :unsafe ((array long-float) fixnum fixnum) :long-double "@0;(#0)->array.self.lf[#1*(#0)->array.dims[1]+#2]") +#+complex-float (def-inline cl:aref :unsafe ((array si:complex-single-float) fixnum fixnum) :csfloat "@0;(#0)->array.self.csf[#1*(#0)->array.dims[1]+#2]") +#+complex-float (def-inline cl:aref :unsafe ((array si:complex-double-float) fixnum fixnum) :cdfloat "@0;(#0)->array.self.cdf[#1*(#0)->array.dims[1]+#2]") +#+complex-float (def-inline cl:aref :unsafe ((array si:complex-long-float) fixnum fixnum) :clfloat "@0;(#0)->array.self.clf[#1*(#0)->array.dims[1]+#2]") + +(def-inline cl:aref :unsafe ((array fixnum) fixnum fixnum) :fixnum "@0;(#0)->array.self.fix[#1*(#0)->array.dims[1]+#2]") + +(def-inline cl:aref :always (t t) t "ecl_aref1(#0,ecl_to_size(#1))") +(def-inline cl:aref :always (t fixnum) t "ecl_aref1(#0,#1)") +(def-inline cl:aref :unsafe (t t) t "ecl_aref1(#0,ecl_fixnum(#1))") +(def-inline cl:aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))") +(def-inline cl:aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") #+unicode -(def-inline aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]") -(def-inline aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]") -(def-inline aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]") -(def-inline aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]") -(def-inline aref :unsafe ((array long-float) fixnum) :long-double "(#0)->array.self.lf[#1]") -#+complex-float (def-inline aref :unsafe ((array si:complex-single-float) fixnum) :csfloat "(#0)->array.self.csf[#1]") -#+complex-float (def-inline aref :unsafe ((array si:complex-double-float) fixnum) :cdfloat "(#0)->array.self.cdf[#1]") -#+complex-float (def-inline aref :unsafe ((array si:complex-long-float) fixnum) :clfloat "(#0)->array.self.clf[#1]") -(def-inline aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]") - -(def-inline row-major-aref :always (t t) t "ecl_aref(#0,ecl_to_size(#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,ecl_fixnum(#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,ecl_fixnum(#1))") -(def-inline row-major-aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") +(def-inline cl:aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]") +(def-inline cl:aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]") +(def-inline cl:aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]") +(def-inline cl:aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]") +(def-inline cl:aref :unsafe ((array long-float) fixnum) :long-double "(#0)->array.self.lf[#1]") +#+complex-float (def-inline cl:aref :unsafe ((array si:complex-single-float) fixnum) :csfloat "(#0)->array.self.csf[#1]") +#+complex-float (def-inline cl:aref :unsafe ((array si:complex-double-float) fixnum) :cdfloat "(#0)->array.self.cdf[#1]") +#+complex-float (def-inline cl:aref :unsafe ((array si:complex-long-float) fixnum) :clfloat "(#0)->array.self.clf[#1]") +(def-inline cl:aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]") + +(def-inline cl:row-major-aref :always (t t) t "ecl_aref(#0,ecl_to_size(#1))") +(def-inline cl:row-major-aref :always (t fixnum) t "ecl_aref(#0,#1)") +(def-inline cl:row-major-aref :unsafe (t t) t "ecl_aref_unsafe(#0,ecl_fixnum(#1))") +(def-inline cl:row-major-aref :unsafe (t fixnum) t "ecl_aref_unsafe(#0,#1)") +(def-inline cl:row-major-aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))") +(def-inline cl: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) :unsigned-char "(#0)->base_string.self[#1]") -(def-inline row-major-aref :unsafe ((array ext:byte8) fixnum) :uint8-t "(#0)->vector.self.b8[#1]") -(def-inline row-major-aref :unsafe ((array ext:integer8) fixnum) :int8-t "(#0)->vector.self.i8[#1]") -(def-inline row-major-aref :unsafe ((array ext:byte16) fixnum) :uint16-t "(#0)->vector.self.b16[#1]") -(def-inline row-major-aref :unsafe ((array ext:integer16) fixnum) :int16-t "(#0)->vector.self.i16[#1]") -(def-inline row-major-aref :unsafe ((array ext:byte32) fixnum) :uint32-t "(#0)->vector.self.b32[#1]") -(def-inline row-major-aref :unsafe ((array ext:integer32) fixnum) :int32-t "(#0)->vector.self.i32[#1]") -(def-inline row-major-aref :unsafe ((array ext:byte64) fixnum) :uint64-t "(#0)->vector.self.b64[#1]") -(def-inline row-major-aref :unsafe ((array ext:integer64) fixnum) :int64-t "(#0)->vector.self.i64[#1]") -(def-inline row-major-aref :unsafe ((array long-float) fixnum) :long-double "(#0)->array.self.lf[#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]") -#+complex-float (def-inline row-major-aref :unsafe ((array si:complex-single-float) fixnum) :csfloat "(#0)->array.self.csf[#1]") -#+complex-float (def-inline row-major-aref :unsafe ((array si:complex-double-float) fixnum) :cdfloat "(#0)->array.self.cdf[#1]") -#+complex-float (def-inline row-major-aref :unsafe ((array si:complex-long-float) fixnum) :clfloat "(#0)->array.self.clf[#1]") -(def-inline row-major-aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]") +(def-inline cl:row-major-aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]") +(def-inline cl:row-major-aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]") +(def-inline cl:row-major-aref :unsafe ((array ext:byte8) fixnum) :uint8-t "(#0)->vector.self.b8[#1]") +(def-inline cl:row-major-aref :unsafe ((array ext:integer8) fixnum) :int8-t "(#0)->vector.self.i8[#1]") +(def-inline cl:row-major-aref :unsafe ((array ext:byte16) fixnum) :uint16-t "(#0)->vector.self.b16[#1]") +(def-inline cl:row-major-aref :unsafe ((array ext:integer16) fixnum) :int16-t "(#0)->vector.self.i16[#1]") +(def-inline cl:row-major-aref :unsafe ((array ext:byte32) fixnum) :uint32-t "(#0)->vector.self.b32[#1]") +(def-inline cl:row-major-aref :unsafe ((array ext:integer32) fixnum) :int32-t "(#0)->vector.self.i32[#1]") +(def-inline cl:row-major-aref :unsafe ((array ext:byte64) fixnum) :uint64-t "(#0)->vector.self.b64[#1]") +(def-inline cl:row-major-aref :unsafe ((array ext:integer64) fixnum) :int64-t "(#0)->vector.self.i64[#1]") +(def-inline cl:row-major-aref :unsafe ((array long-float) fixnum) :long-double "(#0)->array.self.lf[#1]") +(def-inline cl:row-major-aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]") +(def-inline cl:row-major-aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]") +#+complex-float (def-inline cl:row-major-aref :unsafe ((array si:complex-single-float) fixnum) :csfloat "(#0)->array.self.csf[#1]") +#+complex-float (def-inline cl:row-major-aref :unsafe ((array si:complex-double-float) fixnum) :cdfloat "(#0)->array.self.cdf[#1]") +#+complex-float (def-inline cl:row-major-aref :unsafe ((array si:complex-long-float) fixnum) :clfloat "(#0)->array.self.clf[#1]") +(def-inline cl:row-major-aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]") (def-inline si:row-major-aset :always (t t t) t "ecl_aset(#0,ecl_to_size(#1),#2)") (def-inline si:row-major-aset :always (t fixnum t) t "ecl_aset(#0,#1,#2)") @@ -117,35 +117,35 @@ ext:array-index) array "@0;(ecl_copy_subarray(#0,#1,#2,#3,#4),#0)") -(def-inline array-rank :unsafe (array) :fixnum +(def-inline cl:array-rank :unsafe (array) :fixnum "@0;(((#0)->d.t == t_array)?(#0)->array.rank:1)") -(def-inline array-rank :always (array) :fixnum +(def-inline cl:array-rank :always (array) :fixnum "ecl_array_rank(#0)") -(def-inline array-dimension :always (t t) fixnum +(def-inline cl:array-dimension :always (t t) fixnum "ecl_array_dimension(#0,ecl_to_size(#1))") -(def-inline array-dimension :always (t fixnum) fixnum +(def-inline cl:array-dimension :always (t fixnum) fixnum "ecl_array_dimension(#0,#1)") -(def-inline array-total-size :unsafe (t) :fixnum "((#0)->array.dim)") +(def-inline cl:array-total-size :unsafe (t) :fixnum "((#0)->array.dim)") -(def-inline adjustable-array-p :always (t) :bool "@0;(ECL_ARRAYP(#0)? (void)0: FEtype_error_array(#0),ECL_ADJUSTABLE_ARRAY_P(#0))") -(def-inline adjustable-array-p :unsafe (array) :bool "ECL_ADJUSTABLE_ARRAY_P(#0)") +(def-inline cl:adjustable-array-p :always (t) :bool "@0;(ECL_ARRAYP(#0)? (void)0: FEtype_error_array(#0),ECL_ADJUSTABLE_ARRAY_P(#0))") +(def-inline cl:adjustable-array-p :unsafe (array) :bool "ECL_ADJUSTABLE_ARRAY_P(#0)") -(def-inline svref :always (t t) t "ecl_aref1(#0,ecl_to_size(#1))") -(def-inline svref :always (t fixnum) t "ecl_aref1(#0,#1)") -(def-inline svref :unsafe (t t) t "(#0)->vector.self.t[ecl_fixnum(#1)]") -(def-inline svref :unsafe (t fixnum) t "(#0)->vector.self.t[#1]") +(def-inline cl:svref :always (t t) t "ecl_aref1(#0,ecl_to_size(#1))") +(def-inline cl:svref :always (t fixnum) t "ecl_aref1(#0,#1)") +(def-inline cl:svref :unsafe (t t) t "(#0)->vector.self.t[ecl_fixnum(#1)]") +(def-inline cl:svref :unsafe (t fixnum) t "(#0)->vector.self.t[#1]") (def-inline si:svset :always (t t t) t "ecl_aset1(#0,ecl_to_size(#1),#2)") (def-inline si:svset :always (t fixnum t) t "ecl_aset1(#0,#1,#2)") (def-inline si:svset :unsafe (t t t) t "((#0)->vector.self.t[ecl_fixnum(#1)]=(#2))") (def-inline si:svset :unsafe (t fixnum t) t "(#0)->vector.self.t[#1]= #2") -(def-inline array-has-fill-pointer-p :always (t) :bool "@0;(ECL_ARRAYP(#0)?(void)0:FEtype_error_array(#0),ECL_ARRAY_HAS_FILL_POINTER_P(#0))") -(def-inline array-has-fill-pointer-p :unsafe (array) :bool "ECL_ARRAY_HAS_FILL_POINTER_P(#0)") +(def-inline cl:array-has-fill-pointer-p :always (t) :bool "@0;(ECL_ARRAYP(#0)?(void)0:FEtype_error_array(#0),ECL_ARRAY_HAS_FILL_POINTER_P(#0))") +(def-inline cl:array-has-fill-pointer-p :unsafe (array) :bool "ECL_ARRAY_HAS_FILL_POINTER_P(#0)") -(def-inline fill-pointer :unsafe (t) :fixnum "((#0)->vector.fillp)") +(def-inline cl:fill-pointer :unsafe (t) :fixnum "((#0)->vector.fillp)") (def-inline si:fill-pointer-set :unsafe (t fixnum) :fixnum @@ -153,45 +153,45 @@ ;; file character.d -(def-inline standard-char-p :always (character) :bool "ecl_standard_char_p(#0)") +(def-inline cl:standard-char-p :always (character) :bool "ecl_standard_char_p(#0)") -(def-inline graphic-char-p :always (character) :bool "ecl_graphic_char_p(#0)") +(def-inline cl:graphic-char-p :always (character) :bool "ecl_graphic_char_p(#0)") -(def-inline alpha-char-p :always (character) :bool "ecl_alpha_char_p(#0)") +(def-inline cl:alpha-char-p :always (character) :bool "ecl_alpha_char_p(#0)") -(def-inline upper-case-p :always (character) :bool "ecl_upper_case_p(#0)") +(def-inline cl:upper-case-p :always (character) :bool "ecl_upper_case_p(#0)") -(def-inline lower-case-p :always (character) :bool "ecl_lower_case_p(#0)") +(def-inline cl:lower-case-p :always (character) :bool "ecl_lower_case_p(#0)") -(def-inline both-case-p :always (character) :bool "ecl_both_case_p(#0)") +(def-inline cl:both-case-p :always (character) :bool "ecl_both_case_p(#0)") -(def-inline alphanumericp :always (character) :bool "ecl_alphanumericp(#0)") +(def-inline cl:alphanumericp :always (character) :bool "ecl_alphanumericp(#0)") -(def-inline char= :always (t t) :bool "ecl_char_code(#0)==ecl_char_code(#1)") -(def-inline char= :always (character character) :bool "(#0)==(#1)") +(def-inline cl:char= :always (t t) :bool "ecl_char_code(#0)==ecl_char_code(#1)") +(def-inline cl:char= :always (character character) :bool "(#0)==(#1)") -(def-inline char/= :always (t t) :bool "ecl_char_code(#0)!=ecl_char_code(#1)") -(def-inline char/= :always (character character) :bool "(#0)!=(#1)") +(def-inline cl:char/= :always (t t) :bool "ecl_char_code(#0)!=ecl_char_code(#1)") +(def-inline cl:char/= :always (character character) :bool "(#0)!=(#1)") -(def-inline char< :always (character character) :bool "(#0)<(#1)") +(def-inline cl:char< :always (character character) :bool "(#0)<(#1)") -(def-inline char> :always (character character) :bool "(#0)>(#1)") +(def-inline cl:char> :always (character character) :bool "(#0)>(#1)") -(def-inline char<= :always (character character) :bool "(#0)<=(#1)") +(def-inline cl:char<= :always (character character) :bool "(#0)<=(#1)") -(def-inline char>= :always (character character) :bool "(#0)>=(#1)") +(def-inline cl:char>= :always (character character) :bool "(#0)>=(#1)") -(def-inline char-code :always (character) :fixnum "#0") +(def-inline cl:char-code :always (character) :fixnum "#0") -(def-inline code-char :always (fixnum) :wchar "#0") +(def-inline cl:code-char :always (fixnum) :wchar "#0") -(def-inline char-upcase :always (base-char) :unsigned-char "ecl_char_upcase(#0)") -(def-inline char-upcase :always (character) :wchar "ecl_char_upcase(#0)") +(def-inline cl:char-upcase :always (base-char) :unsigned-char "ecl_char_upcase(#0)") +(def-inline cl:char-upcase :always (character) :wchar "ecl_char_upcase(#0)") -(def-inline char-downcase :always (base-char) :unsigned-char "ecl_char_downcase(#0)") -(def-inline char-downcase :always (character) :wchar "ecl_char_downcase(#0)") +(def-inline cl:char-downcase :always (base-char) :unsigned-char "ecl_char_downcase(#0)") +(def-inline cl:char-downcase :always (character) :wchar "ecl_char_downcase(#0)") -(def-inline char-int :always (character) :fixnum "#0") +(def-inline cl:char-int :always (character) :fixnum "#0") ;; file ffi.d @@ -199,457 +199,457 @@ ;; file file.d -(def-inline input-stream-p :always (stream) :bool "ecl_input_stream_p(#0)") +(def-inline cl:input-stream-p :always (stream) :bool "ecl_input_stream_p(#0)") -(def-inline output-stream-p :always (stream) :bool "ecl_output_stream_p(#0)") +(def-inline cl:output-stream-p :always (stream) :bool "ecl_output_stream_p(#0)") ;; file hash.d -(def-inline gethash :always (t t t) t "ecl_gethash_safe(#0,#1,#2)" :multiple-values nil) -(def-inline gethash :always (t t) t "ecl_gethash_safe(#0,#1,ECL_NIL)" :multiple-values nil) -(def-inline hash-table-count :unsafe (hash-table) ext:array-index "ecl_hash_table_count(#0)") +(def-inline cl:gethash :always (t t t) t "ecl_gethash_safe(#0,#1,#2)" :multiple-values nil) +(def-inline cl:gethash :always (t t) t "ecl_gethash_safe(#0,#1,ECL_NIL)" :multiple-values nil) +(def-inline cl:hash-table-count :unsafe (hash-table) ext:array-index "ecl_hash_table_count(#0)") ;; file list.d -(def-inline car :unsafe (cons) t "ECL_CONS_CAR(#0)") -(def-inline car :unsafe (t) t "_ecl_car(#0)") +(def-inline cl:car :unsafe (cons) t "ECL_CONS_CAR(#0)") +(def-inline cl:car :unsafe (t) t "_ecl_car(#0)") -(def-inline si::cons-car :always (t) t "_ecl_car(#0)") -(def-inline si::cons-car :unsafe (t) t "ECL_CONS_CAR(#0)") +(def-inline si:cons-car :always (t) t "_ecl_car(#0)") +(def-inline si:cons-car :unsafe (t) t "ECL_CONS_CAR(#0)") -(def-inline cdr :unsafe (cons) t "ECL_CONS_CDR(#0)") -(def-inline cdr :unsafe (t) t "_ecl_cdr(#0)") +(def-inline cl:cdr :unsafe (cons) t "ECL_CONS_CDR(#0)") +(def-inline cl:cdr :unsafe (t) t "_ecl_cdr(#0)") -(def-inline si::cons-cdr :always (t) t "_ecl_cdr(#0)") -(def-inline si::cons-cdr :unsafe (t) t "ECL_CONS_CDR(#0)") +(def-inline si:cons-cdr :always (t) t "_ecl_cdr(#0)") +(def-inline si:cons-cdr :unsafe (t) t "ECL_CONS_CDR(#0)") ;; BEGIN-GENERATED (gen-cons-sysfun) -(def-inline car :always (t) t "ecl_car(#0)") -(def-inline car :unsafe (t) t "_ecl_car(#0)") -(def-inline cdr :always (t) t "ecl_cdr(#0)") -(def-inline cdr :unsafe (t) t "_ecl_cdr(#0)") -(def-inline caar :always (t) t "ecl_caar(#0)") -(def-inline caar :unsafe (t) t "_ecl_caar(#0)") -(def-inline cdar :always (t) t "ecl_cdar(#0)") -(def-inline cdar :unsafe (t) t "_ecl_cdar(#0)") -(def-inline cadr :always (t) t "ecl_cadr(#0)") -(def-inline cadr :unsafe (t) t "_ecl_cadr(#0)") -(def-inline cddr :always (t) t "ecl_cddr(#0)") -(def-inline cddr :unsafe (t) t "_ecl_cddr(#0)") -(def-inline caaar :always (t) t "ecl_caaar(#0)") -(def-inline caaar :unsafe (t) t "_ecl_caaar(#0)") -(def-inline cdaar :always (t) t "ecl_cdaar(#0)") -(def-inline cdaar :unsafe (t) t "_ecl_cdaar(#0)") -(def-inline cadar :always (t) t "ecl_cadar(#0)") -(def-inline cadar :unsafe (t) t "_ecl_cadar(#0)") -(def-inline cddar :always (t) t "ecl_cddar(#0)") -(def-inline cddar :unsafe (t) t "_ecl_cddar(#0)") -(def-inline caadr :always (t) t "ecl_caadr(#0)") -(def-inline caadr :unsafe (t) t "_ecl_caadr(#0)") -(def-inline cdadr :always (t) t "ecl_cdadr(#0)") -(def-inline cdadr :unsafe (t) t "_ecl_cdadr(#0)") -(def-inline caddr :always (t) t "ecl_caddr(#0)") -(def-inline caddr :unsafe (t) t "_ecl_caddr(#0)") -(def-inline cdddr :always (t) t "ecl_cdddr(#0)") -(def-inline cdddr :unsafe (t) t "_ecl_cdddr(#0)") -(def-inline caaaar :always (t) t "ecl_caaaar(#0)") -(def-inline caaaar :unsafe (t) t "_ecl_caaaar(#0)") -(def-inline cdaaar :always (t) t "ecl_cdaaar(#0)") -(def-inline cdaaar :unsafe (t) t "_ecl_cdaaar(#0)") -(def-inline cadaar :always (t) t "ecl_cadaar(#0)") -(def-inline cadaar :unsafe (t) t "_ecl_cadaar(#0)") -(def-inline cddaar :always (t) t "ecl_cddaar(#0)") -(def-inline cddaar :unsafe (t) t "_ecl_cddaar(#0)") -(def-inline caadar :always (t) t "ecl_caadar(#0)") -(def-inline caadar :unsafe (t) t "_ecl_caadar(#0)") -(def-inline cdadar :always (t) t "ecl_cdadar(#0)") -(def-inline cdadar :unsafe (t) t "_ecl_cdadar(#0)") -(def-inline caddar :always (t) t "ecl_caddar(#0)") -(def-inline caddar :unsafe (t) t "_ecl_caddar(#0)") -(def-inline cdddar :always (t) t "ecl_cdddar(#0)") -(def-inline cdddar :unsafe (t) t "_ecl_cdddar(#0)") -(def-inline caaadr :always (t) t "ecl_caaadr(#0)") -(def-inline caaadr :unsafe (t) t "_ecl_caaadr(#0)") -(def-inline cdaadr :always (t) t "ecl_cdaadr(#0)") -(def-inline cdaadr :unsafe (t) t "_ecl_cdaadr(#0)") -(def-inline cadadr :always (t) t "ecl_cadadr(#0)") -(def-inline cadadr :unsafe (t) t "_ecl_cadadr(#0)") -(def-inline cddadr :always (t) t "ecl_cddadr(#0)") -(def-inline cddadr :unsafe (t) t "_ecl_cddadr(#0)") -(def-inline caaddr :always (t) t "ecl_caaddr(#0)") -(def-inline caaddr :unsafe (t) t "_ecl_caaddr(#0)") -(def-inline cdaddr :always (t) t "ecl_cdaddr(#0)") -(def-inline cdaddr :unsafe (t) t "_ecl_cdaddr(#0)") -(def-inline cadddr :always (t) t "ecl_cadddr(#0)") -(def-inline cadddr :unsafe (t) t "_ecl_cadddr(#0)") -(def-inline cddddr :always (t) t "ecl_cddddr(#0)") -(def-inline cddddr :unsafe (t) t "_ecl_cddddr(#0)") +(def-inline cl:car :always (t) t "ecl_car(#0)") +(def-inline cl:car :unsafe (t) t "_ecl_car(#0)") +(def-inline cl:cdr :always (t) t "ecl_cdr(#0)") +(def-inline cl:cdr :unsafe (t) t "_ecl_cdr(#0)") +(def-inline cl:caar :always (t) t "ecl_caar(#0)") +(def-inline cl:caar :unsafe (t) t "_ecl_caar(#0)") +(def-inline cl:cdar :always (t) t "ecl_cdar(#0)") +(def-inline cl:cdar :unsafe (t) t "_ecl_cdar(#0)") +(def-inline cl:cadr :always (t) t "ecl_cadr(#0)") +(def-inline cl:cadr :unsafe (t) t "_ecl_cadr(#0)") +(def-inline cl:cddr :always (t) t "ecl_cddr(#0)") +(def-inline cl:cddr :unsafe (t) t "_ecl_cddr(#0)") +(def-inline cl:caaar :always (t) t "ecl_caaar(#0)") +(def-inline cl:caaar :unsafe (t) t "_ecl_caaar(#0)") +(def-inline cl:cdaar :always (t) t "ecl_cdaar(#0)") +(def-inline cl:cdaar :unsafe (t) t "_ecl_cdaar(#0)") +(def-inline cl:cadar :always (t) t "ecl_cadar(#0)") +(def-inline cl:cadar :unsafe (t) t "_ecl_cadar(#0)") +(def-inline cl:cddar :always (t) t "ecl_cddar(#0)") +(def-inline cl:cddar :unsafe (t) t "_ecl_cddar(#0)") +(def-inline cl:caadr :always (t) t "ecl_caadr(#0)") +(def-inline cl:caadr :unsafe (t) t "_ecl_caadr(#0)") +(def-inline cl:cdadr :always (t) t "ecl_cdadr(#0)") +(def-inline cl:cdadr :unsafe (t) t "_ecl_cdadr(#0)") +(def-inline cl:caddr :always (t) t "ecl_caddr(#0)") +(def-inline cl:caddr :unsafe (t) t "_ecl_caddr(#0)") +(def-inline cl:cdddr :always (t) t "ecl_cdddr(#0)") +(def-inline cl:cdddr :unsafe (t) t "_ecl_cdddr(#0)") +(def-inline cl:caaaar :always (t) t "ecl_caaaar(#0)") +(def-inline cl:caaaar :unsafe (t) t "_ecl_caaaar(#0)") +(def-inline cl:cdaaar :always (t) t "ecl_cdaaar(#0)") +(def-inline cl:cdaaar :unsafe (t) t "_ecl_cdaaar(#0)") +(def-inline cl:cadaar :always (t) t "ecl_cadaar(#0)") +(def-inline cl:cadaar :unsafe (t) t "_ecl_cadaar(#0)") +(def-inline cl:cddaar :always (t) t "ecl_cddaar(#0)") +(def-inline cl:cddaar :unsafe (t) t "_ecl_cddaar(#0)") +(def-inline cl:caadar :always (t) t "ecl_caadar(#0)") +(def-inline cl:caadar :unsafe (t) t "_ecl_caadar(#0)") +(def-inline cl:cdadar :always (t) t "ecl_cdadar(#0)") +(def-inline cl:cdadar :unsafe (t) t "_ecl_cdadar(#0)") +(def-inline cl:caddar :always (t) t "ecl_caddar(#0)") +(def-inline cl:caddar :unsafe (t) t "_ecl_caddar(#0)") +(def-inline cl:cdddar :always (t) t "ecl_cdddar(#0)") +(def-inline cl:cdddar :unsafe (t) t "_ecl_cdddar(#0)") +(def-inline cl:caaadr :always (t) t "ecl_caaadr(#0)") +(def-inline cl:caaadr :unsafe (t) t "_ecl_caaadr(#0)") +(def-inline cl:cdaadr :always (t) t "ecl_cdaadr(#0)") +(def-inline cl:cdaadr :unsafe (t) t "_ecl_cdaadr(#0)") +(def-inline cl:cadadr :always (t) t "ecl_cadadr(#0)") +(def-inline cl:cadadr :unsafe (t) t "_ecl_cadadr(#0)") +(def-inline cl:cddadr :always (t) t "ecl_cddadr(#0)") +(def-inline cl:cddadr :unsafe (t) t "_ecl_cddadr(#0)") +(def-inline cl:caaddr :always (t) t "ecl_caaddr(#0)") +(def-inline cl:caaddr :unsafe (t) t "_ecl_caaddr(#0)") +(def-inline cl:cdaddr :always (t) t "ecl_cdaddr(#0)") +(def-inline cl:cdaddr :unsafe (t) t "_ecl_cdaddr(#0)") +(def-inline cl:cadddr :always (t) t "ecl_cadddr(#0)") +(def-inline cl:cadddr :unsafe (t) t "_ecl_cadddr(#0)") +(def-inline cl:cddddr :always (t) t "ecl_cddddr(#0)") +(def-inline cl:cddddr :unsafe (t) t "_ecl_cddddr(#0)") ;; END-GENERATED -(def-inline cons :always (t t) t "CONS(#0,#1)") +(def-inline cl:cons :always (t t) t "CONS(#0,#1)") -(def-inline endp :safe (t) :bool "ecl_endp(#0)") -(def-inline endp :unsafe (t) :bool "#0==ECL_NIL") +(def-inline cl:endp :safe (t) :bool "ecl_endp(#0)") +(def-inline cl:endp :unsafe (t) :bool "#0==ECL_NIL") -(def-inline nth :always (t t) t "ecl_nth(ecl_to_size(#0),#1)") -(def-inline nth :always (fixnum t) t "ecl_nth(#0,#1)") -(def-inline nth :unsafe (t t) t "ecl_nth(ecl_fixnum(#0),#1)") -(def-inline nth :unsafe (fixnum t) t "ecl_nth(#0,#1)") +(def-inline cl:nth :always (t t) t "ecl_nth(ecl_to_size(#0),#1)") +(def-inline cl:nth :always (fixnum t) t "ecl_nth(#0,#1)") +(def-inline cl:nth :unsafe (t t) t "ecl_nth(ecl_fixnum(#0),#1)") +(def-inline cl:nth :unsafe (fixnum t) t "ecl_nth(#0,#1)") -(def-inline nthcdr :always (t t) t "ecl_nthcdr(ecl_to_size(#0),#1)") -(def-inline nthcdr :always (fixnum t) t "ecl_nthcdr(#0,#1)") -(def-inline nthcdr :unsafe (t t) t "ecl_nthcdr(ecl_fixnum(#0),#1)") -(def-inline nthcdr :unsafe (fixnum t) t "ecl_nthcdr(#0,#1)") +(def-inline cl:nthcdr :always (t t) t "ecl_nthcdr(ecl_to_size(#0),#1)") +(def-inline cl:nthcdr :always (fixnum t) t "ecl_nthcdr(#0,#1)") +(def-inline cl:nthcdr :unsafe (t t) t "ecl_nthcdr(ecl_fixnum(#0),#1)") +(def-inline cl:nthcdr :unsafe (fixnum t) t "ecl_nthcdr(#0,#1)") -(def-inline last :always (t) t "ecl_last(#0,1)") +(def-inline cl:last :always (t) t "ecl_last(#0,1)") -(def-inline list :always nil t "ECL_NIL") -(def-inline list :always (t) t "ecl_list1(#0)") +(def-inline cl:list :always nil t "ECL_NIL") +(def-inline cl:list :always (t) t "ecl_list1(#0)") -(def-inline list* :always (t) t "#0") -(def-inline list* :always (t t) t "CONS(#0,#1)") +(def-inline cl:list* :always (t) t "#0") +(def-inline cl:list* :always (t t) t "CONS(#0,#1)") -(def-inline append :always (t t) t "ecl_append(#0,#1)") +(def-inline cl:append :always (t t) t "ecl_append(#0,#1)") -(def-inline nconc :always (t t) t "ecl_nconc(#0,#1)") +(def-inline cl:nconc :always (t t) t "ecl_nconc(#0,#1)") -(def-inline butlast :always (t) t "ecl_butlast(#0,1)") +(def-inline cl:butlast :always (t) t "ecl_butlast(#0,1)") -(def-inline nbutlast :always (t) t "ecl_nbutlast(#0,1)") +(def-inline cl:nbutlast :always (t) t "ecl_nbutlast(#0,1)") ;; file num_arith.d -(def-inline 1+ :always (t) t "ecl_one_plus(#0)") -(def-inline 1+ :always (fixnum) t "ecl_make_integer((#0)+1)") -(def-inline 1+ :always (long-float) :long-double "(long double)(#0)+1") -(def-inline 1+ :always (double-float) :double "(double)(#0)+1") -(def-inline 1+ :always (single-float) :float "(float)(#0)+1") -#+complex-float (def-inline 1+ :always (si:complex-single-float) :csfloat "(_Complex float)(#0)+1") -#+complex-float (def-inline 1+ :always (si:complex-double-float) :cdfloat "(_Complex double)(#0)+1") -#+complex-float (def-inline 1+ :always (si:complex-long-float) :clfloat "(_Complex long double)(#0)+1") -(def-inline 1+ :always (fixnum) :fixnum "(#0)+1" :exact-return-type t) - -(def-inline 1- :always (t) t "ecl_one_minus(#0)") -(def-inline 1- :always (fixnum) t "ecl_make_integer((#0)-1)") -(def-inline 1- :always (long-float) :long-double "(long double)(#0)-1") -(def-inline 1- :always (double-float) :double "(double)(#0)-1") -(def-inline 1- :always (single-float) :float "(float)(#0)-1") -#+complex-float (def-inline 1- :always (si:complex-single-float) :csfloat "(_Complex float)(#0)-1") -#+complex-float (def-inline 1- :always (si:complex-double-float) :cdfloat "(_Complex double)(#0)-1") -#+complex-float (def-inline 1- :always (si:complex-long-float) :clfloat "(_Complex long double)(#0)-1") -(def-inline 1- :always (fixnum) :fixnum "(#0)-1" :exact-return-type t) +(def-inline cl:1+ :always (t) t "ecl_one_plus(#0)") +(def-inline cl:1+ :always (fixnum) t "ecl_make_integer((#0)+1)") +(def-inline cl:1+ :always (long-float) :long-double "(long double)(#0)+1") +(def-inline cl:1+ :always (double-float) :double "(double)(#0)+1") +(def-inline cl:1+ :always (single-float) :float "(float)(#0)+1") +#+complex-float (def-inline cl:1+ :always (si:complex-single-float) :csfloat "(_Complex float)(#0)+1") +#+complex-float (def-inline cl:1+ :always (si:complex-double-float) :cdfloat "(_Complex double)(#0)+1") +#+complex-float (def-inline cl:1+ :always (si:complex-long-float) :clfloat "(_Complex long double)(#0)+1") +(def-inline cl:1+ :always (fixnum) :fixnum "(#0)+1" :exact-return-type t) + +(def-inline cl:1- :always (t) t "ecl_one_minus(#0)") +(def-inline cl:1- :always (fixnum) t "ecl_make_integer((#0)-1)") +(def-inline cl:1- :always (long-float) :long-double "(long double)(#0)-1") +(def-inline cl:1- :always (double-float) :double "(double)(#0)-1") +(def-inline cl:1- :always (single-float) :float "(float)(#0)-1") +#+complex-float (def-inline cl:1- :always (si:complex-single-float) :csfloat "(_Complex float)(#0)-1") +#+complex-float (def-inline cl:1- :always (si:complex-double-float) :cdfloat "(_Complex double)(#0)-1") +#+complex-float (def-inline cl:1- :always (si:complex-long-float) :clfloat "(_Complex long double)(#0)-1") +(def-inline cl:1- :always (fixnum) :fixnum "(#0)-1" :exact-return-type t) ;; file num_co.d -(def-inline float :always (t single-float) :float "ecl_to_float(#0)") -(def-inline float :always (t double-float) :double "ecl_to_double(#0)") -(def-inline float :always (t long-float) :long-double "ecl_to_long_double(#0)") -(def-inline float :always (fixnum-float) :long-double "((long double)(#0))" :exact-return-type t) -(def-inline float :always (fixnum-float) :double "((double)(#0))" :exact-return-type t) -(def-inline float :always (fixnum-float) :float "((float)(#0))" :exact-return-type t) +(def-inline cl:float :always (t single-float) :float "ecl_to_float(#0)") +(def-inline cl:float :always (t double-float) :double "ecl_to_double(#0)") +(def-inline cl:float :always (t long-float) :long-double "ecl_to_long_double(#0)") +(def-inline cl:float :always (fixnum-float) :long-double "((long double)(#0))" :exact-return-type t) +(def-inline cl:float :always (fixnum-float) :double "((double)(#0))" :exact-return-type t) +(def-inline cl:float :always (fixnum-float) :float "((float)(#0))" :exact-return-type t) -(def-inline numerator :unsafe (integer) integer "(#0)") -(def-inline numerator :unsafe (ratio) integer "(#0)->ratio.num") +(def-inline cl:numerator :unsafe (integer) integer "(#0)") +(def-inline cl:numerator :unsafe (ratio) integer "(#0)->ratio.num") -(def-inline denominator :unsafe (integer) integer "ecl_make_fixnum(1)") -(def-inline denominator :unsafe (ratio) integer "(#0)->ratio.den") +(def-inline cl:denominator :unsafe (integer) integer "ecl_make_fixnum(1)") +(def-inline cl:denominator :unsafe (ratio) integer "(#0)->ratio.den") -(def-inline floor :always (t) (values &rest t) "ecl_floor1(#0)") -(def-inline floor :always (t t) (values &rest t) "ecl_floor2(#0,#1)") +(def-inline cl:floor :always (t) (values &rest t) "ecl_floor1(#0)") +(def-inline cl:floor :always (t t) (values &rest t) "ecl_floor2(#0,#1)") #+(or) ; does not work well, no multiple values -(def-inline floor :always (fixnum fixnum) :fixnum +(def-inline cl:floor :always (fixnum fixnum) :fixnum "@01;(#0>=0&>0?(#0)/(#1):ecl_ifloor(#0,#1))") -(def-inline ceiling :always (t) (values &rest t) "ecl_ceiling1(#0)") -(def-inline ceiling :always (t t) (values &rest t) "ecl_ceiling2(#0,#1)") +(def-inline cl:ceiling :always (t) (values &rest t) "ecl_ceiling1(#0)") +(def-inline cl:ceiling :always (t t) (values &rest t) "ecl_ceiling2(#0,#1)") -(def-inline truncate :always (t) (values &rest t) "ecl_truncate1(#0)") -(def-inline truncate :always (t t) (values &rest t) "ecl_truncate2(#0,#1)") +(def-inline cl:truncate :always (t) (values &rest t) "ecl_truncate1(#0)") +(def-inline cl:truncate :always (t t) (values &rest t) "ecl_truncate2(#0,#1)") #+(or) ; does not work well, no multiple values -(def-inline truncate :always (fixnum-float) :fixnum "(cl_fixnum)(#0)") +(def-inline cl:truncate :always (fixnum-float) :fixnum "(cl_fixnum)(#0)") -(def-inline round :always (t) (values &rest t) "ecl_round1(#0)") -(def-inline round :always (t t) (values &rest t) "ecl_round2(#0,#1)") +(def-inline cl:round :always (t) (values &rest t) "ecl_round1(#0)") +(def-inline cl:round :always (t t) (values &rest t) "ecl_round2(#0,#1)") -(def-inline mod :always (t t) t "(ecl_floor2(#0,#1),cl_env_copy->values[1])") -(def-inline mod :always (fixnum fixnum) :fixnum +(def-inline cl:mod :always (t t) t "(ecl_floor2(#0,#1),cl_env_copy->values[1])") +(def-inline cl:mod :always (fixnum fixnum) :fixnum "@01;(#0>=0&>0?(#0)%(#1):ecl_imod(#0,#1))") -(def-inline rem :always (t t) t "(ecl_truncate2(#0,#1),cl_env_copy->values[1])") -(def-inline rem :always (fixnum fixnum) :fixnum "(#0)%(#1)") +(def-inline cl:rem :always (t t) t "(ecl_truncate2(#0,#1),cl_env_copy->values[1])") +(def-inline cl:rem :always (fixnum fixnum) :fixnum "(#0)%(#1)") -(def-inline = :always (t t) :bool "ecl_number_equalp(#0,#1)") -(def-inline = :always (fixnum-float fixnum-float) :bool "(#0)==(#1)") +(def-inline cl:= :always (t t) :bool "ecl_number_equalp(#0,#1)") +(def-inline cl:= :always (fixnum-float fixnum-float) :bool "(#0)==(#1)") -(def-inline /= :always (t t) :bool "!ecl_number_equalp(#0,#1)") -(def-inline /= :always (fixnum-float fixnum-float) :bool "(#0)!=(#1)") +(def-inline cl:/= :always (t t) :bool "!ecl_number_equalp(#0,#1)") +(def-inline cl:/= :always (fixnum-float fixnum-float) :bool "(#0)!=(#1)") -(def-inline < :always (t t) :bool "ecl_lower(#0,#1)") -(def-inline < :always (fixnum-float fixnum-float) :bool "(#0)<(#1)") -(def-inline < :always (fixnum-float fixnum-float fixnum-float) :bool +(def-inline cl:< :always (t t) :bool "ecl_lower(#0,#1)") +(def-inline cl:< :always (fixnum-float fixnum-float) :bool "(#0)<(#1)") +(def-inline cl:< :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)<(#1) && (#1)<(#2))") -(def-inline > :always (t t) :bool "ecl_greater(#0,#1)") -(def-inline > :always (fixnum-float fixnum-float) :bool "(#0)>(#1)") -(def-inline > :always (fixnum-float fixnum-float fixnum-float) :bool +(def-inline cl:> :always (t t) :bool "ecl_greater(#0,#1)") +(def-inline cl:> :always (fixnum-float fixnum-float) :bool "(#0)>(#1)") +(def-inline cl:> :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)>(#1) && (#1)>(#2))") -(def-inline <= :always (t t) :bool "ecl_lowereq(#0,#1)") -(def-inline <= :always (fixnum-float fixnum-float) :bool "(#0)<=(#1)") -(def-inline <= :always (fixnum-float fixnum-float fixnum-float) :bool +(def-inline cl:<= :always (t t) :bool "ecl_lowereq(#0,#1)") +(def-inline cl:<= :always (fixnum-float fixnum-float) :bool "(#0)<=(#1)") +(def-inline cl:<= :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)<=(#1) && (#1)<=(#2))") -(def-inline >= :always (t t) :bool "ecl_greatereq(#0,#1)") -(def-inline >= :always (fixnum-float fixnum-float) :bool "(#0)>=(#1)") -(def-inline >= :always (fixnum-float fixnum-float fixnum-float) :bool +(def-inline cl:>= :always (t t) :bool "ecl_greatereq(#0,#1)") +(def-inline cl:>= :always (fixnum-float fixnum-float) :bool "(#0)>=(#1)") +(def-inline cl:>= :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)>=(#1) && (#1)>=(#2))") -#+ieee-floating-point (def-inline max :always (t t) t "@01;((ecl_float_nan_p(#1) || ecl_greatereq(#0,#1))?#0:#1)") -#-ieee-floating-point (def-inline max :always (t t) t "@01;(ecl_greatereq(#0,#1)?#0:#1)") -(def-inline max :always (fixnum fixnum) :fixnum "@01;(#0)>=(#1)?#0:#1") +#+ieee-floating-point (def-inline cl:max :always (t t) t "@01;((ecl_float_nan_p(#1) || ecl_greatereq(#0,#1))?#0:#1)") +#-ieee-floating-point (def-inline cl:max :always (t t) t "@01;(ecl_greatereq(#0,#1)?#0:#1)") +(def-inline cl:max :always (fixnum fixnum) :fixnum "@01;(#0)>=(#1)?#0:#1") -#+ieee-floating-point (def-inline min :always (t t) t "@01;((ecl_float_nan_p(#1) || ecl_lowereq(#0,#1))?#0:#1)") -#-ieee-floating-point (def-inline min :always (t t) t "@01;(ecl_lowereq(#0,#1)?#0:#1)") -(def-inline min :always (fixnum fixnum) :fixnum "@01;(#0)<=(#1)?#0:#1") +#+ieee-floating-point (def-inline cl:min :always (t t) t "@01;((ecl_float_nan_p(#1) || ecl_lowereq(#0,#1))?#0:#1)") +#-ieee-floating-point (def-inline cl:min :always (t t) t "@01;(ecl_lowereq(#0,#1)?#0:#1)") +(def-inline cl:min :always (fixnum fixnum) :fixnum "@01;(#0)<=(#1)?#0:#1") ;; file num_log.d -(def-inline logand :always nil t "ecl_make_fixnum(-1)") -(def-inline logand :always nil :fixnum "-1") -(def-inline logand :always (t t) t "ecl_boole(ECL_BOOLAND,(#0),(#1))") -(def-inline logand :always (fixnum fixnum) :fixnum "((#0) & (#1))") +(def-inline cl:logand :always nil t "ecl_make_fixnum(-1)") +(def-inline cl:logand :always nil :fixnum "-1") +(def-inline cl:logand :always (t t) t "ecl_boole(ECL_BOOLAND,(#0),(#1))") +(def-inline cl:logand :always (fixnum fixnum) :fixnum "((#0) & (#1))") -(def-inline logandc1 :always (t t) t "ecl_boole(ECL_BOOLANDC1,(#0),(#1))") -(def-inline logandc1 :always (fixnum fixnum) :fixnum "(~(#0) & (#1))") +(def-inline cl:logandc1 :always (t t) t "ecl_boole(ECL_BOOLANDC1,(#0),(#1))") +(def-inline cl:logandc1 :always (fixnum fixnum) :fixnum "(~(#0) & (#1))") -(def-inline logandc2 :always (t t) t "ecl_boole(ECL_BOOLANDC2,(#0),(#1))") -(def-inline logandc2 :always (fixnum fixnum) :fixnum "((#0) & ~(#1))") - -(def-inline logeqv :always nil t "ecl_make_fixnum(-1)") -(def-inline logeqv :always nil :fixnum "-1") -(def-inline logeqv :always (t t) t "ecl_boole(ECL_BOOLEQV,(#0),(#1))") -(def-inline logeqv :always (fixnum fixnum) :fixnum "(~( (#0) ^ (#1) ))") - -(def-inline logior :always nil t "ecl_make_fixnum(0)") -(def-inline logior :always nil :fixnum "0") -(def-inline logior :always (t t) t "ecl_boole(ECL_BOOLIOR,(#0),(#1))") -(def-inline logior :always (fixnum fixnum) :fixnum "((#0) | (#1))") - -(def-inline lognand :always (t t) t "ecl_boole(ECL_BOOLNAND,(#0),(#1))") -(def-inline lognand :always (fixnum fixnum) :fixnum "(~( (#0) & (#1) ))") - -(def-inline lognor :always (t t) t "ecl_boole(ECL_BOOLNOR,(#0),(#1))") -(def-inline lognor :always (fixnum fixnum) :fixnum "(~( (#0) | (#1) ))") - -(def-inline lognot :always (t) t "ecl_boole(ECL_BOOLXOR,(#0),ecl_make_fixnum(-1))") -(def-inline lognot :always (fixnum) :fixnum "(~(#0))") - -(def-inline logorc1 :always (t t) t "ecl_boole(ECL_BOOLORC1,(#0),(#1))") -(def-inline logorc1 :always (fixnum fixnum) :fixnum "(~(#0) | (#1))") - -(def-inline logorc2 :always (t t) t "ecl_boole(ECL_BOOLORC2,(#0),(#1))") -(def-inline logorc2 :always (fixnum fixnum) :fixnum "((#0) | ~(#1))") - -(def-inline logxor :always nil t "ecl_make_fixnum(0)") -(def-inline logxor :always nil :fixnum "0") -(def-inline logxor :always (t t) t "ecl_boole(ECL_BOOLXOR,(#0),(#1))") -(def-inline logxor :always (fixnum fixnum) :fixnum "((#0) ^ (#1))") - -(def-inline boole :always (fixnum t t) t "ecl_boole((#0),(#1),(#2))") - -(def-inline logbitp :always ((integer -29 29) fixnum) :bool "(#1 >> #0) & 1") - -(def-inline integer-length :always (t) :cl-index "ecl_integer_length(#0)") - -(def-inline zerop :always (t) :bool "ecl_zerop(#0)") -(def-inline zerop :always (fixnum-float) :bool "(#0)==0") - -(def-inline plusp :always (t) :bool "ecl_plusp(#0)") -(def-inline plusp :always (fixnum-float) :bool "(#0)>0") - -(def-inline minusp :always (t) :bool "ecl_minusp(#0)") -(def-inline minusp :always (fixnum-float) :bool "(#0)<0") - -(def-inline oddp :always (t) :bool "ecl_oddp(#0)") -(def-inline oddp :always (fixnum fixnum) :bool "(#0) & 1") - -(def-inline evenp :always (t) :bool "ecl_evenp(#0)") -(def-inline evenp :always (fixnum fixnum) :bool "~(#0) & 1") - -(def-inline abs :always (t t) t "ecl_abs(#0,#1)") - -(def-inline exp :always (t) t "ecl_exp(#0)") - -(def-inline expt :always (t t) t "ecl_expt(#0,#1)") -(def-inline expt :always ((integer 2 2) (integer 0 29)) :fixnum "(1<<(#1))") -(def-inline expt :always ((integer 0 0) t) :fixnum "0") -(def-inline expt :always ((integer 1 1) t) :fixnum "1") -(def-inline expt :always ((long-float 0.0 *) long-float) :long-double "powl((long double)#0,(long double)#1)") -(def-inline expt :always ((double-float 0.0 *) double-float) :double "pow((double)#0,(double)#1)") -(def-inline expt :always ((single-float 0.0 *) single-float) :float "powf((float)#0,(float)#1)") -#+complex-float (def-inline expt :always (si:complex-single-float si:complex-single-float) :csfloat "cpowf(#0,#1)") -#+complex-float (def-inline expt :always (si:complex-double-float si:complex-double-float) :cdfloat "cpow(#0,#1)") -#+complex-float (def-inline expt :always (si:complex-long-float si:complex-long-float) :clfloat "cpowl(#0,#1)") - -(def-inline log :always (fixnum-float) :long-double "logl((long double)(#0))" :exact-return-type t) -(def-inline log :always (fixnum-float) :double "log((double)(#0))" :exact-return-type t) -(def-inline log :always (fixnum-float) :float "logf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline log :always (si:complex-single-float) :csfloat "clogf(#0)") -#+complex-float (def-inline log :always (si:complex-double-float) :cdfloat "clog(#0)") -#+complex-float (def-inline log :always (si:complex-long-float) :clfloat "clogl(#0)") - -(def-inline sqrt :always (number) number "ecl_sqrt(#0)") -(def-inline sqrt :always ((long-float 0.0 *)) :long-double "sqrtl((long double)(#0))") -(def-inline sqrt :always ((double-float 0.0 *)) :double "sqrt((double)(#0))") -(def-inline sqrt :always ((single-float 0.0 *)) :float "sqrtf((float)(#0))") -#+complex-float (def-inline sqrt :always (si:complex-single-float) :csfloat "csqrtf(#0)") -#+complex-float (def-inline sqrt :always (si:complex-double-float) :cdfloat "csqrt(#0)") -#+complex-float (def-inline sqrt :always (si:complex-long-float) :clfloat "csqrtl(#0)") - -(def-inline sin :always (number) number "ecl_sin(#0)") -(def-inline sin :always (fixnum-float) :long-double "sinl((long double)(#0))" :exact-return-type t) -(def-inline sin :always (fixnum-float) :double "sin((double)(#0))" :exact-return-type t) -(def-inline sin :always (fixnum-float) :float "sinf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline sin :always (si:complex-single-float) :csfloat "csinf(#0)") -#+complex-float (def-inline sin :always (si:complex-double-float) :cdfloat "csin(#0)") -#+complex-float (def-inline sin :always (si:complex-long-float) :clfloat "csinl(#0)") - -(def-inline cos :always (t) number "ecl_cos(#0)") -(def-inline cos :always (fixnum-float) :long-double "cosl((long double)(#0))" :exact-return-type t) -(def-inline cos :always (fixnum-float) :double "cos((double)(#0))" :exact-return-type t) -(def-inline cos :always (fixnum-float) :float "cosf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline cos :always (si:complex-single-float) :csfloat "ccosf(#0)") -#+complex-float (def-inline cos :always (si:complex-double-float) :cdfloat "ccos(#0)") -#+complex-float (def-inline cos :always (si:complex-long-float) :clfloat "ccosl(#0)") - -(def-inline tan :always (t) number "ecl_tan(#0)") -(def-inline tan :always (fixnum-float) :long-double "tanl((long double)(#0))" :exact-return-type t) -(def-inline tan :always (fixnum-float) :double "tan((double)(#0))" :exact-return-type t) -(def-inline tan :always (fixnum-float) :float "tanf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline tan :always (si:complex-single-float) :csfloat "ctanf(#0)") -#+complex-float (def-inline tan :always (si:complex-double-float) :cdfloat "ctan(#0)") -#+complex-float (def-inline tan :always (si:complex-long-float) :clfloat "ctanl(#0)") - -(def-inline sinh :always (t) number "ecl_sinh(#0)") -(def-inline sinh :always (fixnum-float) :long-double "sinhl((long double)(#0))" :exact-return-type t) -(def-inline sinh :always (fixnum-float) :double "sinh((double)(#0))" :exact-return-type t) -(def-inline sinh :always (fixnum-float) :float "sinhf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline sinh :always (si:complex-single-float) :csfloat "csinhf(#0)") -#+complex-float (def-inline sinh :always (si:complex-double-float) :cdfloat "csinh(#0)") -#+complex-float (def-inline sinh :always (si:complex-long-float) :clfloat "csinhl(#0)") - -(def-inline cosh :always (t) number "ecl_cosh(#0)") -(def-inline cosh :always (fixnum-float) :long-double "coshl((long double)(#0))" :exact-return-type t) -(def-inline cosh :always (fixnum-float) :double "cosh((double)(#0))" :exact-return-type t) -(def-inline cosh :always (fixnum-float) :float "coshf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline cosh :always (si:complex-single-float) :csfloat "ccoshf(#0)") -#+complex-float (def-inline cosh :always (si:complex-double-float) :cdfloat "ccosh(#0)") -#+complex-float (def-inline cosh :always (si:complex-long-float) :clfloat "ccoshl(#0)") - -(def-inline tanh :always (t) number "ecl_tanh(#0)") -(def-inline tanh :always (fixnum-float) :long-double "tanhl((long double)(#0))" :exact-return-type t) -(def-inline tanh :always (fixnum-float) :double "tanh((double)(#0))" :exact-return-type t) -(def-inline tanh :always (fixnum-float) :float "tanhf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline tanh :always (si:complex-single-float) :csfloat "ctanhf(#0)") -#+complex-float (def-inline tanh :always (si:complex-double-float) :cdfloat "ctanh(#0)") -#+complex-float (def-inline tanh :always (si:complex-long-float) :clfloat "ctanhl(#0)") +(def-inline cl:logandc2 :always (t t) t "ecl_boole(ECL_BOOLANDC2,(#0),(#1))") +(def-inline cl:logandc2 :always (fixnum fixnum) :fixnum "((#0) & ~(#1))") + +(def-inline cl:logeqv :always nil t "ecl_make_fixnum(-1)") +(def-inline cl:logeqv :always nil :fixnum "-1") +(def-inline cl:logeqv :always (t t) t "ecl_boole(ECL_BOOLEQV,(#0),(#1))") +(def-inline cl:logeqv :always (fixnum fixnum) :fixnum "(~( (#0) ^ (#1) ))") + +(def-inline cl:logior :always nil t "ecl_make_fixnum(0)") +(def-inline cl:logior :always nil :fixnum "0") +(def-inline cl:logior :always (t t) t "ecl_boole(ECL_BOOLIOR,(#0),(#1))") +(def-inline cl:logior :always (fixnum fixnum) :fixnum "((#0) | (#1))") + +(def-inline cl:lognand :always (t t) t "ecl_boole(ECL_BOOLNAND,(#0),(#1))") +(def-inline cl:lognand :always (fixnum fixnum) :fixnum "(~( (#0) & (#1) ))") + +(def-inline cl:lognor :always (t t) t "ecl_boole(ECL_BOOLNOR,(#0),(#1))") +(def-inline cl:lognor :always (fixnum fixnum) :fixnum "(~( (#0) | (#1) ))") + +(def-inline cl:lognot :always (t) t "ecl_boole(ECL_BOOLXOR,(#0),ecl_make_fixnum(-1))") +(def-inline cl:lognot :always (fixnum) :fixnum "(~(#0))") + +(def-inline cl:logorc1 :always (t t) t "ecl_boole(ECL_BOOLORC1,(#0),(#1))") +(def-inline cl:logorc1 :always (fixnum fixnum) :fixnum "(~(#0) | (#1))") + +(def-inline cl:logorc2 :always (t t) t "ecl_boole(ECL_BOOLORC2,(#0),(#1))") +(def-inline cl:logorc2 :always (fixnum fixnum) :fixnum "((#0) | ~(#1))") + +(def-inline cl:logxor :always nil t "ecl_make_fixnum(0)") +(def-inline cl:logxor :always nil :fixnum "0") +(def-inline cl:logxor :always (t t) t "ecl_boole(ECL_BOOLXOR,(#0),(#1))") +(def-inline cl:logxor :always (fixnum fixnum) :fixnum "((#0) ^ (#1))") + +(def-inline cl:boole :always (fixnum t t) t "ecl_boole((#0),(#1),(#2))") + +(def-inline cl:logbitp :always ((integer -29 29) fixnum) :bool "(#1 >> #0) & 1") + +(def-inline cl:integer-length :always (t) :cl-index "ecl_integer_length(#0)") + +(def-inline cl:zerop :always (t) :bool "ecl_zerop(#0)") +(def-inline cl:zerop :always (fixnum-float) :bool "(#0)==0") + +(def-inline cl:plusp :always (t) :bool "ecl_plusp(#0)") +(def-inline cl:plusp :always (fixnum-float) :bool "(#0)>0") + +(def-inline cl:minusp :always (t) :bool "ecl_minusp(#0)") +(def-inline cl:minusp :always (fixnum-float) :bool "(#0)<0") + +(def-inline cl:oddp :always (t) :bool "ecl_oddp(#0)") +(def-inline cl:oddp :always (fixnum fixnum) :bool "(#0) & 1") + +(def-inline cl:evenp :always (t) :bool "ecl_evenp(#0)") +(def-inline cl:evenp :always (fixnum fixnum) :bool "~(#0) & 1") + +(def-inline cl:abs :always (t t) t "ecl_abs(#0,#1)") + +(def-inline cl:exp :always (t) t "ecl_exp(#0)") + +(def-inline cl:expt :always (t t) t "ecl_expt(#0,#1)") +(def-inline cl:expt :always ((integer 2 2) (integer 0 29)) :fixnum "(1<<(#1))") +(def-inline cl:expt :always ((integer 0 0) t) :fixnum "0") +(def-inline cl:expt :always ((integer 1 1) t) :fixnum "1") +(def-inline cl:expt :always ((long-float 0.0 *) long-float) :long-double "powl((long double)#0,(long double)#1)") +(def-inline cl:expt :always ((double-float 0.0 *) double-float) :double "pow((double)#0,(double)#1)") +(def-inline cl:expt :always ((single-float 0.0 *) single-float) :float "powf((float)#0,(float)#1)") +#+complex-float (def-inline cl:expt :always (si:complex-single-float si:complex-single-float) :csfloat "cpowf(#0,#1)") +#+complex-float (def-inline cl:expt :always (si:complex-double-float si:complex-double-float) :cdfloat "cpow(#0,#1)") +#+complex-float (def-inline cl:expt :always (si:complex-long-float si:complex-long-float) :clfloat "cpowl(#0,#1)") + +(def-inline cl:log :always (fixnum-float) :long-double "logl((long double)(#0))" :exact-return-type t) +(def-inline cl:log :always (fixnum-float) :double "log((double)(#0))" :exact-return-type t) +(def-inline cl:log :always (fixnum-float) :float "logf((float)(#0))" :exact-return-type t) +#+complex-float (def-inline cl:log :always (si:complex-single-float) :csfloat "clogf(#0)") +#+complex-float (def-inline cl:log :always (si:complex-double-float) :cdfloat "clog(#0)") +#+complex-float (def-inline cl:log :always (si:complex-long-float) :clfloat "clogl(#0)") + +(def-inline cl:sqrt :always (number) number "ecl_sqrt(#0)") +(def-inline cl:sqrt :always ((long-float 0.0 *)) :long-double "sqrtl((long double)(#0))") +(def-inline cl:sqrt :always ((double-float 0.0 *)) :double "sqrt((double)(#0))") +(def-inline cl:sqrt :always ((single-float 0.0 *)) :float "sqrtf((float)(#0))") +#+complex-float (def-inline cl:sqrt :always (si:complex-single-float) :csfloat "csqrtf(#0)") +#+complex-float (def-inline cl:sqrt :always (si:complex-double-float) :cdfloat "csqrt(#0)") +#+complex-float (def-inline cl:sqrt :always (si:complex-long-float) :clfloat "csqrtl(#0)") + +(def-inline cl:sin :always (number) number "ecl_sin(#0)") +(def-inline cl:sin :always (fixnum-float) :long-double "sinl((long double)(#0))" :exact-return-type t) +(def-inline cl:sin :always (fixnum-float) :double "sin((double)(#0))" :exact-return-type t) +(def-inline cl:sin :always (fixnum-float) :float "sinf((float)(#0))" :exact-return-type t) +#+complex-float (def-inline cl:sin :always (si:complex-single-float) :csfloat "csinf(#0)") +#+complex-float (def-inline cl:sin :always (si:complex-double-float) :cdfloat "csin(#0)") +#+complex-float (def-inline cl:sin :always (si:complex-long-float) :clfloat "csinl(#0)") + +(def-inline cl:cos :always (t) number "ecl_cos(#0)") +(def-inline cl:cos :always (fixnum-float) :long-double "cosl((long double)(#0))" :exact-return-type t) +(def-inline cl:cos :always (fixnum-float) :double "cos((double)(#0))" :exact-return-type t) +(def-inline cl:cos :always (fixnum-float) :float "cosf((float)(#0))" :exact-return-type t) +#+complex-float (def-inline cl:cos :always (si:complex-single-float) :csfloat "ccosf(#0)") +#+complex-float (def-inline cl:cos :always (si:complex-double-float) :cdfloat "ccos(#0)") +#+complex-float (def-inline cl:cos :always (si:complex-long-float) :clfloat "ccosl(#0)") + +(def-inline cl:tan :always (t) number "ecl_tan(#0)") +(def-inline cl:tan :always (fixnum-float) :long-double "tanl((long double)(#0))" :exact-return-type t) +(def-inline cl:tan :always (fixnum-float) :double "tan((double)(#0))" :exact-return-type t) +(def-inline cl:tan :always (fixnum-float) :float "tanf((float)(#0))" :exact-return-type t) +#+complex-float (def-inline cl:tan :always (si:complex-single-float) :csfloat "ctanf(#0)") +#+complex-float (def-inline cl:tan :always (si:complex-double-float) :cdfloat "ctan(#0)") +#+complex-float (def-inline cl:tan :always (si:complex-long-float) :clfloat "ctanl(#0)") + +(def-inline cl:sinh :always (t) number "ecl_sinh(#0)") +(def-inline cl:sinh :always (fixnum-float) :long-double "sinhl((long double)(#0))" :exact-return-type t) +(def-inline cl:sinh :always (fixnum-float) :double "sinh((double)(#0))" :exact-return-type t) +(def-inline cl:sinh :always (fixnum-float) :float "sinhf((float)(#0))" :exact-return-type t) +#+complex-float (def-inline cl:sinh :always (si:complex-single-float) :csfloat "csinhf(#0)") +#+complex-float (def-inline cl:sinh :always (si:complex-double-float) :cdfloat "csinh(#0)") +#+complex-float (def-inline cl:sinh :always (si:complex-long-float) :clfloat "csinhl(#0)") + +(def-inline cl:cosh :always (t) number "ecl_cosh(#0)") +(def-inline cl:cosh :always (fixnum-float) :long-double "coshl((long double)(#0))" :exact-return-type t) +(def-inline cl:cosh :always (fixnum-float) :double "cosh((double)(#0))" :exact-return-type t) +(def-inline cl:cosh :always (fixnum-float) :float "coshf((float)(#0))" :exact-return-type t) +#+complex-float (def-inline cl:cosh :always (si:complex-single-float) :csfloat "ccoshf(#0)") +#+complex-float (def-inline cl:cosh :always (si:complex-double-float) :cdfloat "ccosh(#0)") +#+complex-float (def-inline cl:cosh :always (si:complex-long-float) :clfloat "ccoshl(#0)") + +(def-inline cl:tanh :always (t) number "ecl_tanh(#0)") +(def-inline cl:tanh :always (fixnum-float) :long-double "tanhl((long double)(#0))" :exact-return-type t) +(def-inline cl:tanh :always (fixnum-float) :double "tanh((double)(#0))" :exact-return-type t) +(def-inline cl:tanh :always (fixnum-float) :float "tanhf((float)(#0))" :exact-return-type t) +#+complex-float (def-inline cl:tanh :always (si:complex-single-float) :csfloat "ctanhf(#0)") +#+complex-float (def-inline cl:tanh :always (si:complex-double-float) :cdfloat "ctanh(#0)") +#+complex-float (def-inline cl:tanh :always (si:complex-long-float) :clfloat "ctanhl(#0)") ;; file package.d ;; file pathname.d -(def-inline null :always (t) :bool "#0==ECL_NIL") +(def-inline cl:null :always (t) :bool "#0==ECL_NIL") -(def-inline symbolp :always (t) :bool "@0;ECL_SYMBOLP(#0)") +(def-inline cl:symbolp :always (t) :bool "@0;ECL_SYMBOLP(#0)") -(def-inline atom :always (t) :bool "@0;ECL_ATOM(#0)") +(def-inline cl:atom :always (t) :bool "@0;ECL_ATOM(#0)") -(def-inline consp :always (t) :bool "@0;ECL_CONSP(#0)") +(def-inline cl:consp :always (t) :bool "@0;ECL_CONSP(#0)") -(def-inline listp :always (t) :bool "@0;ECL_LISTP(#0)") +(def-inline cl:listp :always (t) :bool "@0;ECL_LISTP(#0)") -(def-inline numberp :always (t) :bool "ecl_numberp(#0)") +(def-inline cl:numberp :always (t) :bool "ecl_numberp(#0)") -(def-inline integerp :always (t) :bool "@0;ECL_FIXNUMP(#0)||ECL_BIGNUMP(#0)") +(def-inline cl:integerp :always (t) :bool "@0;ECL_FIXNUMP(#0)||ECL_BIGNUMP(#0)") -(def-inline floatp :always (t) :bool "floatp(#0)") +(def-inline cl:floatp :always (t) :bool "floatp(#0)") -(def-inline characterp :always (t) :bool "ECL_CHARACTERP(#0)") +(def-inline cl:characterp :always (t) :bool "ECL_CHARACTERP(#0)") -(def-inline base-char-p :always (character) :bool "ECL_BASE_CHAR_P(#0)") +(def-inline si:base-char-p :always (character) :bool "ECL_BASE_CHAR_P(#0)") -(def-inline stringp :always (t) :bool "@0;ECL_STRINGP(#0)") +(def-inline cl:stringp :always (t) :bool "@0;ECL_STRINGP(#0)") -(def-inline base-string-p :always (t) :bool "@0;ECL_BASE_STRINGP(#0)") +(def-inline si:base-string-p :always (t) :bool "@0;ECL_BASE_STRING_P(#0)") -(def-inline bit-vector-p :always (t) :bool "@0;ECL_BIT_VECTOR_P(#0)") +(def-inline cl:bit-vector-p :always (t) :bool "@0;ECL_BIT_VECTOR_P(#0)") -(def-inline vectorp :always (t) :bool "@0;ECL_VECTORP(#0)") +(def-inline cl:vectorp :always (t) :bool "@0;ECL_VECTORP(#0)") -(def-inline arrayp :always (t) :bool "@0;ECL_ARRAYP(#0)") +(def-inline cl:arrayp :always (t) :bool "@0;ECL_ARRAYP(#0)") -(def-inline eq :always (t t) :bool "(#0)==(#1)") -(def-inline eq :always (fixnum fixnum) :bool "(#0)==(#1)") +(def-inline cl:eq :always (t t) :bool "(#0)==(#1)") +(def-inline cl:eq :always (fixnum fixnum) :bool "(#0)==(#1)") -(def-inline eql :always (t t) :bool "ecl_eql(#0,#1)") -(def-inline eql :always (character t) :bool "(ECL_CODE_CHAR(#0)==(#1))") -(def-inline eql :always (t character) :bool "((#0)==ECL_CODE_CHAR(#1))") -(def-inline eql :always (character character) :bool "(#0)==(#1)") -(def-inline eql :always ((not (or complex bignum ratio float)) t) :bool +(def-inline cl:eql :always (t t) :bool "ecl_eql(#0,#1)") +(def-inline cl:eql :always (character t) :bool "(ECL_CODE_CHAR(#0)==(#1))") +(def-inline cl:eql :always (t character) :bool "((#0)==ECL_CODE_CHAR(#1))") +(def-inline cl:eql :always (character character) :bool "(#0)==(#1)") +(def-inline cl:eql :always ((not (or complex bignum ratio float)) t) :bool "(#0)==(#1)") -(def-inline eql :always (t (not (or complex bignum ratio float))) :bool +(def-inline cl:eql :always (t (not (or complex bignum ratio float))) :bool "(#0)==(#1)") -(def-inline eql :always (fixnum fixnum) :bool "(#0)==(#1)") +(def-inline cl:eql :always (fixnum fixnum) :bool "(#0)==(#1)") -(def-inline equal :always (t t) :bool "ecl_equal(#0,#1)") -(def-inline equal :always (fixnum fixnum) :bool "(#0)==(#1)") +(def-inline cl:equal :always (t t) :bool "ecl_equal(#0,#1)") +(def-inline cl:equal :always (fixnum fixnum) :bool "(#0)==(#1)") -(def-inline equalp :always (t t) :bool "ecl_equalp(#0,#1)") -(def-inline equalp :always (fixnum fixnum) :bool "(#0)==(#1)") +(def-inline cl:equalp :always (t t) :bool "ecl_equalp(#0,#1)") +(def-inline cl:equalp :always (fixnum fixnum) :bool "(#0)==(#1)") -(def-inline not :always (t) :bool "(#0)==ECL_NIL") +(def-inline cl:not :always (t) :bool "(#0)==ECL_NIL") ;; file print.d, read.d -(def-inline clear-output :always (stream) NULL "(ecl_clear_output(#0),ECL_NIL)") +(def-inline cl:clear-output :always (stream) NULL "(ecl_clear_output(#0),ECL_NIL)") -(def-inline finish-output :always (stream) NULL "(ecl_finish_output(#0),ECL_NIL)") +(def-inline cl:finish-output :always (stream) NULL "(ecl_finish_output(#0),ECL_NIL)") -(def-inline finish-output :always (stream) NULL "(ecl_force_output(#0),ECL_NIL)") +(def-inline cl:finish-output :always (stream) NULL "(ecl_force_output(#0),ECL_NIL)") -(def-inline write-char :always (t) t "@0;(ecl_princ_char(ecl_char_code(#0),ECL_NIL),(#0))") +(def-inline cl:write-char :always (t) t "@0;(ecl_princ_char(ecl_char_code(#0),ECL_NIL),(#0))") -(def-inline clear-input :always (stream) NULL "(ecl_clear_input(#0),ECL_NIL)") +(def-inline cl:clear-input :always (stream) NULL "(ecl_clear_input(#0),ECL_NIL)") -(def-inline copy-readtable :always (null null) t "standard_readtable") +(def-inline cl:copy-readtable :always (null null) t "standard_readtable") -(def-inline boundp :always (t) :bool "ecl_boundp(cl_env_copy,#0)") -(def-inline boundp :unsafe ((and symbol (not null))) :bool "ECL_SYM_VAL(cl_env_copy,#0)!=OBJNULL") +(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") ;; file unixsys.d ;; file sequence.d -(def-inline elt :always (t t) t "ecl_elt(#0,ecl_to_size(#1))") -(def-inline elt :always (t fixnum) t "ecl_elt(#0,#1)") +(def-inline cl:elt :always (t t) t "ecl_elt(#0,ecl_to_size(#1))") +(def-inline cl:elt :always (t fixnum) t "ecl_elt(#0,#1)") -(def-inline elt :unsafe (t t) t "ecl_elt(#0,ecl_fixnum(#1))") -(def-inline elt :unsafe (t fixnum) t "ecl_elt(#0,#1)") -(def-inline elt :unsafe (vector t) t "ecl_aref_unsafe(#0,ecl_fixnum(#1))") -(def-inline elt :unsafe (vector fixnum) t "ecl_aref_unsafe(#0,#1)") -(def-inline aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))") -(def-inline aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") +(def-inline cl:elt :unsafe (t t) t "ecl_elt(#0,ecl_fixnum(#1))") +(def-inline cl:elt :unsafe (t fixnum) t "ecl_elt(#0,#1)") +(def-inline cl:elt :unsafe (vector t) t "ecl_aref_unsafe(#0,ecl_fixnum(#1))") +(def-inline cl:elt :unsafe (vector fixnum) t "ecl_aref_unsafe(#0,#1)") +(def-inline cl:aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))") +(def-inline cl:aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") #+unicode -(def-inline aref :unsafe ((array character) fixnum) :wchar +(def-inline cl:aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]") -(def-inline aref :unsafe ((array base-char) fixnum) :unsigned-char +(def-inline cl:aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]") -(def-inline aref :unsafe ((array double-float) fixnum) :double +(def-inline cl:aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]") -(def-inline aref :unsafe ((array single-float) fixnum) :float +(def-inline cl:aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]") -(def-inline aref :unsafe ((array fixnum) fixnum) :fixnum +(def-inline cl:aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]") (def-inline si:elt-set :always (t t t) t "ecl_elt_set(#0,ecl_to_size(#1),#2)") @@ -659,22 +659,22 @@ (def-inline si:elt-set :unsafe (vector t t) t "ecl_aset_unsafe(#0,ecl_to_size(#1),#2)") (def-inline si:elt-set :unsafe (vector fixnum t) t "ecl_aset_unsafe(#0,#1,#2)") -(def-inline length :always (t) :fixnum "ecl_length(#0)") -(def-inline length :unsafe (vector) :fixnum "(#0)->vector.fillp") +(def-inline cl:length :always (t) :fixnum "ecl_length(#0)") +(def-inline cl:length :unsafe (vector) :fixnum "(#0)->vector.fillp") -(def-inline copy-seq :always (t) t "ecl_copy_seq(#0)") +(def-inline cl:copy-seq :always (t) t "ecl_copy_seq(#0)") ;; file character.d -(def-inline char :always (t fixnum) t "ecl_aref1(#0,#1)") -(def-inline char :always (t fixnum) :wchar "ecl_char(#0,#1)") +(def-inline cl:char :always (t fixnum) t "ecl_aref1(#0,#1)") +(def-inline cl:char :always (t fixnum) :wchar "ecl_char(#0,#1)") #-unicode -(def-inline char :unsafe (t t) t "ECL_CODE_CHAR((#0)->base_string.self[ecl_fixnum(#1)])") +(def-inline cl:char :unsafe (t t) t "ECL_CODE_CHAR((#0)->base_string.self[ecl_fixnum(#1)])") #-unicode -(def-inline char :unsafe (t fixnum) :unsigned-char "(#0)->base_string.self[#1]") -(def-inline char :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]") +(def-inline cl:char :unsafe (t fixnum) :unsigned-char "(#0)->base_string.self[#1]") +(def-inline cl:char :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]") #+unicode -(def-inline char :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") +(def-inline cl:char :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") (def-inline si:char-set :always (t t t) t "si_char_set(#0,#1,#2)") (def-inline si:char-set :always (t fixnum t) t "ecl_aset1(#0,#1,#2)") @@ -694,15 +694,15 @@ (def-inline si:char-set :unsafe (ext:extended-string fixnum character) :unsigned-char "(#0)->string.self[#1]= #2") -(def-inline schar :always (t t) t "ecl_elt(#0,ecl_to_size(#1))") -(def-inline schar :always (t fixnum) t "ecl_elt(#0,#1)") -(def-inline schar :always (t fixnum) :wchar "ecl_char(#0,#1)") -(def-inline schar :unsafe (base-string t) t "ECL_CODE_CHAR((#0)->base_string.self[ecl_fixnum(#1)])") +(def-inline cl:schar :always (t t) t "ecl_elt(#0,ecl_to_size(#1))") +(def-inline cl:schar :always (t fixnum) t "ecl_elt(#0,#1)") +(def-inline cl:schar :always (t fixnum) :wchar "ecl_char(#0,#1)") +(def-inline cl:schar :unsafe (base-string t) t "ECL_CODE_CHAR((#0)->base_string.self[ecl_fixnum(#1)])") #-unicode -(def-inline schar :unsafe (t fixnum) :unsigned-char "(#0)->base_string.self[#1]") -(def-inline schar :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]") +(def-inline cl:schar :unsafe (t fixnum) :unsigned-char "(#0)->base_string.self[#1]") +(def-inline cl:schar :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]") #+unicode -(def-inline schar :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") +(def-inline cl:schar :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") (def-inline si:schar-set :always (t t t) t "ecl_elt_set(#0,ecl_to_size(#1),#2)") (def-inline si:schar-set :always (t fixnum t) t "ecl_elt_set(#0,#1,#2)") @@ -724,7 +724,7 @@ (def-inline si:schar-set :unsafe (ext:extended-string fixnum character) :wchar "(#0)->string.self[#1]= #2") -(def-inline string= :always (string string) :bool "ecl_string_eq(#0,#1)") +(def-inline cl:string= :always (string string) :bool "ecl_string_eq(#0,#1)") ;; file structure.d @@ -737,10 +737,10 @@ ;; file symbol.d -(def-inline get :always (t t t) t "ecl_get(#0,#1,#2)") -(def-inline get :always (t t) t "ecl_get(#0,#1,ECL_NIL)") +(def-inline cl:get :always (t t t) t "ecl_get(#0,#1,#2)") +(def-inline cl:get :always (t t) t "ecl_get(#0,#1,ECL_NIL)") -(def-inline symbol-name :always (t) string "ecl_symbol_name(#0)") +(def-inline cl:symbol-name :always (t) string "ecl_symbol_name(#0)") ;; Additions used by the compiler. ;; The following functions do not exist. They are always expanded into the @@ -836,10 +836,10 @@ #+clos (def-inline si:instance-class :always (standard-object) t "ECL_CLASS_OF(#0)") #+clos -(def-inline class-of :unsafe (standard-object) t "ECL_CLASS_OF(#0)") +(def-inline cl:class-of :unsafe (standard-object) t "ECL_CLASS_OF(#0)") #+clos -(def-inline si::instancep :always (t) :bool "@0;ECL_INSTANCEP(#0)") +(def-inline si:instancep :always (t) :bool "@0;ECL_INSTANCEP(#0)") #+clos (def-inline si:unbound :always nil t "ECL_UNBOUND") -- GitLab From e4988d1f7c23647fa3ccf2407aa789dc13bbcd8c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 14 Feb 2023 11:42:20 +0100 Subject: [PATCH 08/33] cmp: don't USE the package EXT --- src/cmp/cmparray.lsp | 24 ++++++++++++------------ src/cmp/cmpc-wt.lsp | 2 +- src/cmp/cmpenv-api.lsp | 2 +- src/cmp/cmpmac.lsp | 4 ++-- src/cmp/cmpmap.lsp | 2 +- src/cmp/cmpnum.lsp | 12 ++++++------ src/cmp/cmpopt-bits.lsp | 8 ++++---- src/cmp/cmpopt-cons.lsp | 2 +- src/cmp/cmpopt-sequence.lsp | 14 +++++++------- src/cmp/cmpopt.lsp | 6 +++--- src/cmp/cmppackage.lsp | 3 ++- src/cmp/cmppass1-call.lsp | 4 ++-- src/cmp/cmppass1-special.lsp | 6 +++--- src/cmp/cmppass1-var.lsp | 8 ++++---- src/cmp/cmptables.lsp | 6 +++--- src/cmp/cmptype-assert.lsp | 10 +++++----- src/cmp/cmptype.lsp | 6 +++--- src/cmp/cmputil.lsp | 6 +++--- 18 files changed, 63 insertions(+), 62 deletions(-) diff --git a/src/cmp/cmparray.lsp b/src/cmp/cmparray.lsp index 191931b59..1a6540da8 100644 --- a/src/cmp/cmparray.lsp +++ b/src/cmp/cmparray.lsp @@ -80,8 +80,8 @@ ,%displaced-to ,%displaced-index-offset))) ;; Then we may fill the array with a given value (when initial-element-supplied-p - (setf form `(si::fill-array-with-elt ,form ,%initial-element 0 nil))) - (setf form `(truly-the (array ,guessed-element-type ,dimensions-type) + (setf form `(si:fill-array-with-elt ,form ,%initial-element 0 nil))) + (setf form `(ext:truly-the (array ,guessed-element-type ,dimensions-type) ,form)))) form) @@ -92,7 +92,7 @@ (defun expand-vector-push (whole env extend &aux (args (rest whole))) (declare (si::c-local) (ignore env)) - (with-clean-symbols (value vector index dimension) + (ext:with-clean-symbols (value vector index dimension) (when (or (eq (first args) 'value) ; No infinite recursion (not (policy-open-code-aref/aset))) (return-from expand-vector-push @@ -114,8 +114,8 @@ (declare (fixnum index dimension) (:read-only index dimension)) (cond ((< index dimension) - (sys::fill-pointer-set vector (truly-the fixnum (+ 1 index))) - (sys::aset vector index value) + (si:fill-pointer-set vector (ext:truly-the fixnum (+ 1 index))) + (si:aset vector index value) index) (t ,(if extend `(vector-push-extend value vector ,@(cddr args)) @@ -137,7 +137,7 @@ form)) (defun expand-aref (array indices env) - (with-clean-symbols (%array) + (ext:with-clean-symbols (%array) `(let ((%array ,array)) (declare (:read-only %array) (optimize (safety 0))) @@ -162,11 +162,11 @@ `(let* ((,%array ,array)) (declare (:read-only ,%array) (optimize (safety 0))) - (si::row-major-aset ,%array ,(expand-row-major-index %array indices env) ,value)))) + (si:row-major-aset ,%array ,(expand-row-major-index %array indices env) ,value)))) (define-compiler-macro array-row-major-index (&whole form array &rest indices &environment env) (if (policy-open-code-aref/aset env) - (with-clean-symbols (%array) + (ext:with-clean-symbols (%array) `(let ((%array ,array)) (declare (:read-only %array) (optimize (safety 0))) @@ -188,7 +188,7 @@ (check-vector-in-bounds ,a ,index) ,index))) (if (policy-type-assertions env) - (with-clean-symbols (%array-index) + (ext:with-clean-symbols (%array-index) `(let ((%array-index ,index)) (declare (:read-only %array-index)) ,(expansion a '%array-index))) @@ -207,7 +207,7 @@ for index in indices collect `(,(gentemp "DIM") (array-dimension-fast ,a ,i)))) (dim-names (mapcar #'first dims))) - (with-clean-symbols (%ndx-var %output-var %dim-var) + (ext:with-clean-symbols (%ndx-var %output-var %dim-var) `(let* (,@dims (%output-var 0)) (declare (type ext:array-index %output-var ,@dim-names) @@ -221,12 +221,12 @@ for dim-var in dim-names when (plusp i) collect `(setf %output-var - (truly-the ext:array-index (* %output-var ,dim-var))) + (ext:truly-the ext:array-index (* %output-var ,dim-var))) collect `(let ((%ndx-var ,index)) (declare (ext:array-index %ndx-var)) ,(and check `(check-index-in-bounds ,a %ndx-var ,dim-var)) (setf %output-var - (truly-the ext:array-index (+ %output-var %ndx-var))))) + (ext:truly-the ext:array-index (+ %output-var %ndx-var))))) %output-var)))) ;(trace c::expand-row-major-index c::expand-aset c::expand-aref) diff --git a/src/cmp/cmpc-wt.lsp b/src/cmp/cmpc-wt.lsp index 1a681455c..6e6d64e8b 100644 --- a/src/cmp/cmpc-wt.lsp +++ b/src/cmp/cmpc-wt.lsp @@ -178,7 +178,7 @@ :element-type 'base-char :adjustable t :fill-pointer 0)) - (stream (make-sequence-output-stream output :external-format format))) + (stream (ext:make-sequence-output-stream output :external-format format))) (write-string string stream) output)) diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index e2c88b19c..91f5c870a 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -49,7 +49,7 @@ the closure in let/flet forms for variables/functions it closes over." `(progn ,@(rest record-def))) record-lexenv env))) (setf definition - `(flet ((,(compiled-function-name record) + `(flet ((,(ext:compiled-function-name record) ,@record-def)) ,definition)))) ((and (listp record) (symbolp (car record))) diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp index 82c46afd4..ed8ca3ec5 100644 --- a/src/cmp/cmpmac.lsp +++ b/src/cmp/cmpmac.lsp @@ -32,8 +32,8 @@ (declare (type (integer 0 1023) hash) (type (array t (*)) ,cache-name)) (if (and elt ,@(loop for arg in lambda-list - collect `(,test (pop (truly-the cons elt)) ,arg))) - (first (truly-the cons elt)) + collect `(,test (pop (ext:truly-the cons elt)) ,arg))) + (first (ext:truly-the cons elt)) (let ((output (,name ,@lambda-list))) (setf (aref ,cache-name hash) (list ,@lambda-list output)) output)))))))) diff --git a/src/cmp/cmpmap.lsp b/src/cmp/cmpmap.lsp index 7517d6891..16d40a03f 100644 --- a/src/cmp/cmpmap.lsp +++ b/src/cmp/cmpmap.lsp @@ -46,7 +46,7 @@ (MAPCAN (setf do-or-collect 'NCONC)) (MAPCON (setf in-or-on :ON do-or-collect 'NCONC))) (when (eq in-or-on :ON) - (setf args (mapcar #'(lambda (arg) `(checked-value list ,arg)) args))) + (setf args (mapcar #'(lambda (arg) `(ext:checked-value list ,arg)) args))) (when (eq do-or-collect :DO) (let ((var (gensym))) (setf list-1-form `(with ,var = ,(first args)) diff --git a/src/cmp/cmpnum.lsp b/src/cmp/cmpnum.lsp index 62c3938da..54a59fe67 100644 --- a/src/cmp/cmpnum.lsp +++ b/src/cmp/cmpnum.lsp @@ -23,12 +23,12 @@ (define-compiler-macro boole (&whole form op-code op1 op2) (or (and (constantp op-code *cmp-env*) (case (ext:constant-form-value op-code *cmp-env*) - (#. boole-clr `(progn (checked-value integer ,op1) (checked-value integer ,op2) 0)) - (#. boole-set `(progn (checked-value integer ,op1) (checked-value integer ,op2) -1)) - (#. boole-1 `(prog1 (checked-value integer ,op1) (checked-value integer ,op2))) - (#. boole-2 `(progn (checked-value integer ,op1) (checked-value integer ,op2))) - (#. boole-c1 `(prog1 (lognot ,op1) (checked-value integer ,op2))) - (#. boole-c2 `(progn (checked-value integer ,op1) (lognot ,op2))) + (#. boole-clr `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) 0)) + (#. boole-set `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) -1)) + (#. boole-1 `(prog1 (ext:checked-value integer ,op1) (ext:checked-value integer ,op2))) + (#. boole-2 `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2))) + (#. boole-c1 `(prog1 (lognot ,op1) (ext:checked-value integer ,op2))) + (#. boole-c2 `(progn (ext:checked-value integer ,op1) (lognot ,op2))) (#. boole-and `(logand ,op1 ,op2)) (#. boole-ior `(logior ,op1 ,op2)) (#. boole-xor `(logxor ,op1 ,op2)) diff --git a/src/cmp/cmpopt-bits.lsp b/src/cmp/cmpopt-bits.lsp index 6e622b957..88c7d42b3 100644 --- a/src/cmp/cmpopt-bits.lsp +++ b/src/cmp/cmpopt-bits.lsp @@ -30,7 +30,7 @@ (define-compiler-macro ldb (&whole whole bytespec integer) (if (inline-bytespec bytespec) - (with-clean-symbols (%pos %size) + (ext:with-clean-symbols (%pos %size) `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) (%pos ,(third bytespec) unsigned-byte)) (logand (lognot (ash -1 %size)) (ash ,integer (- %pos))))) @@ -43,7 +43,7 @@ (define-compiler-macro mask-field (&whole whole bytespec integer) (if (inline-bytespec bytespec) - (with-clean-symbols (%pos %size) + (ext:with-clean-symbols (%pos %size) `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) (%pos ,(third bytespec) unsigned-byte)) (logand (ash (lognot (ash -1 %size)) %pos) @@ -52,7 +52,7 @@ (define-compiler-macro dpb (&whole whole newbyte bytespec integer) (if (inline-bytespec bytespec) - (with-clean-symbols (%pos %size %mask) + (ext:with-clean-symbols (%pos %size %mask) `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) (%pos ,(third bytespec) unsigned-byte) (%mask (ash (lognot (ash -1 %size)) %pos) t)) @@ -62,7 +62,7 @@ (define-compiler-macro deposit-field (&whole whole newbyte bytespec integer) (if (inline-bytespec bytespec) - (with-clean-symbols (%pos %size %mask) + (ext:with-clean-symbols (%pos %size %mask) `(with-let*-type-check ((%size ,(second bytespec) unsigned-byte) (%pos ,(third bytespec) unsigned-byte) (%mask (ash (lognot (ash -1 %size)) %pos) t)) diff --git a/src/cmp/cmpopt-cons.lsp b/src/cmp/cmpopt-cons.lsp index 4dd6e2b0b..dba9e7649 100644 --- a/src/cmp/cmpopt-cons.lsp +++ b/src/cmp/cmpopt-cons.lsp @@ -22,7 +22,7 @@ (loop for v in values for value-and-type in arg-types collect (if (consp value-and-type) - `(checked-value ,(second value-and-type) ,v) + `(ext:checked-value ,(second value-and-type) ,v) v))) ,@inline-form)) diff --git a/src/cmp/cmpopt-sequence.lsp b/src/cmp/cmpopt-sequence.lsp index 43de356e0..e6f793572 100644 --- a/src/cmp/cmpopt-sequence.lsp +++ b/src/cmp/cmpopt-sequence.lsp @@ -41,7 +41,7 @@ #+(or) (define-compiler-macro si::make-seq-iterator (seq &optional (start 0)) - (with-clean-symbols (%seq %start) + (ext:with-clean-symbols (%seq %start) `(let ((%seq (optional-type-check ,seq sequence)) (%start ,start)) (cond ((consp %seq) @@ -53,7 +53,7 @@ #+(or) (define-compiler-macro si::seq-iterator-ref (seq iterator) - (with-clean-symbols (%seq %iterator) + (ext:with-clean-symbols (%seq %iterator) `(let* ((%seq ,seq) (%iterator ,iterator)) (declare (optimize (safety 0))) @@ -61,18 +61,18 @@ ;; Fixnum iterators are always fine (aref %seq %iterator) ;; Error check in case we may have been passed an improper list - (si:cons-car (checked-value cons %iterator)))))) + (si:cons-car (ext:checked-value cons %iterator)))))) #+(or) (define-compiler-macro si::seq-iterator-next (seq iterator) - (with-clean-symbols (%seq %iterator) + (ext:with-clean-symbols (%seq %iterator) `(let* ((%seq ,seq) (%iterator ,iterator)) (declare (optimize (safety 0))) - (if (si::fixnump %iterator) - (let ((%iterator (1+ (truly-the fixnum %iterator)))) + (if (ext:fixnump %iterator) + (let ((%iterator (1+ (ext:truly-the fixnum %iterator)))) (declare (fixnum %iterator)) - (and (< %iterator (length (truly-the vector %seq))) + (and (< %iterator (length (ext:truly-the vector %seq))) %iterator)) (si:cons-cdr %iterator))))) diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp index b591d0ccc..f49f96fab 100644 --- a/src/cmp/cmpopt.lsp +++ b/src/cmp/cmpopt.lsp @@ -138,7 +138,7 @@ (type ,first ,var2)) (AND (TYPEP ,var1 ',first) (locally (declare (optimize (speed 3) (safety 0) (space 0))) - (setf ,var2 (truly-the ,first ,var1)) + (setf ,var2 (ext:truly-the ,first ,var1)) (AND ,@(expand-in-interval-p var2 rest))))))) ;; ;; Compound COMPLEX types. @@ -188,7 +188,7 @@ (list-var (gensym)) (typed-var (if (policy-assume-no-errors env) list-var - `(truly-the cons ,list-var)))) + `(ext:truly-the cons ,list-var)))) `(block nil (let* ((,list-var ,expression)) (si::while ,list-var @@ -351,7 +351,7 @@ (c-type (lisp-type->rep-type float))) `(let ((value ,value)) (declare (:read-only value)) - (compiler-typecase value + (ext:compiler-typecase value (,float value) (t (ffi:c-inline (value) (:object) ,c-type diff --git a/src/cmp/cmppackage.lsp b/src/cmp/cmppackage.lsp index 6f29de4ce..c04e8f213 100644 --- a/src/cmp/cmppackage.lsp +++ b/src/cmp/cmppackage.lsp @@ -16,7 +16,8 @@ (defpackage #:c (:nicknames #:compiler) - (:use #:cl #:ext) + (:use #:cl) + (:import-from #:ext #:install-c-compiler) (:export ;; Flags controlling the compiler behavior. #:*compiler-break-enable* diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index 859049d55..e0fbefa09 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -272,10 +272,10 @@ call-arguments-limit (+ (first requireds) (first optionals)))) (apply-constant-args-p (and apply-p (constantp apply-list) - (listp (constant-form-value apply-list)))) + (listp (ext:constant-form-value apply-list)))) (n-args-got-min (if apply-constant-args-p (+ (length arguments) - (length (constant-form-value apply-list))) + (length (ext:constant-form-value apply-list))) (length arguments))) (n-args-got-max (cond ((and apply-p (not apply-constant-args-p)) nil) ; unknown maximum number of arguments diff --git a/src/cmp/cmppass1-special.lsp b/src/cmp/cmppass1-special.lsp index 0fbd2f9a6..04e40a48c 100644 --- a/src/cmp/cmppass1-special.lsp +++ b/src/cmp/cmppass1-special.lsp @@ -32,7 +32,7 @@ (c1truly-the args)))) (defun c1truly-the (args) - (check-args-number 'TRULY-THE args 2 2) + (check-args-number 'ext:truly-the args 2 2) (let* ((form (c1expr (second args))) (the-type (first args)) type) @@ -43,7 +43,7 @@ form)) (defun c1compiler-let (args &aux (symbols nil) (values nil)) - (when (endp args) (too-few-args 'COMPILER-LET 1 0)) + (when (endp args) (too-few-args 'ext:compiler-let 1 0)) (dolist (spec (car args)) (cond ((consp spec) (cmpck (not (and (symbolp (car spec)) @@ -59,7 +59,7 @@ (setq symbols (nreverse symbols)) (setq values (nreverse values)) (setq args (progv symbols values (c1progn (cdr args)))) - (make-c1form 'COMPILER-LET args symbols values args)) + (make-c1form 'ext:compiler-let args symbols values args)) (defun c1function (args &aux fd) (check-args-number 'FUNCTION args 1 1) diff --git a/src/cmp/cmppass1-var.lsp b/src/cmp/cmppass1-var.lsp index 4a3f0bf4a..80b0b39bc 100644 --- a/src/cmp/cmppass1-var.lsp +++ b/src/cmp/cmppass1-var.lsp @@ -96,7 +96,7 @@ ((trivial-type-p type) (c1expr (first form))) (t - (c1expr `(checked-value ,type ,(first form))))))) + (c1expr `(ext:checked-value ,type ,(first form))))))) ;; :read-only variable handling. Beppe (when (read-only-variable-p name other-decls) (if (global-var-p var) @@ -309,7 +309,7 @@ (type (var-type name)) (form (c1expr (if (trivial-type-p type) form - `(checked-value ,type ,form))))) + `(ext:checked-value ,type ,form))))) (add-to-set-nodes name (make-c1form* 'SETQ :type (c1form-type form) :args name form))) @@ -356,7 +356,7 @@ (push vref vrefs) (push (c1expr (if (trivial-type-p type) form - `(checked-value ,type ,form))) + `(ext:checked-value ,type ,form))) forms)))) (defun c1multiple-value-bind (args) @@ -402,7 +402,7 @@ (let ((new-var (gensym))) (push new-var vars) (push new-var value-bindings) - (push `(setf ,var-or-form (checked-value ,type ,new-var)) storing-forms)))) + (push `(setf ,var-or-form (ext:checked-value ,type ,new-var)) storing-forms)))) (multiple-value-bind (setf-vars setf-vals stores storing-form get-form) (get-setf-expansion var-or-form *cmp-env*) (push (first stores) vars) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index c009a8511..bcbd32e0d 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -152,7 +152,7 @@ '((ext:with-backend . c1with-backend) ; t1 (cl:defmacro . t1defmacro) - (si:compiler-let . c1compiler-let) + (ext:compiler-let . c1compiler-let) (cl:eval-when . c1eval-when) (cl:progn . c1progn) (cl:macrolet . c1macrolet) @@ -235,7 +235,7 @@ (cl:multiple-value-bind . c2multiple-value-bind) (cl:function . c2function) - (si:compiler-let . c2compiler-let) + (ext:compiler-let . c2compiler-let) (with-stack . c2with-stack) (stack-push-values . c2stack-push-values) @@ -256,7 +256,7 @@ )) (defconstant +t2-dispatch-alist+ - '((si:compiler-let . t2compiler-let) + '((ext:compiler-let . t2compiler-let) (cl:progn . t2progn) (ordinary . t2ordinary) (cl:load-time-value . t2load-time-value) diff --git a/src/cmp/cmptype-assert.lsp b/src/cmp/cmptype-assert.lsp index be8fc7cd6..591b7f2c4 100644 --- a/src/cmp/cmptype-assert.lsp +++ b/src/cmp/cmptype-assert.lsp @@ -75,7 +75,7 @@ (symbol-macro-p value)) ;; If multiple references to the value cost time and space, ;; or may cause side effects, we save it. - (with-clean-symbols (%asserted-value) + (ext:with-clean-symbols (%asserted-value) `(let* ((%asserted-value ,value)) (declare (:read-only %asserted-value)) ,(expand-type-assertion '%asserted-value type env compulsory)))) @@ -126,14 +126,14 @@ value type) (cmpdebug "Checking type of ~S to be ~S" value type)) (let ((full-check - (with-clean-symbols (%checked-value) + (ext:with-clean-symbols (%checked-value) `(let* ((%checked-value ,value)) (declare (:read-only %checked-value)) ,(expand-type-assertion '%checked-value type *cmp-env* nil) ,(if (null and-type) '%checked-value - `(truly-the ,type %checked-value)))))) - (make-c1form* 'CHECKED-VALUE + `(ext:truly-the ,type %checked-value)))))) + (make-c1form* 'ext:CHECKED-VALUE :type type :args type form (c1expr full-check))))))) @@ -149,7 +149,7 @@ expression, ensuring that it is satisfied." (when (and (policy-type-assertions env) (not (trivial-type-p type))) (cmpdebug "Checking type of ~A to be ~A" value type) - `(checked-value ,type ,value))) + `(ext:checked-value ,type ,value))) (defmacro type-assertion (&whole whole value type &environment env) "Generates a type check on an expression, ensuring that it is satisfied." diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 828921372..664382292 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -119,7 +119,7 @@ ;; later due to this assertion... (setf (var-type var) t checks (list* `(type-assertion ,name ,type) checks) - new-auxs (list* `(truly-the ,type ,name) name new-auxs)) + new-auxs (list* `(ext:truly-the ,type ,name) name new-auxs)) ;; Or simply enforce the variable's type. (setf (var-type var) (type-and (var-type var) type)))) finally @@ -191,10 +191,10 @@ ((multiple-value-setq (valid value) (constant-value-p value env)) (si::maybe-quote value)) (t - (with-clean-symbols (%value) + (ext:with-clean-symbols (%value) `(let* ((%value ,value)) ,(type-error-check '%value (replace-invalid-types type)) - (truly-the ,type %value))))))) + (ext:truly-the ,type %value))))))) (defun replace-invalid-types (type) ;; Some types which are acceptable in DECLARE are not diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 9b6a92f2e..e9e154136 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -270,13 +270,13 @@ (return nil)) (flag (setf flag nil - fast (cdr (truly-the cons fast)))) + fast (cdr (ext:truly-the cons fast)))) ((eq slow fast) (return nil)) (t (setf flag t - slow (cdr (truly-the cons slow)) - fast (cdr (truly-the cons fast))))) + slow (cdr (ext:truly-the cons slow)) + fast (cdr (ext:truly-the cons fast))))) finally (return l))) (defun check-args-number (operator args &optional (min 0) (max most-positive-fixnum)) -- GitLab From 93fbbcccfc4f98ccdfa3f42ba1b1ed079d12a8de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 14 Feb 2023 12:14:10 +0100 Subject: [PATCH 09/33] cmp: more robust compiler-features collecting --- src/cmp/cmpglobals.lsp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index d66ba333b..e4ab12f33 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -59,7 +59,8 @@ each form it processes. The default value is NIL.") "This variable controls whether the compiler should display messages about its progress. The default value is T.") -(defvar *compiler-features* #+ecl-min nil #-ecl-min '#.*compiler-features* +(defvar *compiler-features* + '#.(if (not (boundp '*compiler-features*)) nil *compiler-features*) "This alternative list of features contains keywords that were gathered from running the compiler. It may be updated by running ") -- GitLab From 7f1f97e1c08f5fe757cede721c8b666a60af317d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 14 Feb 2023 13:41:27 +0100 Subject: [PATCH 10/33] cmp: cosmetic cleanups --- src/cmp/cmpenv-declaim.lsp | 4 ++-- src/cmp/cmpenv-declare.lsp | 4 ++-- src/cmp/cmpenv-proclaim.lsp | 2 +- src/cmp/cmpglobals.lsp | 12 ++++++------ src/cmp/cmppolicy.lsp | 10 +++++----- src/cmp/cmputil.lsp | 4 ++-- 6 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/cmp/cmpenv-declaim.lsp b/src/cmp/cmpenv-declaim.lsp index c93efbe00..33bd27b01 100644 --- a/src/cmp/cmpenv-declaim.lsp +++ b/src/cmp/cmpenv-declaim.lsp @@ -20,7 +20,7 @@ ;;;; stem from. ;;;; -(in-package #-ecl-new "COMPILER" #+ecl-new "C-ENV") +(in-package "COMPILER") (defun process-declaim-args (args) (flet ((add-variables (env types specials) @@ -29,7 +29,7 @@ do (let ((v (c1make-global-variable name :kind 'special))) (setf env (cmp-env-register-var v env nil)))) (loop for (name . type) in types - for specialp = (or (sys:specialp name) (member name specials)) + for specialp = (or (si:specialp name) (member name specials)) for kind = (if specialp 'SPECIAL 'GLOBAL) for v = (c1make-global-variable name :type type :kind kind) do (setf env (cmp-env-register-var v env nil))) diff --git a/src/cmp/cmpenv-declare.lsp b/src/cmp/cmpenv-declare.lsp index ff0a9d47e..139ee6f35 100644 --- a/src/cmp/cmpenv-declare.lsp +++ b/src/cmp/cmpenv-declare.lsp @@ -18,10 +18,10 @@ ;;;; compiled file and do not propagate beyond it. ;;;; -(in-package #-ecl-new "COMPILER" #+ecl-new "C-ENV") +(in-package "COMPILER") (defun valid-form-p (x &optional test) - (and (si::proper-list-p x) + (and (si:proper-list-p x) (or (null test) (every test x)))) diff --git a/src/cmp/cmpenv-proclaim.lsp b/src/cmp/cmpenv-proclaim.lsp index 171329502..546335a48 100644 --- a/src/cmp/cmpenv-proclaim.lsp +++ b/src/cmp/cmpenv-proclaim.lsp @@ -32,7 +32,7 @@ (cl:SPECIAL (dolist (var (cdr decl)) (if (symbolp var) - (sys:*make-special var) + (si:*make-special var) (error "Syntax error in proclamation ~s" decl)))) (cl:OPTIMIZE (dolist (x (cdr decl)) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index e4ab12f33..9df876fca 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -51,11 +51,11 @@ (defvar *compiler-conditions* '() "This variable determines whether conditions are printed or just accumulated.") -(defvar cl:*compile-print* nil +(defvar *compile-print* nil "This variable controls whether the compiler displays messages about each form it processes. The default value is NIL.") -(defvar cl:*compile-verbose* nil +(defvar *compile-verbose* nil "This variable controls whether the compiler should display messages about its progress. The default value is T.") @@ -305,7 +305,7 @@ be deleted if they have been opened with LoadLibrary.") ;;; If (safe-compile) is ON, some kind of run-time checks are not ;;; included in the compiled code. The default value is OFF. -(defconstant +init-env-form+ +(defvar +init-env-form+ '((*gensym-counter* 0) (*compiler-in-use* t) (*compiler-phase* 't1) @@ -336,7 +336,7 @@ be deleted if they have been opened with LoadLibrary.") (*machine* (or *machine* *default-machine*)) (*optimizable-constants* (make-optimizable-constants *machine*)) (*inline-information* - (let ((r (machine-inline-information *machine*))) - (if r (si::copy-hash-table r) (make-inline-information *machine*)))) - )) + (ext:if-let ((r (machine-inline-information *machine*))) + (si:copy-hash-table r) + (make-inline-information *machine*))))) diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index 9ef3d738d..c24eba1c9 100644 --- a/src/cmp/cmppolicy.lsp +++ b/src/cmp/cmppolicy.lsp @@ -39,7 +39,7 @@ for fun-name = (intern (concatenate 'string "POLICY-TO-" (symbol-name name) "-LEVEL")) collect `(defun ,fun-name (policy) - (declare (declaration ext:assume-right-type)) + (declare (ext:assume-right-type)) (loop for level from 0 to 3 when (logbitp (+ level ,i) policy) return level)))) @@ -54,9 +54,9 @@ (dolist (x arguments) (let (flags name value) (cond ((symbolp x) - (setq flags (optimization-quality-switches x 3) + (setq name x value 3 - name x)) + flags (optimization-quality-switches name value))) ((or (not (consp x)) (not (consp (cdr x))) (not (numberp (second x))) @@ -64,9 +64,9 @@ (t (setf name (first x) value (second x) - flags (optimization-quality-switches name (second x))))) + flags (optimization-quality-switches name value)))) (if (null flags) - (cmpwarn "Illegal or unknown OPTIMIZE proclamation ~s" x) + (cmpwarn "Illegal or unknown OPTIMIZE proclamation ~s." x) (setf on (logior on (car flags)) off (logior off (cdr flags)))))) ;;(format t "~%*~64b" bits) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index e9e154136..0efe8c84c 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -40,9 +40,9 @@ (when (wild-pathname-p path) (error "Cannot coerce ~A to a physical filename~%" path)) #+windows - (namestring (si::coerce-to-file-pathname path)) + (namestring (si:coerce-to-file-pathname path)) #-windows - (enough-namestring (si::coerce-to-file-pathname path))) + (enough-namestring (si:coerce-to-file-pathname path))) (defun normalize-build-target-name (target) (ecase target -- GitLab From 45bb774caff25a53a763d93f06ac1b744b13515b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 14 Feb 2023 14:16:54 +0100 Subject: [PATCH 11/33] cmp: values-type-and: fix a typo - we should use rest1 for reference --- src/cmp/cmptype-arith.lsp | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp index 6c7258926..22c5e0cfb 100644 --- a/src/cmp/cmptype-arith.lsp +++ b/src/cmp/cmptype-arith.lsp @@ -67,10 +67,11 @@ (defun valid-type-specifier (type) (handler-case - (if (subtypep type 'T) - (values t type) - (values nil nil)) - (error (c) (values nil nil)))) + (if (subtypep type 'T) + (values t type) + (values nil nil)) + (error () + (values nil nil)))) (defun known-type-p (type) (subtypep type T)) @@ -264,8 +265,8 @@ (opt2 (push (type-and t1 (pop opt2)) opt)) (rest2 (push (type-and t1 (first rest2)) opt)) (t (setf opt1 nil rest1 nil) (return)))) - (when rest - (let ((t1 (first rest))) + (when rest1 + (let ((t1 (first rest1))) (loop for t2 in req2 do (push (type-and t1 t2) req)) (loop for t2 in opt2 -- GitLab From f38ef8ee2b656ad37c7dbae2539606475d65fb98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 14 Feb 2023 14:51:09 +0100 Subject: [PATCH 12/33] cmp: cleanup: add ignore declarations, remove unused args etc --- src/cmp/cmpc-inliner.lsp | 4 +- src/cmp/cmpc-wt.lsp | 9 +- src/cmp/cmpinline.lsp | 8 +- src/cmp/cmppass1-call.lsp | 6 +- src/cmp/cmppass1-data.lsp | 2 +- src/cmp/cmppass1-fun.lsp | 1 + src/cmp/cmppass1-special.lsp | 2 +- src/cmp/cmppass1-stack.lsp | 1 + src/cmp/cmppass1-top.lsp | 2 +- src/cmp/cmpprop.lsp | 174 +++++++++++++++++++++-------------- src/cmp/cmptype-assert.lsp | 4 +- src/cmp/cmptype.lsp | 5 +- 12 files changed, 128 insertions(+), 90 deletions(-) diff --git a/src/cmp/cmpc-inliner.lsp b/src/cmp/cmpc-inliner.lsp index ed0540d41..a507a4d23 100644 --- a/src/cmp/cmpc-inliner.lsp +++ b/src/cmp/cmpc-inliner.lsp @@ -51,14 +51,14 @@ ;; the variable *INLINE-BLOCKS*. (and (inline-possible fname) (not (gethash fname *c2-dispatch-table*)) - (let* ((dest-rep-type (loc-representation-type *destination*)) + (let* (;; (dest-rep-type (loc-representation-type *destination*)) (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)) + ;; (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))) diff --git a/src/cmp/cmpc-wt.lsp b/src/cmp/cmpc-wt.lsp index 6e6d64e8b..4514a4640 100644 --- a/src/cmp/cmpc-wt.lsp +++ b/src/cmp/cmpc-wt.lsp @@ -64,14 +64,16 @@ (mapc #'wt1 forms)) ;;; Blocks beyond this value will not be indented -(defvar +max-depth+ 10) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar +max-depth+ 10)) + (defvar +c-newline-indent-strings+ #.(coerce (let ((basis (make-array (1+ +max-depth+) :initial-element #\Space :element-type 'base-char))) (setf (aref basis 0) #\Newline) (loop for i from 0 to +max-depth+ - collect (subseq basis 0 (1+ i)))) + collect (subseq basis 0 (1+ i)))) 'vector)) (defun wt-nl-indent () @@ -136,7 +138,7 @@ ((or (eq c #\Newline) (eq c #\Tab)) (princ c stream)) ((or (< code 32) (> code 127)) - (format stream "\ux" code)) + (format stream "\u~x" code)) ((and (char= c #\*) (char= (schar text (1+ n)) #\/)) (princ #\\ stream)) (t @@ -184,6 +186,7 @@ (defun wt-filtered-data (string stream &key one-liner (external-format #-unicode :default #+unicode :utf-8)) + (declare (ignorable external-format)) #+unicode (setf string (encode-string string external-format)) (let ((N (length string)) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index b0ff95964..086fa9bce 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -110,7 +110,7 @@ (c2expr* form) (list type temp)) (list type - (list 'SYS:STRUCTURE-REF + (list 'si:STRUCTURE-REF (first (coerce-locs (inline-args (list (c1form-arg 0 form))))) (c1form-arg 1 form) @@ -125,7 +125,7 @@ (c2expr* form) (list type temp)) (list type - (list 'SYS:INSTANCE-REF + (list 'si:instance-ref (first (coerce-locs (inline-args (list (c1form-arg 0 form))))) (c1form-arg 1 form) @@ -140,10 +140,10 @@ (emit-inlined-variable form forms)) (CALL-GLOBAL (emit-inlined-call-global form (c1form-primary-type form))) - (SYS:STRUCTURE-REF + (si:STRUCTURE-REF (emit-inlined-structure-ref form forms)) #+clos - (SYS:INSTANCE-REF + (si:INSTANCE-REF (emit-inlined-instance-ref form forms)) (SETQ (emit-inlined-setq form forms)) diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index e0fbefa09..762900507 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -24,7 +24,7 @@ (defun unoptimized-funcall (fun arguments) (let ((l (length arguments))) - (if (<= l si::c-arguments-limit) + (if (<= l si:c-arguments-limit) (make-c1form* 'FUNCALL :sp-change t :side-effects t :args (c1expr fun) (c1args* arguments)) (unoptimized-long-call fun arguments)))) @@ -101,7 +101,7 @@ form))) (let* ((fun (first args)) (arguments (rest args))) - (cond ((eql (first (last arguments)) 'clos::.combined-method-args.) + (cond ((eql (first (last arguments)) 'clos:.combined-method-args.) ;; Uses frames instead of lists as last argumennt (default-apply fun arguments)) ((and (consp fun) @@ -257,7 +257,7 @@ ;;; arguments) expression into an equivalent let* statement. Returns ;;; the bindings and body as two values. (defun transform-funcall/apply-into-let* (lambda-form arguments apply-p - &aux body apply-list apply-var + &aux apply-list apply-var let-vars extra-stmts all-keys) (multiple-value-bind (requireds optionals rest key-flag keywords allow-other-keys aux-vars) diff --git a/src/cmp/cmppass1-data.lsp b/src/cmp/cmppass1-data.lsp index 89f57cc54..01bddb9ef 100644 --- a/src/cmp/cmppass1-data.lsp +++ b/src/cmp/cmppass1-data.lsp @@ -121,7 +121,7 @@ ;; inconsistent. ((and (not item) (not duplicate) (symbolp object) (multiple-value-bind (foundp symbol) - (si::mangle-name object) + (si:mangle-name object) (and foundp (return-from add-object symbol))))) (t diff --git a/src/cmp/cmppass1-fun.lsp b/src/cmp/cmppass1-fun.lsp index 5f4c0809d..da447459f 100644 --- a/src/cmp/cmppass1-fun.lsp +++ b/src/cmp/cmppass1-fun.lsp @@ -278,6 +278,7 @@ (var (c1make-var name ss is ts)) (init (third specs)) (flag (fourth specs))) + (declare (ignore key)) (setq init (if init (and-form-type (var-type var) (c1expr init) init :safe "In (LAMBDA ~a...)" function-name) diff --git a/src/cmp/cmppass1-special.lsp b/src/cmp/cmppass1-special.lsp index 04e40a48c..e40b681ae 100644 --- a/src/cmp/cmppass1-special.lsp +++ b/src/cmp/cmppass1-special.lsp @@ -61,7 +61,7 @@ (setq args (progv symbols values (c1progn (cdr args)))) (make-c1form 'ext:compiler-let args symbols values args)) -(defun c1function (args &aux fd) +(defun c1function (args) (check-args-number 'FUNCTION args 1 1) (let ((fun (car args))) (cond ((si::valid-function-name-p fun) diff --git a/src/cmp/cmppass1-stack.lsp b/src/cmp/cmppass1-stack.lsp index f45ed4ecc..ff091691b 100644 --- a/src/cmp/cmppass1-stack.lsp +++ b/src/cmp/cmppass1-stack.lsp @@ -30,6 +30,7 @@ :args body))) (defun c1innermost-stack-frame (args) + (declare (ignore args)) `(ffi:c-inline () () :object "_ecl_inner_frame" :one-liner t :side-effects nil)) diff --git a/src/cmp/cmppass1-top.lsp b/src/cmp/cmppass1-top.lsp index ee4fed445..22f6df3ca 100644 --- a/src/cmp/cmppass1-top.lsp +++ b/src/cmp/cmppass1-top.lsp @@ -117,7 +117,7 @@ (destructuring-bind (name lambda-list &rest body) args (multiple-value-bind (function pprint doc-string) - (sys::expand-defmacro name lambda-list body) + (si:expand-defmacro name lambda-list body) (declare (ignore pprint doc-string)) (let ((fn (cmp-eval function *cmp-env*))) (cmp-env-register-global-macro name fn)) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 1d4f3b010..8cbce8b8b 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -22,9 +22,11 @@ `(format *standard-output* ,string ,@args)))) (defun p1ordinary (c1form assumptions form) + (declare (ignore c1form)) (p1propagate form assumptions)) (defun p1fset (c1form assumptions fun fname macro pprint c1forms) + (declare (ignore c1form fun fname macro pprint c1forms)) (values 'function assumptions)) (defun p1propagate (form assumptions) @@ -67,13 +69,14 @@ (values type assumptions))) (defun p1values (form assumptions values) + (declare (ignore form)) (loop for v in values - collect (multiple-value-bind (type new-assumptions) - (p1propagate v assumptions) - (setf assumptions new-assumptions) - (values-type-primary-type type)) - into all-values - finally (return (values `(values ,@all-values) assumptions)))) + collect (multiple-value-bind (type new-assumptions) + (p1propagate v assumptions) + (setf assumptions new-assumptions) + (values-type-primary-type type)) + into all-values + finally (return (values `(values ,@all-values) assumptions)))) (defun p1propagate-list (list assumptions) (loop with final-type = t @@ -91,10 +94,12 @@ of the occurrences in those lists." (baboon :format-control "P1MERGE-BRANCHES got a non-empty list of assumptions"))) (defun revise-var-type (variable assumptions where-to-stop) + (declare (ignore variable)) (unless (and (null assumptions) (null where-to-stop)) (baboon :format-control "REVISE-VAR-TYPE got a non-empty list of assumptions"))) (defun p1block (c1form assumptions blk body) + (declare (ignore c1form)) (setf (blk-type blk) nil) (multiple-value-bind (normal-type assumptions) (p1propagate body assumptions) @@ -103,6 +108,7 @@ of the occurrences in those lists." assumptions)))) (defun p1return-from (c1form assumptions blk return-type value) + (declare (ignore c1form return-type)) (let* ((values-type (p1propagate value assumptions)) (blk-type (blk-type blk))) (setf (blk-type blk) (if blk-type @@ -111,39 +117,49 @@ of the occurrences in those lists." (values values-type assumptions))) (defun p1call-global (c1form assumptions fname args) + (declare (ignore c1form)) (loop for v in args - do (multiple-value-bind (arg-type local-ass) - (p1propagate v assumptions) - (setf assumptions local-ass)) - finally (let ((type (propagate-types fname args))) - (prop-message "~&;;; Computing output of function ~A with args~&;;; ~{ ~A~}~&;;; gives ~A, while before ~A" - fname (mapcar #'c1form-primary-type args) - type (c1form-type c1form)) - (return (values type assumptions))))) + do (multiple-value-bind (arg-type local-ass) + (p1propagate v assumptions) + (declare (ignore arg-type)) + (setf assumptions local-ass)) + finally (let ((type (propagate-types fname args))) + (prop-message "~&;;; Computing output of function ~A with args~&;;; ~{ ~A~}~&;;; gives ~A, while before ~A" + fname (mapcar #'c1form-primary-type args) + type (c1form-type c1form)) + (return (values type assumptions))))) (defun p1call-local (c1form assumptions fun args) + (declare (ignore c1form)) (loop for v in args - do (multiple-value-bind (arg-type local-ass) - (p1propagate v assumptions) - (setf assumptions local-ass)) - finally (return (values (fun-return-type fun) - assumptions)))) + do (multiple-value-bind (arg-type local-ass) + (p1propagate v assumptions) + (declare (ignore arg-type)) + (setf assumptions local-ass)) + finally (return (values (fun-return-type fun) + assumptions)))) (defun p1catch (c1form assumptions tag body) + (declare (ignore c1form)) (multiple-value-bind (tag-type assumptions) (p1propagate tag assumptions) + (declare (ignore tag-type)) (p1propagate body assumptions)) (values t assumptions)) (defun p1throw (c1form assumptions catch-value output-value) + (declare (ignore c1form)) (multiple-value-bind (type new-assumptions) (p1propagate catch-value assumptions) + (declare (ignore type)) (p1propagate output-value new-assumptions)) (values t assumptions)) (defun p1if (c1form assumptions fmla true-branch false-branch) + (declare (ignore c1form)) (multiple-value-bind (fmla-type base-assumptions) (p1propagate fmla assumptions) + (declare (ignore fmla-type)) (multiple-value-bind (t1 a1) (p1propagate true-branch base-assumptions) (multiple-value-bind (t2 a2) @@ -152,40 +168,45 @@ of the occurrences in those lists." (p1merge-branches base-assumptions (list a1 a2))))))) (defun p1fmla-not (c1form assumptions form) + (declare (ignore c1form)) (multiple-value-bind (type assumptions) (p1propagate form assumptions) + (declare (ignore type)) (values '(member t nil) assumptions))) (defun p1fmla-and (c1form orig-assumptions butlast last) + (declare (ignore c1form)) (loop with type = t - with assumptions = orig-assumptions - for form in (append butlast (list last)) - collect (progn - (multiple-value-setq (type assumptions) - (p1propagate form assumptions)) - assumptions) - into assumptions-list - finally (return (values (type-or 'null (values-type-primary-type type)) - (p1merge-branches orig-assumptions - assumptions-list))))) + with assumptions = orig-assumptions + for form in (append butlast (list last)) + collect (progn + (multiple-value-setq (type assumptions) + (p1propagate form assumptions)) + assumptions) + into assumptions-list + finally (return (values (type-or 'null (values-type-primary-type type)) + (p1merge-branches orig-assumptions + assumptions-list))))) (defun p1fmla-or (c1form orig-assumptions butlast last) + (declare (ignore c1form)) (loop with type - with output-type = t - with assumptions = orig-assumptions - for form in (append butlast (list last)) - collect (progn - (multiple-value-setq (type assumptions) - (p1propagate form assumptions)) - (setf output-type (type-or (values-type-primary-type type) - output-type)) - assumptions) - into assumptions-list - finally (return (values output-type - (p1merge-branches orig-assumptions - assumptions-list))))) + with output-type = t + with assumptions = orig-assumptions + for form in (append butlast (list last)) + collect (progn + (multiple-value-setq (type assumptions) + (p1propagate form assumptions)) + (setf output-type (type-or (values-type-primary-type type) + output-type)) + assumptions) + into assumptions-list + finally (return (values output-type + (p1merge-branches orig-assumptions + assumptions-list))))) (defun p1lambda (c1form assumptions lambda-list doc body &rest not-used) + (declare (ignore c1form lambda-list doc not-used)) (prop-message "~&;;;~&;;; Propagating function~&;;;") (let ((type (p1propagate body assumptions))) (values type assumptions))) @@ -197,66 +218,75 @@ of the occurrences in those lists." assumptions))) (defun p1let* (c1form base-assumptions vars forms body) + (declare (ignore c1form)) (let ((assumptions base-assumptions)) (loop with type - for v in vars - for f in forms - unless (or (global-var-p v) (var-set-nodes v)) - do (progn - (multiple-value-setq (type assumptions) (p1propagate f assumptions)) - (setf (var-type v) (type-and (values-type-primary-type type) - (var-type v))) - (prop-message "~&;;; Variable ~A assigned type ~A" - (var-name v) (var-type v)))) + for v in vars + for f in forms + unless (or (global-var-p v) (var-set-nodes v)) + do (progn + (multiple-value-setq (type assumptions) (p1propagate f assumptions)) + (setf (var-type v) (type-and (values-type-primary-type type) + (var-type v))) + (prop-message "~&;;; Variable ~A assigned type ~A" + (var-name v) (var-type v)))) (multiple-value-bind (type assumptions) (p1propagate body assumptions) (loop for v in vars - do (revise-var-type v assumptions base-assumptions)) + do (revise-var-type v assumptions base-assumptions)) (values type assumptions)))) (defun p1locals (c1form assumptions funs body labels) + (declare (ignore c1form labels)) (loop for f in funs - do (p1propagate-function f assumptions)) + do (p1propagate-function f assumptions)) (p1propagate body assumptions)) (defun p1multiple-value-bind (c1form assumptions vars-list init-c1form body) + (declare (ignore c1form)) (multiple-value-bind (init-form-type assumptions) (p1propagate init-c1form assumptions) (loop for v in vars-list - for type in (values-type-to-n-types init-form-type (length vars-list)) - unless (or (global-var-p v) - (var-set-nodes v)) - do (setf (var-type v) (type-and (var-type v) type)) and - do (prop-message "~&;;; Variable ~A assigned type ~A" - (var-name v) (var-type v))) + for type in (values-type-to-n-types init-form-type (length vars-list)) + unless (or (global-var-p v) + (var-set-nodes v)) + do (setf (var-type v) (type-and (var-type v) type)) and + do (prop-message "~&;;; Variable ~A assigned type ~A" + (var-name v) (var-type v))) (p1propagate body assumptions))) (defun p1multiple-value-setq (c1form assumptions vars-list value-c1form) + (declare (ignore c1form vars-list)) (multiple-value-bind (init-form-type assumptions) (p1propagate value-c1form assumptions) (values init-form-type assumptions))) (defun p1progn (c1form assumptions forms) + (declare (ignore c1form)) (p1propagate-list forms assumptions)) (defun p1compiler-typecase (c1form assumptions variable expressions) + (declare (ignore c1form)) (let ((var-type (var-type variable))) (loop with output-type = t - for (a-type c1form) in expressions - for c1form-type = (p1propagate c1form assumptions) - when (or (member a-type '(t otherwise)) - (subtypep var-type a-type)) - do (setf output-type c1form-type) - finally (return (values output-type assumptions))))) + for (a-type c1form) in expressions + for c1form-type = (p1propagate c1form assumptions) + when (or (member a-type '(t otherwise)) + (subtypep var-type a-type)) + do (setf output-type c1form-type) + finally (return (values output-type assumptions))))) (defun p1checked-value (c1form assumptions type value let-form) - (let* ((value-type (p1propagate value assumptions)) - (alt-type (p1propagate let-form assumptions))) + (declare (ignore c1form let-form)) + (let ((value-type (p1propagate value assumptions)) + ;;(alt-type (p1propagate let-form assumptions)) + ) (if (subtypep value-type type) value-type type))) (defun p1progv (c1form assumptions variables values body) + (declare (ignore c1form)) (let (type) (multiple-value-setq (type assumptions) (p1propagate variables assumptions)) @@ -272,17 +302,20 @@ of the occurrences in those lists." assumptions))) (defun p1psetq (c1form assumptions vars c1forms) + (declare (ignore c1form vars)) (loop for form in c1forms - do (multiple-value-bind (new-type assumptions) - (p1propagate form assumptions))) + do (p1propagate form assumptions)) (values 'null assumptions)) (defun p1with-stack (c1form assumptions body) + (declare (ignore c1form)) (p1propagate body assumptions)) (defun p1stack-push-values (c1form assumptions form inline) + (declare (ignore c1form inline)) (multiple-value-bind (form-type assumptions) (p1propagate form assumptions) + (declare (ignore form-type)) (values nil assumptions))) (defvar *tagbody-depth* -1 @@ -291,6 +324,7 @@ of the occurrences in those lists." as 2^*tagbody-limit* in the worst cases.") (defun p1go (c1form assumptions tag-var return-type) + (declare (ignore c1form tag-var return-type)) (values t assumptions)) (defun filter-only-declarations (assumptions) @@ -305,7 +339,7 @@ as 2^*tagbody-limit* in the worst cases.") (values 'null (append (p1merge-branches nil ass-list) orig-assumptions)))) (defun p1tagbody-one-pass (c1form assumptions tag-loc body) - (declare (ignore tag-loc)) + (declare (ignore c1form tag-loc)) (loop with local-ass = assumptions with ass-list = '() with aux diff --git a/src/cmp/cmptype-assert.lsp b/src/cmp/cmptype-assert.lsp index 591b7f2c4..a449d9d3f 100644 --- a/src/cmp/cmptype-assert.lsp +++ b/src/cmp/cmptype-assert.lsp @@ -143,7 +143,7 @@ value let-form))) -(defmacro optional-type-assertion (&whole whole value type &environment env) +(defmacro optional-type-assertion (value type &environment env) "If safety settings are high enough, generates a type check on an expression, ensuring that it is satisfied." (when (and (policy-type-assertions env) @@ -151,7 +151,7 @@ expression, ensuring that it is satisfied." (cmpdebug "Checking type of ~A to be ~A" value type) `(ext:checked-value ,type ,value))) -(defmacro type-assertion (&whole whole value type &environment env) +(defmacro type-assertion (value type &environment env) "Generates a type check on an expression, ensuring that it is satisfied." (cmpdebug "Checking type of ~A to be ~A" value type) (unless (trivial-type-p type) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 664382292..55132af6b 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -182,7 +182,7 @@ "if (ecl_unlikely(!(#0))) FEwrong_type_argument(#1,#2);" :one-liner nil)))) -(defmacro assert-type-if-known (&whole whole value type &environment env) +(defmacro assert-type-if-known (value type &environment env) "Generates a type check on an expression, ensuring that it is satisfied." (multiple-value-bind (trivial valid) (subtypep 't type) @@ -211,8 +211,7 @@ (otherwise type))))) -(defmacro optional-type-check (&whole whole value type &environment env) - (declare (ignore env)) +(defmacro optional-type-check (value type) (if (policy-assume-right-type) value `(assert-type-if-known ,value ,type))) -- GitLab From 66c7626a8f9e84c800f0b158130c1f7dc614bcb5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 14 Feb 2023 16:21:35 +0100 Subject: [PATCH 13/33] cmp: cleanup: some more cleanup --- src/cmp/cmppass2-data.lsp | 8 ++++---- src/cmp/cmpstructures.lsp | 4 ++-- src/cmp/cmputil.lsp | 2 +- src/cmp/sysfun.lsp | 12 ++++++------ src/lsp/evalmacros.lsp | 2 +- 5 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/cmp/cmppass2-data.lsp b/src/cmp/cmppass2-data.lsp index c287d05d6..776b9dd01 100644 --- a/src/cmp/cmppass2-data.lsp +++ b/src/cmp/cmppass2-data.lsp @@ -29,7 +29,7 @@ (let* ((*wt-string-size* 0) (*wt-data-column* 80) (data (data-get-all-objects)) - (data-string (si::with-ecl-io-syntax + (data-string (si:with-ecl-io-syntax (prin1-to-string data))) (l (length data-string))) (subseq data-string 1 (1- l)))) @@ -119,19 +119,19 @@ (let* ((*read-default-float-format* 'single-float) (*print-readably* t)) (format stream "ecl_def_ct_single_float(~A,~S,static,const);" - name value stream))) + name value))) (defun static-double-float-builder (name value stream) (let* ((*read-default-float-format* 'double-float) (*print-readably* t)) (format stream "ecl_def_ct_double_float(~A,~S,static,const);" - name value stream))) + name value))) (defun static-long-float-builder (name value stream) (let* ((*read-default-float-format* 'long-float) (*print-readably* t)) (format stream "ecl_def_ct_long_float(~A,~SL,static,const);" - name value stream))) + name value))) (defun static-rational-builder (name value stream) (let* ((*read-default-float-format* 'double-float) diff --git a/src/cmp/cmpstructures.lsp b/src/cmp/cmpstructures.lsp index e3d25af4f..78d6e7b84 100644 --- a/src/cmp/cmpstructures.lsp +++ b/src/cmp/cmpstructures.lsp @@ -22,7 +22,7 @@ ;;; (defun get-slot-type (name index) ;; default is t - (or (third (nth index (si:get-sysprop name 'SYS::STRUCTURE-SLOT-DESCRIPTIONS))) 'T)) + (or (third (nth index (si:get-sysprop name 'si:structure-slot-descriptions))) 'T)) ;;; ;;; STRUCTURE SLOT READING @@ -34,7 +34,7 @@ ;;; (defun maybe-optimize-structure-access (fname args) - (let* ((slot-description (si:get-sysprop fname 'SYS::STRUCTURE-ACCESS))) + (let* ((slot-description (si:get-sysprop fname 'si::structure-access))) (when (and slot-description (inline-possible fname) (policy-inline-slot-access-p)) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 0efe8c84c..010dcf7ff 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -517,7 +517,7 @@ keyword argument, the compiler-macro declines to provide an expansion. (setq lambda-list (nconc (ldiff lambda-list env) (cddr env)))) ;; 2. parse the remaining lambda-list (multiple-value-bind (reqs opts rest key-flag keywords allow-other-keys auxs) - (si::process-lambda-list lambda-list 'si:macro) + (si:process-lambda-list lambda-list 'si:macro) (when (and rest (or key-flag allow-other-keys)) (error "define-compiler-macro* can't deal with lambda-lists with both &key and &rest arguments")) ;; utility functions diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index f17ea2d8c..7204932c5 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -485,9 +485,9 @@ (def-inline cl:expt :always ((integer 2 2) (integer 0 29)) :fixnum "(1<<(#1))") (def-inline cl:expt :always ((integer 0 0) t) :fixnum "0") (def-inline cl:expt :always ((integer 1 1) t) :fixnum "1") -(def-inline cl:expt :always ((long-float 0.0 *) long-float) :long-double "powl((long double)#0,(long double)#1)") -(def-inline cl:expt :always ((double-float 0.0 *) double-float) :double "pow((double)#0,(double)#1)") -(def-inline cl:expt :always ((single-float 0.0 *) single-float) :float "powf((float)#0,(float)#1)") +(def-inline cl:expt :always ((long-float 0.0l0 *) long-float) :long-double "powl((long double)#0,(long double)#1)") +(def-inline cl:expt :always ((double-float 0.0d0 *) double-float) :double "pow((double)#0,(double)#1)") +(def-inline cl:expt :always ((single-float 0.0f0 *) single-float) :float "powf((float)#0,(float)#1)") #+complex-float (def-inline cl:expt :always (si:complex-single-float si:complex-single-float) :csfloat "cpowf(#0,#1)") #+complex-float (def-inline cl:expt :always (si:complex-double-float si:complex-double-float) :cdfloat "cpow(#0,#1)") #+complex-float (def-inline cl:expt :always (si:complex-long-float si:complex-long-float) :clfloat "cpowl(#0,#1)") @@ -500,9 +500,9 @@ #+complex-float (def-inline cl:log :always (si:complex-long-float) :clfloat "clogl(#0)") (def-inline cl:sqrt :always (number) number "ecl_sqrt(#0)") -(def-inline cl:sqrt :always ((long-float 0.0 *)) :long-double "sqrtl((long double)(#0))") -(def-inline cl:sqrt :always ((double-float 0.0 *)) :double "sqrt((double)(#0))") -(def-inline cl:sqrt :always ((single-float 0.0 *)) :float "sqrtf((float)(#0))") +(def-inline cl:sqrt :always ((long-float 0.0l0 *)) :long-double "sqrtl((long double)(#0))") +(def-inline cl:sqrt :always ((double-float 0.0d0 *)) :double "sqrt((double)(#0))") +(def-inline cl:sqrt :always ((single-float 0.0f0 *)) :float "sqrtf((float)(#0))") #+complex-float (def-inline cl:sqrt :always (si:complex-single-float) :csfloat "csqrtf(#0)") #+complex-float (def-inline cl:sqrt :always (si:complex-double-float) :cdfloat "csqrt(#0)") #+complex-float (def-inline cl:sqrt :always (si:complex-long-float) :clfloat "csqrtl(#0)") diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index d66315c31..a9228631e 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -122,7 +122,7 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." ;;; (defmacro define-compiler-macro (&whole whole name vl &rest body) (multiple-value-bind (function pprint doc-string) - (sys::expand-defmacro name vl body 'cl:define-compiler-macro) + (si:expand-defmacro name vl body 'cl:define-compiler-macro) (declare (ignore pprint)) (setq function `(function ,function)) (when *dump-defun-definitions* -- GitLab From b3ec398d295563637b1349eb908264f6262e330e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Feb 2023 16:25:36 +0100 Subject: [PATCH 14/33] cmp: move all conditions to a separate file --- src/cmp/cmpcond.lsp | 212 +++++++++++++++++++++++++++++++++++++++++++ src/cmp/cmputil.lsp | 213 +------------------------------------------- src/cmp/load.lsp.in | 1 + 3 files changed, 216 insertions(+), 210 deletions(-) create mode 100644 src/cmp/cmpcond.lsp diff --git a/src/cmp/cmpcond.lsp b/src/cmp/cmpcond.lsp new file mode 100644 index 000000000..c16cae49e --- /dev/null +++ b/src/cmp/cmpcond.lsp @@ -0,0 +1,212 @@ + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański +;;;; +;;;; See file 'LICENSE' for the copyright details. + +(in-package #:compiler) + +#+cmu-format +(progn + (defconstant +note-format+ "~&~@< ~;~?~;~:@>") + (defconstant +warn-format+ "~&~@< ! ~;~?~;~:@>") + (defconstant +error-format+ "~&~@< * ~;~?~;~:@>") + (defconstant +fatal-format+ "~&~@< ** ~;~?~;~:@>")) +#-cmu-format +(progn + (defconstant +note-format+ "~& ~?") + (defconstant +warn-format+ "~& ! ~?") + (defconstant +error-format+ "~& * ~?") + (defconstant +fatal-format+ "~& ** ~?")) + +;; For indirect use in :REPORT functions +(defun compiler-message-report (stream c format-control &rest format-arguments) + (let ((position (compiler-message-file-position c)) + (prefix (compiler-message-prefix c)) + (file (compiler-message-file c)) + (form (innermost-non-expanded-form (compiler-message-toplevel-form c)))) + (if (and form + position + (not (minusp position)) + (not (equalp form '|compiler preprocess|))) + (let* ((*print-length* 2) + (*print-level* 2)) + (format stream + "~A:~% in file ~A, position ~D~& at ~A" + prefix + (make-pathname :name (pathname-name file) + :type (pathname-type file) + :version (pathname-version file)) + position + form)) + (format stream "~A:" prefix)) + (format stream (compiler-message-format c) + format-control + format-arguments))) + +(define-condition compiler-message (simple-condition) + ((prefix :initform "Note" :accessor compiler-message-prefix) + (format :initform +note-format+ :accessor compiler-message-format) + (file :initarg :file :initform *compile-file-pathname* + :accessor compiler-message-file) + (position :initarg :file :initform *compile-file-position* + :accessor compiler-message-file-position) + (toplevel-form :initarg :form :initform *current-toplevel-form* + :accessor compiler-message-toplevel-form) + (form :initarg :form :initform *current-form* + :accessor compiler-message-form)) + (:report (lambda (c stream) + (apply #'compiler-message-report stream c + (simple-condition-format-control c) + (simple-condition-format-arguments c))))) + +(define-condition compiler-note (compiler-message) ()) + +(define-condition compiler-debug-note (compiler-note) ()) + +(define-condition compiler-warning (compiler-message style-warning) + ((prefix :initform "Warning") + (format :initform +warn-format+))) + +(define-condition compiler-macro-expansion-failed (compiler-warning) + ()) + +(define-condition compiler-error (compiler-message) + ((prefix :initform "Error") + (format :initform +error-format+))) + +(define-condition compiler-fatal-error (compiler-error) + ((format :initform +fatal-format+))) + +(define-condition compiler-internal-error (compiler-fatal-error) + ((prefix :initform "Internal error"))) + +(define-condition compiler-style-warning (compiler-message style-warning) + ((prefix :initform "Style warning") + (format :initform +warn-format+))) + +(define-condition compiler-undefined-variable (compiler-style-warning) + ((variable :initarg :name :initform nil)) + (:report + (lambda (c stream) + (compiler-message-report stream c + "Variable ~A was undefined. ~ + Compiler assumes it is a global." + (slot-value c 'variable))))) + +(define-condition circular-dependency (compiler-error) + () + (:report + (lambda (c stream) + (compiler-message-report stream c + "Circular references in creation form for ~S." + (compiler-message-form c))))) + +(defun print-compiler-message (c stream) + (unless (typep c *suppress-compiler-messages*) + #+cmu-format + (format stream "~&~@<;;; ~@;~A~:>" c) + #-cmu-format + (format stream "~&;;; ~A" c))) + +;;; A few notes about the following handlers. We want the user to be +;;; able to capture, collect and perhaps abort on the different +;;; conditions signaled by the compiler. Since the compiler uses +;;; HANDLER-BIND, the only way to let this happen is either let the +;;; handler return or use SIGNAL at the beginning of the handler and +;;; let the outer handler intercept. +;;; +;;; In neither case do we want to enter the the debugger. That means +;;; we can not derive the compiler conditions from SERIOUS-CONDITION. +;;; +(defun handle-compiler-note (c) + (declare (ignore c)) + nil) + +(defun handle-compiler-warning (c) + (push c *compiler-conditions*) + nil) + +(defun handle-compiler-error (c) + (signal c) + (push c *compiler-conditions*) + (print-compiler-message c t) + (abort)) + +(defun handle-compiler-internal-error (c) + (when *compiler-break-enable* + (invoke-debugger c)) + (setf c (make-condition 'compiler-internal-error + :format-control "~A" + :format-arguments (list c))) + (push c *compiler-conditions*) + (signal c) + (print-compiler-message c t) + (abort)) + +(defmacro cmpck (condition string &rest args) + `(if ,condition (cmperr ,string ,@args))) + +(defmacro cmpassert (condition string &rest args) + `(unless ,condition (cmperr ,string ,@args))) + +(defun cmperr (string &rest args) + (let ((c (make-condition 'compiler-error + :format-control string + :format-arguments args))) + (signal c) + (print-compiler-message c t) + (abort))) + +(defun too-many-args (name upper-bound n &aux (*print-case* :upcase)) + (cmperr "~S requires at most ~R argument~:p, but ~R ~:*~[were~;was~:;were~] supplied.~%" + name upper-bound n)) + +(defun too-few-args (name lower-bound n) + (cmperr "~S requires at least ~R argument~:p, but only ~R ~:*~[were~;was~:;were~] supplied.~%" + name lower-bound n)) + +(defun do-cmpwarn (&rest args) + (declare (si::c-local)) + (let ((condition (apply #'make-condition args))) + (restart-case (signal condition) + (muffle-warning () + :REPORT "Skip warning" + (return-from do-cmpwarn nil))) + (print-compiler-message condition t))) + +(defun cmpwarn-style (string &rest args) + (do-cmpwarn 'compiler-style-warning :format-control string :format-arguments args)) + +(defun cmpwarn (string &rest args) + (do-cmpwarn 'compiler-warning :format-control string :format-arguments args)) + +(defun cmpnote (string &rest args) + (do-cmpwarn 'compiler-note :format-control string :format-arguments args)) + +(defun cmpdebug (string &rest args) + (do-cmpwarn 'compiler-debug-note :format-control string :format-arguments args)) + +(defun undefined-variable (sym) + (do-cmpwarn 'compiler-undefined-variable :name sym)) + +(defun baboon (&key (format-control "A bug was found in the compiler") + format-arguments) + (signal 'compiler-internal-error + :format-control format-control + :format-arguments format-arguments)) + +;;; This is not used (left for debugging). +(defmacro with-cmp-protection (main-form error-form) + `(let* ((si::*break-enable* *compiler-break-enable*) + (throw-flag t)) + (unwind-protect + (multiple-value-prog1 + (if *compiler-break-enable* + (handler-bind ((error #'invoke-debugger)) + ,main-form) + ,main-form) + (setf throw-flag nil)) + (when throw-flag ,error-form)))) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 010dcf7ff..6cfcd236a 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -16,19 +16,6 @@ (in-package "COMPILER") -#+cmu-format -(progn - (defconstant +note-format+ "~&~@< ~;~?~;~:@>") - (defconstant +warn-format+ "~&~@< ! ~;~?~;~:@>") - (defconstant +error-format+ "~&~@< * ~;~?~;~:@>") - (defconstant +fatal-format+ "~&~@< ** ~;~?~;~:@>")) -#-cmu-format -(progn - (defconstant +note-format+ "~& ~?") - (defconstant +warn-format+ "~& ! ~?") - (defconstant +error-format+ "~& * ~?") - (defconstant +fatal-format+ "~& ** ~?")) - ;; Return a namestring for a path that is sufficiently ;; unambiguous (hopefully) for the C compiler (and associates) ;; to decipher. @@ -61,131 +48,6 @@ (setf output f))) finally (return output)))) -;; For indirect use in :REPORT functions -(defun compiler-message-report (stream c format-control &rest format-arguments) - (let ((position (compiler-message-file-position c)) - (prefix (compiler-message-prefix c)) - (file (compiler-message-file c)) - (form (innermost-non-expanded-form (compiler-message-toplevel-form c)))) - (if (and form - position - (not (minusp position)) - (not (equalp form '|compiler preprocess|))) - (let* ((*print-length* 2) - (*print-level* 2)) - (format stream - "~A:~% in file ~A, position ~D~& at ~A" - prefix - (make-pathname :name (pathname-name file) - :type (pathname-type file) - :version (pathname-version file)) - position - form)) - (format stream "~A:" prefix)) - (format stream (compiler-message-format c) - format-control - format-arguments))) - -(define-condition compiler-message (simple-condition) - ((prefix :initform "Note" :accessor compiler-message-prefix) - (format :initform +note-format+ :accessor compiler-message-format) - (file :initarg :file :initform *compile-file-pathname* - :accessor compiler-message-file) - (position :initarg :file :initform *compile-file-position* - :accessor compiler-message-file-position) - (toplevel-form :initarg :form :initform *current-toplevel-form* - :accessor compiler-message-toplevel-form) - (form :initarg :form :initform *current-form* - :accessor compiler-message-form)) - (:report (lambda (c stream) - (apply #'compiler-message-report stream c - (simple-condition-format-control c) - (simple-condition-format-arguments c))))) - -(define-condition compiler-note (compiler-message) ()) - -(define-condition compiler-debug-note (compiler-note) ()) - -(define-condition compiler-warning (compiler-message style-warning) - ((prefix :initform "Warning") - (format :initform +warn-format+))) - -(define-condition compiler-macro-expansion-failed (compiler-warning) - ()) - -(define-condition compiler-error (compiler-message) - ((prefix :initform "Error") - (format :initform +error-format+))) - -(define-condition compiler-fatal-error (compiler-error) - ((format :initform +fatal-format+))) - -(define-condition compiler-internal-error (compiler-fatal-error) - ((prefix :initform "Internal error"))) - -(define-condition compiler-style-warning (compiler-message style-warning) - ((prefix :initform "Style warning") - (format :initform +warn-format+))) - -(define-condition compiler-undefined-variable (compiler-style-warning) - ((variable :initarg :name :initform nil)) - (:report - (lambda (c stream) - (compiler-message-report stream c - "Variable ~A was undefined. ~ - Compiler assumes it is a global." - (slot-value c 'variable))))) - -(define-condition circular-dependency (compiler-error) - () - (:report - (lambda (c stream) - (compiler-message-report stream c - "Circular references in creation form for ~S." - (compiler-message-form c))))) - -(defun print-compiler-message (c stream) - (unless (typep c *suppress-compiler-messages*) - #+cmu-format - (format stream "~&~@<;;; ~@;~A~:>" c) - #-cmu-format - (format stream "~&;;; ~A" c))) - -;;; A few notes about the following handlers. We want the user to be -;;; able to capture, collect and perhaps abort on the different -;;; conditions signaled by the compiler. Since the compiler uses -;;; HANDLER-BIND, the only way to let this happen is either let the -;;; handler return or use SIGNAL at the beginning of the handler and -;;; let the outer handler intercept. -;;; -;;; In neither case do we want to enter the the debugger. That means -;;; we can not derive the compiler conditions from SERIOUS-CONDITION. -;;; -(defun handle-compiler-note (c) - (declare (ignore c)) - nil) - -(defun handle-compiler-warning (c) - (push c *compiler-conditions*) - nil) - -(defun handle-compiler-error (c) - (signal c) - (push c *compiler-conditions*) - (print-compiler-message c t) - (abort)) - -(defun handle-compiler-internal-error (c) - (when *compiler-break-enable* - (invoke-debugger c)) - (setf c (make-condition 'compiler-internal-error - :format-control "~A" - :format-arguments (list c))) - (push c *compiler-conditions*) - (signal c) - (print-compiler-message c t) - (abort)) - (defun do-compilation-unit (closure &key override) (cond (override (let* ((*active-protection* nil)) @@ -238,24 +100,6 @@ (defun print-var (var-object stream) (format stream "#" (var-name var-object) (var-kind var-object))) -(defun cmpprogress (&rest args) - (when *compile-verbose* - (apply #'format t args))) - -(defmacro cmpck (condition string &rest args) - `(if ,condition (cmperr ,string ,@args))) - -(defmacro cmpassert (condition string &rest args) - `(unless ,condition (cmperr ,string ,@args))) - -(defun cmperr (string &rest args) - (let ((c (make-condition 'compiler-error - :format-control string - :format-arguments args))) - (signal c) - (print-compiler-message c t) - (abort))) - (defun safe-list-length (l) ;; Computes the length of a proper list or returns NIL if it ;; is a circular list or terminates with a non-NIL atom. @@ -280,7 +124,6 @@ finally (return l))) (defun check-args-number (operator args &optional (min 0) (max most-positive-fixnum)) - (let ((l (safe-list-length args))) (when (null l) (let ((*print-circle* t)) @@ -290,39 +133,6 @@ (when (and max (> l max)) (too-many-args operator max l)))) -(defun too-many-args (name upper-bound n &aux (*print-case* :upcase)) - (cmperr "~S requires at most ~R argument~:p, but ~R ~:*~[were~;was~:;were~] supplied.~%" - name - upper-bound - n)) - -(defun too-few-args (name lower-bound n) - (cmperr "~S requires at least ~R argument~:p, but only ~R ~:*~[were~;was~:;were~] supplied.~%" - name - lower-bound - n)) - -(defun do-cmpwarn (&rest args) - (declare (si::c-local)) - (let ((condition (apply #'make-condition args))) - (restart-case (signal condition) - (muffle-warning () - :REPORT "Skip warning" - (return-from do-cmpwarn nil))) - (print-compiler-message condition t))) - -(defun cmpwarn-style (string &rest args) - (do-cmpwarn 'compiler-style-warning :format-control string :format-arguments args)) - -(defun cmpwarn (string &rest args) - (do-cmpwarn 'compiler-warning :format-control string :format-arguments args)) - -(defun cmpnote (string &rest args) - (do-cmpwarn 'compiler-note :format-control string :format-arguments args)) - -(defun cmpdebug (string &rest args) - (do-cmpwarn 'compiler-debug-note :format-control string :format-arguments args)) - (defun print-current-form () (when *compile-print* (let ((*print-length* 2) @@ -337,26 +147,9 @@ (when name (format t "~&;;; Emitting code for ~s.~%" name))))) -(defun undefined-variable (sym) - (do-cmpwarn 'compiler-undefined-variable :name sym)) - -(defun baboon (&key (format-control "A bug was found in the compiler") - format-arguments) - (signal 'compiler-internal-error - :format-control format-control - :format-arguments format-arguments)) - -(defmacro with-cmp-protection (main-form error-form) - `(let* ((si::*break-enable* *compiler-break-enable*) - (throw-flag t)) - (unwind-protect - (multiple-value-prog1 - (if *compiler-break-enable* - (handler-bind ((error #'invoke-debugger)) - ,main-form) - ,main-form) - (setf throw-flag nil)) - (when throw-flag ,error-form)))) +(defun cmpprogress (&rest args) + (when *compile-verbose* + (apply #'format t args))) (defun cmp-eval (form &optional (env *cmp-env*)) (handler-case (si::eval-with-env form env nil t :execute) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 9ae9f59b9..d1408c384 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -7,6 +7,7 @@ "build:cmp;cmpdefs.lsp" "src:cmp;cmpmac.lsp" "src:cmp;cmputil.lsp" + "src:cmp;cmpcond.lsp" ;; Environment "src:cmp;cmpenv-api.lsp" "src:cmp;cmpenv-fun.lsp" -- GitLab From a85b5851087d0a259116b9a3fc0d1de0acaa2b4b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Feb 2023 18:02:31 +0100 Subject: [PATCH 15/33] cmp: move set-closure-env from cmpenv-api to cmpenv-fun --- src/cmp/cmpenv-api.lsp | 48 ------------------------------------------ src/cmp/cmpenv-fun.lsp | 48 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 48 insertions(+), 48 deletions(-) diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index 91f5c870a..0622cdf3f 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -25,54 +25,6 @@ that are susceptible to be changed by PROCLAIM." (defun cmp-env-copy (&optional (env *cmp-env*)) (cons (car env) (cdr env))) -(defun set-closure-env (definition lexenv &optional (env *cmp-env*)) - "Set up an environment for compilation of closures: Register closed -over macros in the compiler environment and enclose the definition of -the closure in let/flet forms for variables/functions it closes over." - (loop for record in lexenv - do (cond ((not (listp record)) - (multiple-value-bind (record-def record-lexenv) - (function-lambda-expression record) - (cond ((eql (car record-def) 'LAMBDA) - (setf record-def (cdr record-def))) - ((eql (car record-def) 'EXT:LAMBDA-BLOCK) - (setf record-def (cddr record-def))) - (t - (error "~&;;; Error: Not a valid lambda expression: ~s." record-def))) - ;; allow for closures which close over closures. - ;; (first record-def) is the lambda list, (rest - ;; record-def) the definition of the local function - ;; in record - (setf (rest record-def) - (list (set-closure-env (if (= (length record-def) 2) - (second record-def) - `(progn ,@(rest record-def))) - record-lexenv env))) - (setf definition - `(flet ((,(ext:compiled-function-name record) - ,@record-def)) - ,definition)))) - ((and (listp record) (symbolp (car record))) - (cond ((eq (car record) 'si:macro) - (cmp-env-register-macro (cddr record) (cadr record) env)) - ((eq (car record) 'si:symbol-macro) - (cmp-env-register-symbol-macro-function (cddr record) (cadr record) env)) - (t - (setf definition - `(let ((,(car record) ',(cdr record))) - ,definition))) - )) - ;; ((and (integerp (cdr record)) (= (cdr record) 0)) - ;; Tags: We have lost the information, which tag - ;; corresponds to the lex-env record. If we are - ;; compiling a closure over a tag, we will get an - ;; error later on. - ;; ) - ;; (t - ;; Blocks: Not yet implemented - ) - finally (return definition))) - (defmacro cmp-env-variables (&optional (env '*cmp-env*)) `(car ,env)) diff --git a/src/cmp/cmpenv-fun.lsp b/src/cmp/cmpenv-fun.lsp index 0d5522672..0c55a5165 100644 --- a/src/cmp/cmpenv-fun.lsp +++ b/src/cmp/cmpenv-fun.lsp @@ -172,3 +172,51 @@ ;; locally we don't keep the definition. `(eval-when (:load-toplevel :execute) (si:put-sysprop ',fname 'inline ',form)))) + +(defun set-closure-env (definition lexenv &optional (env *cmp-env*)) + "Set up an environment for compilation of closures: Register closed +over macros in the compiler environment and enclose the definition of +the closure in let/flet forms for variables/functions it closes over." + (loop for record in lexenv + do (cond ((not (listp record)) + (multiple-value-bind (record-def record-lexenv) + (function-lambda-expression record) + (cond ((eql (car record-def) 'LAMBDA) + (setf record-def (cdr record-def))) + ((eql (car record-def) 'EXT:LAMBDA-BLOCK) + (setf record-def (cddr record-def))) + (t + (error "~&;;; Error: Not a valid lambda expression: ~s." record-def))) + ;; allow for closures which close over closures. + ;; (first record-def) is the lambda list, (rest + ;; record-def) the definition of the local function + ;; in record + (setf (rest record-def) + (list (set-closure-env (if (= (length record-def) 2) + (second record-def) + `(progn ,@(rest record-def))) + record-lexenv env))) + (setf definition + `(flet ((,(ext:compiled-function-name record) + ,@record-def)) + ,definition)))) + ((and (listp record) (symbolp (car record))) + (cond ((eq (car record) 'si:macro) + (cmp-env-register-macro (cddr record) (cadr record) env)) + ((eq (car record) 'si:symbol-macro) + (cmp-env-register-symbol-macro-function (cddr record) (cadr record) env)) + (t + (setf definition + `(let ((,(car record) ',(cdr record))) + ,definition))) + )) + ;; ((and (integerp (cdr record)) (= (cdr record) 0)) + ;; Tags: We have lost the information, which tag + ;; corresponds to the lex-env record. If we are + ;; compiling a closure over a tag, we will get an + ;; error later on. + ;; ) + ;; (t + ;; Blocks: Not yet implemented + ) + finally (return definition))) -- GitLab From f1080c716c0dc01308c875d47482fd7dca74035d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Feb 2023 18:05:40 +0100 Subject: [PATCH 16/33] cmp: remove unused environment object type "cleanup" --- src/cmp/cmpenv-api.lsp | 24 ------------------------ 1 file changed, 24 deletions(-) diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index 0622cdf3f..e735d87de 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -31,26 +31,6 @@ that are susceptible to be changed by PROCLAIM." (defmacro cmp-env-functions (&optional (env '*cmp-env*)) `(cdr ,env)) -(defun cmp-env-cleanups (env) - (loop with specials = '() - with end = (cmp-env-variables env) - with cleanup-forms = '() - with aux - for records-list on (cmp-env-variables *cmp-env*) - until (eq records-list end) - do (let ((record (first records-list))) - (cond ((atom record)) - ((and (symbolp (first record)) - (eq (second record) :special)) - (push (fourth record) specials)) - ((eq (first record) :cleanup) - (push (second record) cleanup-forms)))) - finally (progn - (unless (eq records-list end) - (error "Inconsistency in environment.")) - (return (values specials - (apply #'nconc (mapcar #'copy-list cleanup-forms))))))) - (defun cmp-env-register-var (var &optional (env *cmp-env*) (boundp t)) (push (list (var-name var) (if (member (var-kind var) '(special global)) @@ -120,10 +100,6 @@ that are susceptible to be changed by PROCLAIM." (cmp-env-variables env)) env) -(defun cmp-env-register-cleanup (form &optional (env *cmp-env*)) - (push (list :cleanup (copy-list form)) (cmp-env-variables env)) - env) - (defun cmp-env-search-function (name &optional (env *cmp-env*)) (let ((cfb nil) (unw nil) -- GitLab From 9eff84b622b1ffaffbef374bca865a3390a58e13 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Feb 2023 18:25:31 +0100 Subject: [PATCH 17/33] cmp: rename env functions to comply to other naming conventions c1make-global-variable -> make-global-var (and move to cmpvar) -- this function does not create c1form so this name was wrong cmp-env-declare-special -> declare-special (and move to cmpenv-var) -- this function does not only declare special but it also creates an instance of a variable - move that to a new file cmpenv-var.lsp --- src/cmp/cmpenv-api.lsp | 9 +-------- src/cmp/cmpenv-declaim.lsp | 4 ++-- src/cmp/cmpenv-var.lsp | 14 ++++++++++++++ src/cmp/cmppass1-eval.lsp | 2 +- src/cmp/cmppass1-fun.lsp | 2 +- src/cmp/cmppass1-var.lsp | 23 +++++------------------ src/cmp/cmpvar.lsp | 13 +++++++++++++ src/cmp/load.lsp.in | 1 + 8 files changed, 38 insertions(+), 30 deletions(-) create mode 100644 src/cmp/cmpenv-var.lsp diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index e735d87de..bc1fad6b2 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -19,7 +19,7 @@ (defun cmp-env-root (&optional (env *cmp-env-root*)) "Provide a root environment for toplevel forms storing all declarations that are susceptible to be changed by PROCLAIM." - (let* ((env (cmp-env-copy env))) + (let ((env (cmp-env-copy env))) (add-default-optimizations env))) (defun cmp-env-copy (&optional (env *cmp-env*)) @@ -41,13 +41,6 @@ that are susceptible to be changed by PROCLAIM." (cmp-env-variables env)) env) -(defun cmp-env-declare-special (name &optional (env *cmp-env*)) - (when (cmp-env-search-symbol-macro name env) - (cmperr "Symbol ~A cannot be declared special and appear in a symbol-macrolet." name)) - (cmp-env-register-var (c::c1make-global-variable name :warn nil :kind 'SPECIAL) - env nil) - env) - (defun cmp-env-add-declaration (type arguments &optional (env *cmp-env*)) (push (list* :declare type arguments) (cmp-env-variables env)) diff --git a/src/cmp/cmpenv-declaim.lsp b/src/cmp/cmpenv-declaim.lsp index 33bd27b01..4b189b79d 100644 --- a/src/cmp/cmpenv-declaim.lsp +++ b/src/cmp/cmpenv-declaim.lsp @@ -26,12 +26,12 @@ (flet ((add-variables (env types specials) (loop for name in specials unless (assoc name types) - do (let ((v (c1make-global-variable name :kind 'special))) + do (let ((v (make-global-var name :kind 'special))) (setf env (cmp-env-register-var v env nil)))) (loop for (name . type) in types for specialp = (or (si:specialp name) (member name specials)) for kind = (if specialp 'SPECIAL 'GLOBAL) - for v = (c1make-global-variable name :type type :kind kind) + for v = (make-global-var name :type type :kind kind) do (setf env (cmp-env-register-var v env nil))) env)) (multiple-value-bind (body specials types ignored others doc all) diff --git a/src/cmp/cmpenv-var.lsp b/src/cmp/cmpenv-var.lsp new file mode 100644 index 000000000..aa29a765e --- /dev/null +++ b/src/cmp/cmpenv-var.lsp @@ -0,0 +1,14 @@ + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański +;;;; +;;;; See file 'LICENSE' for the copyright details. + +(in-package #:compiler) + +(defun declare-special (name &optional (env *cmp-env*)) + (when (cmp-env-search-symbol-macro name env) + (cmperr "Symbol ~A cannot be declared special and appear in a symbol-macrolet." name)) + (cmp-env-register-var (make-global-var name :warn nil :kind 'SPECIAL) env nil)) diff --git a/src/cmp/cmppass1-eval.lsp b/src/cmp/cmppass1-eval.lsp index b19a8046b..3a83e76cc 100644 --- a/src/cmp/cmppass1-eval.lsp +++ b/src/cmp/cmppass1-eval.lsp @@ -85,7 +85,7 @@ (c1body args t) (if (or ss ts is other-decl) (let ((*cmp-env* (cmp-env-copy))) - (mapc #'cmp-env-declare-special ss) + (mapc #'declare-special ss) (check-vdecl nil ts is) (c1decl-body other-decl body)) (c1progn body)))) diff --git a/src/cmp/cmppass1-fun.lsp b/src/cmp/cmppass1-fun.lsp index da447459f..23086823a 100644 --- a/src/cmp/cmppass1-fun.lsp +++ b/src/cmp/cmppass1-fun.lsp @@ -71,7 +71,7 @@ (let ((*cmp-env* new-env)) (multiple-value-bind (body ss ts is other-decl) (c1body (rest args) t) - (mapc #'cmp-env-declare-special ss) + (mapc #'declare-special ss) (check-vdecl nil ts is) (setq body-c1form (c1decl-body other-decl body)))) diff --git a/src/cmp/cmppass1-var.lsp b/src/cmp/cmppass1-var.lsp index 80b0b39bc..b9a42d0d4 100644 --- a/src/cmp/cmppass1-var.lsp +++ b/src/cmp/cmppass1-var.lsp @@ -120,7 +120,7 @@ (values vars forms specials other-decls body)))) (defun process-let-body (let/let* vars forms specials other-decls body setjmps) - (mapc #'cmp-env-declare-special specials) + (mapc #'declare-special specials) (setf body (c1decl-body other-decls body)) ;; Try eliminating unused variables, replace constant ones, etc. (multiple-value-setq (vars forms) @@ -235,7 +235,7 @@ name type)) (when (eq type 'T) (setf type (or (si:get-sysprop name 'CMP-TYPE) 'T))) - (c1make-global-variable name :kind 'SPECIAL :type type)) + (make-global-var name :kind 'SPECIAL :type type)) (t (make-var :name name :type type :loc 'OBJECT :kind kind :ignorable ignorable @@ -257,8 +257,8 @@ (cmp-env-search-var name) (declare (ignore unw)) (cond ((null var) - (c1make-global-variable name :warn t - :type (or (si:get-sysprop name 'CMP-TYPE) t))) + (make-global-var name :warn t + :type (or (si:get-sysprop name 'CMP-TYPE) t))) ((not (var-p var)) ;; symbol-macrolet (baboon :format-control "c1vref: ~s is not a variable." @@ -277,19 +277,6 @@ (var-name var))))) var)))) -(defun c1make-global-variable (name &key - (type (or (si:get-sysprop name 'CMP-TYPE) t)) - (kind 'GLOBAL) - (warn nil)) - (let* ((var (make-var :name name :kind kind :type type :loc (add-symbol name)))) - (when warn - (unless (or (constantp name) - (special-variable-p name) - (member name *undefined-vars*)) - (undefined-variable name) - (push name *undefined-vars*))) - var)) - (defun c1setq (args) (let ((l (length args))) (cmpck (oddp l) "SETQ requires an even number of arguments.") @@ -370,7 +357,7 @@ ,@args))) (multiple-value-bind (body ss ts is other-decls) (c1body args nil) - (mapc #'cmp-env-declare-special ss) + (mapc #'declare-special ss) (let* ((vars (loop for name in variables collect (c1make-var name ss is ts)))) (setq init-form (c1expr init-form)) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index e7c204948..f2f5765e4 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -99,6 +99,19 @@ (setq type 'T)) (make-var :kind rep-type :type type :loc (next-lcl))) +(defun make-global-var (name &key + (type (or (si:get-sysprop name 'CMP-TYPE) t)) + (kind 'GLOBAL) + (warn nil)) + (let ((var (make-var :name name :kind kind :type type :loc (add-symbol name)))) + (when warn + (unless (or (constantp name) + (special-variable-p name) + (member name *undefined-vars*)) + (undefined-variable name) + (push name *undefined-vars*))) + var)) + (defun make-temp-var (&optional (type 'T)) (make-var :kind :object :type type :loc `(TEMP ,(next-temp)))) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index d1408c384..131ed65a0 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -10,6 +10,7 @@ "src:cmp;cmpcond.lsp" ;; Environment "src:cmp;cmpenv-api.lsp" + "src:cmp;cmpenv-var.lsp" "src:cmp;cmpenv-fun.lsp" "src:cmp;cmpenv-declare.lsp" "src:cmp;cmpenv-proclaim.lsp" -- GitLab From 0489f2e2273b493f8a2c477dea903672f59769c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Feb 2023 18:33:58 +0100 Subject: [PATCH 18/33] cmp: move functions from cmpmac to cmputil both files served the same purpose --- src/cmp/cmpmac.lsp | 114 -------------------------------------------- src/cmp/cmputil.lsp | 107 +++++++++++++++++++++++++++++++++++++++++ src/cmp/load.lsp.in | 1 - 3 files changed, 107 insertions(+), 115 deletions(-) delete mode 100644 src/cmp/cmpmac.lsp diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp deleted file mode 100644 index ed8ca3ec5..000000000 --- a/src/cmp/cmpmac.lsp +++ /dev/null @@ -1,114 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; -;;; ---------------------------------------------------------------------- -;;; Macros only used in the code of the compiler itself: - -(in-package "COMPILER") - -;; ---------------------------------------------------------------------- -;; CACHED FUNCTIONS -;; -(defmacro defun-cached (name lambda-list test &body body) - (let* ((cache-name (intern (concatenate 'string "*" (string name) "-CACHE*") - (symbol-package name))) - (reset-name (intern (concatenate 'string (string name) "-EMPTY-CACHE") - (symbol-package name))) - (hash-function (case test - (EQ 'SI::HASH-EQ) - (EQL 'SI::HASH-EQL) - ((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL) - (t (setf test 'EQUALP) 'SI::HASH-EQUALP)))) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil))) - (defun ,reset-name () - (make-array 1024 :element-type t :adjustable nil)) - (defun ,name ,lambda-list - (flet ((,name ,lambda-list ,@body)) - (let* ((hash (logand (,hash-function ,@lambda-list) 1023)) - (elt (aref ,cache-name hash))) - (declare (type (integer 0 1023) hash) - (type (array t (*)) ,cache-name)) - (if (and elt ,@(loop for arg in lambda-list - collect `(,test (pop (ext:truly-the cons elt)) ,arg))) - (first (ext:truly-the cons elt)) - (let ((output (,name ,@lambda-list))) - (setf (aref ,cache-name hash) (list ,@lambda-list output)) - output)))))))) - -(defmacro defun-equal-cached (name lambda-list &body body) - `(defun-cached ,name ,lambda-list equal-with-circularity ,@body)) - -;;; ---------------------------------------------------------------------- -;;; CONVENIENCE FUNCTIONS / MACROS -;;; - -(defun-cached env-var-name (n) eql - (format nil "env~D" n)) - -(defun-cached lex-env-var-name (n) eql - (format nil "lex~D" n)) - -(defun same-fname-p (name1 name2) (equal name1 name2)) - -;;; from cmplabel.lsp -(defun next-label () - (cons (incf *last-label*) nil)) - -(defun next-label* () - (cons (incf *last-label*) t)) - -(defun labelp (x) - (and (consp x) (integerp (si:cons-car x)))) - -(defun maybe-next-label () - (if (labelp *exit*) - *exit* - (next-label))) - -(defun maybe-wt-label (label) - (unless (eq label *exit*) - (wt-label label))) - -(defmacro with-exit-label ((label) &body body) - `(let* ((,label (next-label)) - (*unwind-exit* (cons ,label *unwind-exit*))) - ,@body - (wt-label ,label))) - -(defmacro with-optional-exit-label ((label) &body body) - `(let* ((,label (maybe-next-label)) - (*unwind-exit* (adjoin ,label *unwind-exit*))) - ,@body - (maybe-wt-label ,label))) - -(defun next-lcl (&optional name) - (list 'LCL (incf *lcl*) T - (if (and name (symbol-package name)) - (lisp-to-c-name name) - ""))) - -(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil)) - (let ((code (incf *next-cfun*))) - (format nil prefix code (lisp-to-c-name lisp-name)))) - -(defun next-temp () - (prog1 *temp* - (incf *temp*) - (setq *max-temp* (max *temp* *max-temp*)))) - -(defun next-lex () - (prog1 (cons *level* *lex*) - (incf *lex*) - (setq *max-lex* (max *lex* *max-lex*)))) - -(defun next-env () - (prog1 *env* - (incf *env*) - (setq *max-env* (max *env* *max-env*)))) - -(defmacro reckless (&rest body) - `(locally (declare (optimize (safety 0))) - ,@body)) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 6cfcd236a..356176dfe 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -473,3 +473,110 @@ comparing circular objects." (and (equal-recursive (car x) (car y) x0 y0 t (logior (ash path-spec 1) 1) (the fixnum (1+ n))) (equal-recursive (cdr x) (cdr y) x0 y0 t (ash path-spec 1) (the fixnum (1+ n)))))))) (equal-recursive x y nil nil t 0 -1))) + +;; ---------------------------------------------------------------------- +;; CACHED FUNCTIONS +;; +(defmacro defun-cached (name lambda-list test &body body) + (let* ((cache-name (intern (concatenate 'string "*" (string name) "-CACHE*") + (symbol-package name))) + (reset-name (intern (concatenate 'string (string name) "-EMPTY-CACHE") + (symbol-package name))) + (hash-function (case test + (EQ 'SI::HASH-EQ) + (EQL 'SI::HASH-EQL) + ((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL) + (t (setf test 'EQUALP) 'SI::HASH-EQUALP)))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil))) + (defun ,reset-name () + (make-array 1024 :element-type t :adjustable nil)) + (defun ,name ,lambda-list + (flet ((,name ,lambda-list ,@body)) + (let* ((hash (logand (,hash-function ,@lambda-list) 1023)) + (elt (aref ,cache-name hash))) + (declare (type (integer 0 1023) hash) + (type (array t (*)) ,cache-name)) + (if (and elt ,@(loop for arg in lambda-list + collect `(,test (pop (ext:truly-the cons elt)) ,arg))) + (first (ext:truly-the cons elt)) + (let ((output (,name ,@lambda-list))) + (setf (aref ,cache-name hash) (list ,@lambda-list output)) + output)))))))) + +(defmacro defun-equal-cached (name lambda-list &body body) + `(defun-cached ,name ,lambda-list equal-with-circularity ,@body)) + +;;; ---------------------------------------------------------------------- +;;; CONVENIENCE FUNCTIONS / MACROS +;;; + +(defun-cached env-var-name (n) eql + (format nil "env~D" n)) + +(defun-cached lex-env-var-name (n) eql + (format nil "lex~D" n)) + +(defun same-fname-p (name1 name2) + (equal name1 name2)) + +;;; from cmplabel.lsp +(defun next-label () + (cons (incf *last-label*) nil)) + +(defun next-label* () + (cons (incf *last-label*) t)) + +(defun labelp (x) + (and (consp x) (integerp (si:cons-car x)))) + +(defun maybe-next-label () + (if (labelp *exit*) + *exit* + (next-label))) + +(defun maybe-wt-label (label) + (unless (eq label *exit*) + (wt-label label))) + +(defmacro with-exit-label ((label) &body body) + `(let* ((,label (next-label)) + (*unwind-exit* (cons ,label *unwind-exit*))) + ,@body + (wt-label ,label))) + +(defmacro with-optional-exit-label ((label) &body body) + `(let* ((,label (maybe-next-label)) + (*unwind-exit* (adjoin ,label *unwind-exit*))) + ,@body + (maybe-wt-label ,label))) + +(defun next-lcl (&optional name) + (list 'LCL (incf *lcl*) T + (if (and name (symbol-package name)) + (lisp-to-c-name name) + ""))) + +(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil)) + (let ((code (incf *next-cfun*))) + (format nil prefix code (lisp-to-c-name lisp-name)))) + +(defun next-temp () + (prog1 *temp* + (incf *temp*) + (setq *max-temp* (max *temp* *max-temp*)))) + +(defun next-lex () + (prog1 (cons *level* *lex*) + (incf *lex*) + (setq *max-lex* (max *lex* *max-lex*)))) + +(defun next-env () + (prog1 *env* + (incf *env*) + (setq *max-env* (max *env* *max-env*)))) + +(defmacro reckless (&rest body) + `(locally (declare (optimize (safety 0))) + ,@body)) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 131ed65a0..a65775c75 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -5,7 +5,6 @@ '("src:cmp;cmppackage.lsp" "src:cmp;cmpglobals.lsp" "build:cmp;cmpdefs.lsp" - "src:cmp;cmpmac.lsp" "src:cmp;cmputil.lsp" "src:cmp;cmpcond.lsp" ;; Environment -- GitLab From c38a18bd0120d72f7248dc6e4ebf80ad53318868 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Feb 2023 18:50:58 +0100 Subject: [PATCH 19/33] cmp: move env-related operators from cmpvar to cmpenv-var --- src/cmp/cmpenv-var.lsp | 50 ++++++++++++++++++++++++++++++++++++ src/cmp/cmpvar.lsp | 58 +++--------------------------------------- 2 files changed, 54 insertions(+), 54 deletions(-) diff --git a/src/cmp/cmpenv-var.lsp b/src/cmp/cmpenv-var.lsp index aa29a765e..295a97fc5 100644 --- a/src/cmp/cmpenv-var.lsp +++ b/src/cmp/cmpenv-var.lsp @@ -12,3 +12,53 @@ (when (cmp-env-search-symbol-macro name env) (cmperr "Symbol ~A cannot be declared special and appear in a symbol-macrolet." name)) (cmp-env-register-var (make-global-var name :warn nil :kind 'SPECIAL) env nil)) + +;;; A special binding creates a var object with the kind field SPECIAL, +;;; whereas a special declaration without binding creates a var object with +;;; the kind field GLOBAL. Thus a reference to GLOBAL may need to make sure +;;; that the variable has a value. + +;;; Bootstrap problem: proclaim needs this function: +;;; +;;; Check if a variable has been declared as a special variable with a global +;;; value. + +(defun check-global (name) + (member name *global-vars*)) + +(defun si::register-global (name) + (pushnew name *global-vars*) + (values)) + +(defun special-variable-p (name) + "Return true if NAME is associated to a special variable in the lexical environment." + (or (si::specialp name) + (check-global name) + (let ((v (cmp-env-search-var name *cmp-env-root*))) + ;; Fixme! Revise the declamation code to ensure whether + ;; we also have to consider 'GLOBAL here. + (and v (eq (var-kind v) 'SPECIAL))))) + +(defun constant-variable-p (name) + (si::constp name)) + +(defun local-variable-p (name &optional (env *cmp-env*)) + (let ((record (cmp-env-search-var name env))) + (and record (var-p record)))) + +(defun symbol-macro-p (name &optional (env *cmp-env*)) + (let ((record (cmp-env-search-var name env))) + (and record (not (var-p record))))) + +(defun read-only-variable-p (name other-decls) + (dolist (i other-decls nil) + (when (and (eq (car i) :READ-ONLY) + (member name (rest i))) + (return t)))) + +(defun variable-type-in-env (name &optional (env *cmp-env*)) + (let ((var (cmp-env-search-var name env))) + (cond ((var-p var) + (var-type var)) + ((si:get-sysprop name 'CMP-TYPE)) + (t)))) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index f2f5765e4..5c20300d7 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -14,12 +14,6 @@ (in-package #:compiler) -(defun read-only-variable-p (v other-decls) - (dolist (i other-decls nil) - (when (and (eq (car i) :READ-ONLY) - (member v (rest i))) - (return t)))) - (defun env-grows (possibily) ;; if additional closure variables are introduced and this is not ;; last form, we must use a new env. @@ -121,7 +115,7 @@ (defun var-changed-in-form-list (var form-list) (loop for f in form-list - thereis (var-changed-in-form var f))) + thereis (var-changed-in-form var f))) ;;; FIXME! VAR-REFERENCED-IN-FORM and VAR-CHANGED-IN-FORM are too ;;; pessimistic. One should check whether the functions reading/setting the @@ -213,46 +207,6 @@ (add-to-set-nodes v form)) form) -;;; A special binding creates a var object with the kind field SPECIAL, -;;; whereas a special declaration without binding creates a var object with -;;; the kind field GLOBAL. Thus a reference to GLOBAL may need to make sure -;;; that the variable has a value. - -;;; Bootstrap problem: proclaim needs this function: -;;; -;;; Check if a variable has been declared as a special variable with a global -;;; value. - -(defun check-global (name) - (member name *global-vars*)) - -(defun special-variable-p (name) - "Return true if NAME is associated to a special variable in the lexical environment." - (or (si::specialp name) - (check-global name) - (let ((v (cmp-env-search-var name *cmp-env-root*))) - ;; Fixme! Revise the declamation code to ensure whether - ;; we also have to consider 'GLOBAL here. - (and v (eq (var-kind v) 'SPECIAL))))) - -(defun constant-variable-p (name) - (si::constp name)) - -(defun local-variable-p (name &optional (env *cmp-env*)) - (let ((record (cmp-env-search-var name env))) - (and record (var-p record)))) - -(defun symbol-macro-p (name &optional (env *cmp-env*)) - (let ((record (cmp-env-search-var name env))) - (and record (not (var-p record))))) - -(defun variable-type-in-env (name &optional (env *cmp-env*)) - (let ((var (cmp-env-search-var name env))) - (cond ((var-p var) - (var-type var)) - ((si:get-sysprop name 'CMP-TYPE)) - (t)))) - (defun var-rep-type (var) (case (var-kind var) ((LEXICAL CLOSURE SPECIAL GLOBAL) :object) @@ -270,10 +224,6 @@ (lisp-type->rep-type (var-type var)) :OBJECT))))) -(defun push-vars (v) - (setf (var-index v) (length (cmp-env-variables))) - (cmp-env-register-var v)) - (defun unboxed (var) (not (eq (var-rep-type var) :object))) @@ -290,6 +240,6 @@ (or (plusp (var-ref var)) (global-var-p var))) -(defun si::register-global (name) - (pushnew name *global-vars*) - (values)) +(defun push-vars (v) + (setf (var-index v) (length (cmp-env-variables))) + (cmp-env-register-var v)) -- GitLab From 23428b8af9e60af889bd3313ef6bc43aa04fca4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Feb 2023 20:53:56 +0100 Subject: [PATCH 20/33] cosmetic: clos: declare unused variables as ignored --- src/clos/method.lsp | 2 ++ src/clos/stdmethod.lsp | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 852b061da..7d242f31b 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -64,6 +64,7 @@ (parse-specialized-lambda-list specialized-lambda-list) (multiple-value-bind (lambda-form declarations documentation) (make-raw-lambda name lambda-list required-parameters specializers body env) + (declare (ignore declarations)) (multiple-value-bind (proto-gf proto-method) (prototypes-for-make-method-lambda name) (multiple-value-bind (fn-form options) @@ -181,6 +182,7 @@ (declare (ignore method gf)) (multiple-value-bind (call-next-method-p next-method-p-p in-closure-p) (walk-method-lambda method-lambda env) + (declare (ignore call-next-method-p next-method-p-p)) (values `(lambda (.combined-method-args. *next-methods*) (declare (special .combined-method-args. *next-methods*)) (apply ,(if in-closure-p diff --git a/src/clos/stdmethod.lsp b/src/clos/stdmethod.lsp index d22337a83..97429c850 100644 --- a/src/clos/stdmethod.lsp +++ b/src/clos/stdmethod.lsp @@ -33,7 +33,7 @@ &key (specializers nil spec-supplied-p) (lambda-list nil lambda-supplied-p) generic-function) - (declare (ignore initargs method slot-names)) + (declare (ignore initargs method slot-names generic-function)) (when slot-names (unless spec-supplied-p (error "Specializer list not supplied in method initialization")) -- GitLab From d29a26cf8a8abe24908aa46522f505d7b9bf99d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Feb 2023 20:55:03 +0100 Subject: [PATCH 21/33] cosmetic: cmp: declare unused variables as ignored --- src/cmp/cmpmain.lsp | 6 ++++-- src/cmp/cmpos-features.lsp | 1 + src/cmp/cmppass1-cont.lsp | 30 +++++++++++++++--------------- src/cmp/cmppass2-call.lsp | 1 + src/cmp/cmppass2-ffi.lsp | 5 ++++- src/cmp/cmppass2-loc.lsp | 6 ++++-- src/cmp/cmppass2-special.lsp | 13 ++++++------- src/cmp/cmppass2-top.lsp | 4 +++- src/cmp/cmppass2-var.lsp | 2 ++ 9 files changed, 40 insertions(+), 28 deletions(-) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 2ff7cba39..9fc19afd7 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -217,6 +217,7 @@ the environment variable TMPDIR to a different value." template)) #+dlopen (defun bundle-cc (o-pathname init-name object-files) + (declare (ignore init-name)) (let ((ld-flags (split-program-options *ld-bundle-flags*)) (ld-libs (split-program-options *ld-libs*))) #+msvc @@ -236,7 +237,7 @@ the environment variable TMPDIR to a different value." template)) #+mingw32 (setf ld-flags (list* "-shared" "-Wl,--export-all-symbols" ld-flags)) (linker-cc o-pathname object-files :type :fasl - :ld-flags ld-flags :ld-libs ld-libs))) + :ld-flags ld-flags :ld-libs ld-libs))) (defconstant +lisp-program-header+ " #include @@ -637,7 +638,8 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); (ext:*source-location* (cons source-truename 0)) (*suppress-compiler-messages* (or *suppress-compiler-messages* (not *compile-verbose*)))) - (declare (notinline compiler-cc)) + (declare (ignore output-file) + (notinline compiler-cc)) "Compiles the file specified by INPUT-PATHNAME and generates a fasl file specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME, then \".lsp\" is used as the default file type for the source file. LOAD diff --git a/src/cmp/cmpos-features.lsp b/src/cmp/cmpos-features.lsp index 397fded50..fab08074e 100644 --- a/src/cmp/cmpos-features.lsp +++ b/src/cmp/cmpos-features.lsp @@ -64,6 +64,7 @@ thereis (pathname-match-p base pattern-path))) (defun gather-keywords (strings patterns) + (declare (ignore patterns)) (let ((strings (reduce #'append (mapcar #'split-words strings)))) (mapcar (lambda (s) (intern (string-upcase s) (find-package :keyword))) diff --git a/src/cmp/cmppass1-cont.lsp b/src/cmp/cmppass1-cont.lsp index f86d4644f..31f12532e 100644 --- a/src/cmp/cmppass1-cont.lsp +++ b/src/cmp/cmppass1-cont.lsp @@ -128,21 +128,21 @@ ;; Split forms according to the tag they are preceded by and compile ;; them grouped by PROGN. This help us use the optimizations in ;; C1PROGN to recognize transfers of control. - (loop for form in body - with output = '() - with tag-body = nil - with this-tag = (make-var :name 'tagbody-beginnnig :kind nil) - do (cond ((tag-p form) - (when tag-body - (setf output (cons (c1progn (nreconc tag-body '(nil))) output) - tag-body nil)) - (push form output)) - (t - (push form tag-body))) - finally (setf body - (if tag-body - (cons (c1progn (nreconc tag-body '(nil))) output) - output))) + (make-var :name 'tagbody-beginnnig :kind nil) ; "this-tag" + (loop with output = '() + with tag-body = nil + for form in body + do (cond ((tag-p form) + (when tag-body + (setf output (cons (c1progn (nreconc tag-body '(nil))) output) + tag-body nil)) + (push form output)) + (t + (push form tag-body))) + finally (setf body + (if tag-body + (cons (c1progn (nreconc tag-body '(nil))) output) + output))) ;;; Reverse the body list, deleting unused tags. (loop for form in body diff --git a/src/cmp/cmppass2-call.lsp b/src/cmp/cmppass2-call.lsp index 12187275b..6b98066a9 100644 --- a/src/cmp/cmppass2-call.lsp +++ b/src/cmp/cmppass2-call.lsp @@ -255,6 +255,7 @@ (when fname (wt-comment fname)))) (defun wt-call-normal (fun args type) + (declare (ignore type)) (unless (fun-cfun fun) (baboon "Function without a C name: ~A" (fun-name fun))) (let* ((minarg (fun-minarg fun)) diff --git a/src/cmp/cmppass2-ffi.lsp b/src/cmp/cmppass2-ffi.lsp index b722fac2a..bb21e2f54 100644 --- a/src/cmp/cmppass2-ffi.lsp +++ b/src/cmp/cmppass2-ffi.lsp @@ -326,12 +326,13 @@ ;; (defun c2c-progn (c1form variables statements) + (declare (ignore c1form)) (loop with *destination* = 'TRASH for form in statements do (cond ((stringp form) (wt-nl) (wt-c-inline-loc :void form variables - t ; side effects + t ; side effects nil) ; no output variables ) (t @@ -445,6 +446,7 @@ `(COERCE-LOC ,rep-type ,loc))))) (defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars) + (declare (ignore output-rep-type side-effects)) (with-input-from-string (s c-expression) (when (and output-vars (not (eq output-vars 'VALUES))) (wt-nl)) @@ -495,6 +497,7 @@ (defun t3-defcallback (lisp-name c-name c-name-constant return-type return-type-code arg-types arg-type-constants call-type &aux (return-p t)) + (declare (ignore lisp-name)) (when (eql return-type :void) (setf return-p nil)) (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type))) diff --git a/src/cmp/cmppass2-loc.lsp b/src/cmp/cmppass2-loc.lsp index 8ec8ca84d..2f6d134f1 100644 --- a/src/cmp/cmppass2-loc.lsp +++ b/src/cmp/cmppass2-loc.lsp @@ -174,8 +174,10 @@ (wt "v" lcl)) (defun wt-lcl-loc (lcl &optional type name) - (unless (numberp lcl) (baboon :format-control "wt-lcl-loc: ~s NaN" - :format-arguments (list lcl))) + (declare (ignore type)) + (unless (numberp lcl) + (baboon :format-control "wt-lcl-loc: ~s NaN" + :format-arguments (list lcl))) (wt "v" lcl name)) (defun wt-temp (temp) diff --git a/src/cmp/cmppass2-special.lsp b/src/cmp/cmppass2-special.lsp index ec6809a70..35f364375 100644 --- a/src/cmp/cmppass2-special.lsp +++ b/src/cmp/cmppass2-special.lsp @@ -19,7 +19,7 @@ (progv symbols values (c2expr body))) (defun c2function (c1form kind funob fun) - (declare (ignore c1form)) + (declare (ignore c1form funob)) (case kind (GLOBAL (unwind-exit (list 'FDEFINITION fun))) @@ -37,12 +37,11 @@ (CLOSURE (setf (fun-level fun) 0 (fun-env fun) *env*)) (LEXICAL - (let ((parent (fun-parent fun))) - ;; Only increase the lexical level if there have been some - ;; new variables created. This way, the same lexical environment - ;; can be propagated through nested FLET/LABELS. - (setf (fun-level fun) (if (plusp *lex*) (1+ *level*) *level*) - (fun-env fun) 0))) + ;; Only increase the lexical level if there have been some + ;; new variables created. This way, the same lexical environment + ;; can be propagated through nested FLET/LABELS. + (setf (fun-level fun) (if (plusp *lex*) (1+ *level*) *level*) + (fun-env fun) 0)) (otherwise (setf (fun-env fun) 0 (fun-level fun) 0))) (let ((previous diff --git a/src/cmp/cmppass2-top.lsp b/src/cmp/cmppass2-top.lsp index 334484a1b..c724d2200 100644 --- a/src/cmp/cmppass2-top.lsp +++ b/src/cmp/cmppass2-top.lsp @@ -236,7 +236,7 @@ (wt-label *exit*))) (defun t2init-form (c1form vv-loc form) - (declare (ignore c1form)) + (declare (ignore c1form vv-loc)) (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) (*destination* 'TRASH)) (c2expr form) @@ -473,9 +473,11 @@ (format stream "~%};"))))) (defun t2fset (c1form &rest args) + (declare (ignore args)) (t2ordinary nil c1form)) (defun c2fset (c1form fun fname macro pprint c1forms) + (declare (ignore pprint)) (when (fun-no-entry fun) (wt-nl "(void)0; /* No entry created for " (format nil "~A" (fun-name fun)) diff --git a/src/cmp/cmppass2-var.lsp b/src/cmp/cmppass2-var.lsp index 90ea49af4..67416d224 100644 --- a/src/cmp/cmppass2-var.lsp +++ b/src/cmp/cmppass2-var.lsp @@ -97,6 +97,7 @@ (nr (make-lcl-var :type :int)) (*inline-blocks* 0) min-values max-values) + (declare (ignore nr)) ;; 1) Retrieve the number of output values (multiple-value-setq (min-values max-values) (c1form-values-number init-form)) @@ -300,6 +301,7 @@ ;; many they are. (multiple-value-bind (min-values max-values) (c1form-values-number form) + (declare (ignore max-values)) ;; We save the values in the value stack + value0 (let ((*destination* 'RETURN)) -- GitLab From e984568e7d1bb745e115697b9607909b72937b63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Feb 2023 21:22:38 +0100 Subject: [PATCH 22/33] cmp: rearrange cmppolicy to have a correct order assume-right-types were used before it was defined. --- src/cmp/cmppolicy.lsp | 331 +++++++++++++++++++++--------------------- 1 file changed, 164 insertions(+), 167 deletions(-) diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index c24eba1c9..12cfe8264 100644 --- a/src/cmp/cmppolicy.lsp +++ b/src/cmp/cmppolicy.lsp @@ -16,33 +16,19 @@ (in-package "COMPILER") -(eval-when (:compile-toplevel :execute) - (defconstant +optimization-quality-orders+ '(debug safety speed space))) - (eval-when (:compile-toplevel :execute) (defparameter *optimization-quality-switches* (loop with hash = (make-hash-table :size 64 :test #'eq) - for name in +optimization-quality-orders+ - for i from 0 by 4 - for list = (loop with mask = (ash #b1111 i) - for level from 0 to 3 - for bits = (ash 1 (+ level i)) - collect (cons bits (logxor bits mask))) - do (setf (gethash name hash) list) - finally (return hash))) - (setf (gethash 'compilation-speed *optimization-quality-switches*) - '#1=((0 . 0) . #1#))) - -#.`(eval-when (:compile-toplevel :execute :load-toplevel) - ,@(loop for name in +optimization-quality-orders+ - for i from 0 by 4 - for fun-name = (intern (concatenate 'string - "POLICY-TO-" (symbol-name name) "-LEVEL")) - collect `(defun ,fun-name (policy) - (declare (ext:assume-right-type)) - (loop for level from 0 to 3 - when (logbitp (+ level ,i) policy) - return level)))) + for name in '(debug safety speed space) + for i from 0 by 4 + for list = (loop with mask = (ash #b1111 i) + for level from 0 to 3 + for bits = (ash 1 (+ level i)) + collect (cons bits (logxor bits mask))) + do (setf (gethash name hash) list) + finally (setf (gethash 'compilation-speed hash) + '#1=((0 . 0) . #1#)) + (return hash)))) (defun optimization-quality-switches (type index) (nth index (gethash type *optimization-quality-switches*))) @@ -107,58 +93,45 @@ env (cmp-env-add-declaration 'optimization (list (default-policy)) env))) -(defun cmp-env-all-optimizations (&optional (env *cmp-env*)) - (let ((o (cmp-env-policy env))) - (list (policy-to-debug-level o) - (policy-to-safety-level o) - (policy-to-space-level o) - (policy-to-speed-level o)))) - -(defun cmp-env-optimization (property &optional (env *cmp-env*)) - (let ((o (cmp-env-policy env))) - (case property - (debug (policy-to-debug-level o)) - (safety (policy-to-safety-level o)) - (space (policy-to-space-level o)) - (speed (policy-to-speed-level o))))) - (eval-when (:compile-toplevel :execute) (defparameter +last-optimization-bit+ 17) (defun augment-policy (quality level on-off flag) #+(or) (if (eq on-off :on) (loop for i from 0 to 3 - for bits = (optimization-quality-switches quality i) - if (>= i level) - do (rplaca bits (logior (car bits) flag)) - else do (rplacd bits (logior (cdr bits) flag))) + for bits = (optimization-quality-switches quality i) + if (>= i level) + do (rplaca bits (logior (car bits) flag)) + else do (rplacd bits (logior (cdr bits) flag))) (loop for i from 0 to 3 - for bits = (optimization-quality-switches quality i) - when (>= i level) - do (rplacd bits (logior (cdr bits) flag)))) + for bits = (optimization-quality-switches quality i) + when (>= i level) + do (rplacd bits (logior (cdr bits) flag)))) #+(or) (loop for i from level to 3 - for bits = (optimization-quality-switches quality i) - if (eq on-off :on) - do (rplaca bits (logior (car bits) flag)) - else do (rplacd bits (logior (cdr bits) flag))) + for bits = (optimization-quality-switches quality i) + if (eq on-off :on) + do (rplaca bits (logior (car bits) flag)) + else do (rplacd bits (logior (cdr bits) flag))) (loop for i from 0 to 3 - for bits = (optimization-quality-switches quality i) - if (< i level) - do - (case on-off - (:on (rplacd bits (logior (cdr bits) flag))) - (:off (rplaca bits (logior (car bits) flag)))) - else do - (case on-off - ((:only-on :on) (rplaca bits (logior (car bits) flag))) - ((:only-off :off) (rplacd bits (logior (cdr bits) flag))))) - ) + for bits = (optimization-quality-switches quality i) + if (< i level) + do + (case on-off + (:on (rplacd bits (logior (cdr bits) flag))) + (:off (rplaca bits (logior (car bits) flag)))) + else do + (case on-off + ((:only-on :on) (rplaca bits (logior (car bits) flag))) + ((:only-off :off) (rplacd bits (logior (cdr bits) flag)))))) + (defun policy-declaration-name (base) (intern (symbol-name base) (find-package "EXT"))) + (defun policy-function-name (base) (intern (concatenate 'string "POLICY-" (symbol-name base)) (find-package "C"))) + (defmacro define-policy (&whole whole name &rest conditions) (let* ((test (ash 1 +last-optimization-bit+)) (declaration-name (policy-declaration-name name)) @@ -175,141 +148,165 @@ flags-list)) ;; Scan the definition and correct the flags (loop with extra = '() - with slow = '() - with conditions = (remove doc conditions) - for case = (pop conditions) - while case - do - (case case - (:no-function - (setf emit-function nil)) - (:alias - (let* ((alias (first conditions))) - (setf (gethash declaration-name *optimization-quality-switches*) - (gethash (policy-declaration-name alias) - *optimization-quality-switches*)) - (return `(defun ,function-name (&optional (env *cmp-env*)) - ,@(and doc (list doc)) - (,(policy-function-name alias) env))))) - (:anti-alias - (let* ((alias (first conditions)) - (bits (gethash (policy-declaration-name alias) - *optimization-quality-switches*))) - (setf bits (list (second bits) - (first bits))) - (rplacd (cdr bits) (cdr bits)) - (setf (gethash declaration-name *optimization-quality-switches*) - bits) - (return `(defun ,function-name (&optional (env *cmp-env*)) + with slow = '() + with conditions = (remove doc conditions) + for case = (pop conditions) + while case + do + (case case + (:no-function + (setf emit-function nil)) + (:alias + (let* ((alias (first conditions))) + (setf (gethash declaration-name *optimization-quality-switches*) + (gethash (policy-declaration-name alias) + *optimization-quality-switches*)) + (return `(defun ,function-name (&optional (env *cmp-env*)) + ,@(and doc (list doc)) + (,(policy-function-name alias) env))))) + (:anti-alias + (let* ((alias (first conditions)) + (bits (gethash (policy-declaration-name alias) + *optimization-quality-switches*))) + (setf bits (list (second bits) + (first bits))) + (rplacd (cdr bits) (cdr bits)) + (setf (gethash declaration-name *optimization-quality-switches*) + bits) + (return `(defun ,function-name (&optional (env *cmp-env*)) + ,@(and doc (list doc)) + (not (,(policy-function-name alias) env)))))) + ((:only-on :on) + (push `(>= (cmp-env-optimization ',(first conditions) env) + ,(second conditions)) + slow) + (augment-policy (pop conditions) (pop conditions) + case test)) + ((:only-off :off) + (push `(< (cmp-env-optimization ',(first conditions) env) + ,(second conditions)) + slow) + (augment-policy (pop conditions) (pop conditions) + case test)) + (:requires + (push (pop conditions) extra)) + (otherwise + (error "Syntax error in macro~% ~A" + `(define-policy ,@whole)))) + finally + (progn + (incf +last-optimization-bit+) + (return + (and emit-function + `(defun ,function-name (&optional (env *cmp-env*)) ,@(and doc (list doc)) - (not (,(policy-function-name alias) env)))))) - ((:only-on :on) - (push `(>= (cmp-env-optimization ',(first conditions) env) - ,(second conditions)) - slow) - (augment-policy (pop conditions) (pop conditions) - case test)) - ((:only-off :off) - (push `(< (cmp-env-optimization ',(first conditions) env) - ,(second conditions)) - slow) - (augment-policy (pop conditions) (pop conditions) - case test)) - (:requires - (push (pop conditions) extra)) - (otherwise - (error "Syntax error in macro~% ~A" - `(define-policy ,@whole)))) - finally - (progn - (incf +last-optimization-bit+) - (return - (and emit-function - `(defun ,function-name (&optional (env *cmp-env*)) - ,@(and doc (list doc)) - (let ((bits (cmp-env-policy env))) - (and (logtest bits ,test) - ,@extra)))))))))) + (let ((bits (cmp-env-policy env))) + (and (logtest bits ,test) + ,@extra)))))))))) (eval-when (:compile-toplevel :load-toplevel :execute) -;; -;; ERROR CHECKING POLICY -;; + ;; + ;; ERROR CHECKING POLICY + ;; -(define-policy ext:assume-no-errors :off safety 1) + (define-policy ext:assume-no-errors :off safety 1) -(define-policy ext:assume-right-type :alias ext:assume-no-errors) + (define-policy ext:assume-right-type :alias ext:assume-no-errors) -(define-policy ext:type-assertions :anti-alias ext:assume-no-errors - "Generate type assertions when inlining accessors and other functions.") + (define-policy ext:type-assertions :anti-alias ext:assume-no-errors + "Generate type assertions when inlining accessors and other functions.") -(define-policy ext:check-stack-overflow :on safety 2 - "Add a stack check to every function") + (define-policy ext:check-stack-overflow :on safety 2 + "Add a stack check to every function") -(define-policy ext:check-arguments-type :on safety 1 - "Generate CHECK-TYPE forms for function arguments with type declarations") + (define-policy ext:check-arguments-type :on safety 1 + "Generate CHECK-TYPE forms for function arguments with type declarations") -(define-policy ext:array-bounds-check :on safety 1 - "Check out of bounds access to arrays") + (define-policy ext:array-bounds-check :on safety 1 + "Check out of bounds access to arrays") -(define-policy ext:global-var-checking :on safety 3 - "Read the value of a global variable even if it is discarded, ensuring it is bound") + (define-policy ext:global-var-checking :on safety 3 + "Read the value of a global variable even if it is discarded, ensuring it is bound") -(define-policy ext:global-function-checking :on safety 3 - "Read the binding of a global function even if it is discarded") + (define-policy ext:global-function-checking :on safety 3 + "Read the binding of a global function even if it is discarded") -(define-policy ext:check-nargs :on safety 1 :only-on ext:check-arguments-type 1 - "Check that the number of arguments a function receives is within bounds") + (define-policy ext:check-nargs :on safety 1 :only-on ext:check-arguments-type 1 + "Check that the number of arguments a function receives is within bounds") -(define-policy ext:the-is-checked :on safety 1 - "THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE.") + (define-policy ext:the-is-checked :on safety 1 + "THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE.") -;; -;; INLINING POLICY -;; + ;; + ;; INLINING POLICY + ;; -(define-policy ext:assume-types-dont-change :off safety 1 - "Assume that type and class definitions will not change") + (define-policy ext:assume-types-dont-change :off safety 1 + "Assume that type and class definitions will not change") -(define-policy ext:inline-slot-access :on speed 1 :off debug 2 :off safety 2 - "Inline access to structures and sealed classes") + (define-policy ext:inline-slot-access :on speed 1 :off debug 2 :off safety 2 + "Inline access to structures and sealed classes") -(define-policy ext:inline-accessors :off debug 2 :off space 2 - "Inline access to object slots, including conses and arrays") + (define-policy ext:inline-accessors :off debug 2 :off space 2 + "Inline access to object slots, including conses and arrays") -(define-policy ext:inline-bit-operations :off space 2 - "Inline LDB and similar functions") + (define-policy ext:inline-bit-operations :off space 2 + "Inline LDB and similar functions") -(define-policy ext:open-code-aref/aset :alias ext:inline-accessors - "Inline access to arrays") + (define-policy ext:open-code-aref/aset :alias ext:inline-accessors + "Inline access to arrays") -(define-policy ext:evaluate-forms :off debug 1 - "Pre-evaluate a function that takes constant arguments") + (define-policy ext:evaluate-forms :off debug 1 + "Pre-evaluate a function that takes constant arguments") -(define-policy ext:use-direct-C-call :off debug 2 - "Emit direct calls to a function whose C name is known") + (define-policy ext:use-direct-C-call :off debug 2 + "Emit direct calls to a function whose C name is known") -(define-policy ext:inline-type-checks :off space 2 - "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP, + (define-policy ext:inline-type-checks :off space 2 + "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP, INTGERP, STRINGP.") -(define-policy ext:inline-sequence-functions :off space 2 - "Inline functions such as MAP, MEMBER, FIND, etc") + (define-policy ext:inline-sequence-functions :off space 2 + "Inline functions such as MAP, MEMBER, FIND, etc") + + ;; + ;; DEBUG POLICY + ;; + + (define-policy ext:debug-variable-bindings :on debug 3 + :requires (policy-debug-ihs-frame env) + ;; We can only create variable bindings when the function has an IHS frame!!! + "Create a debug vector with the bindings of each LET/LET*/LAMBDA form?") -;; -;; DEBUG POLICY -;; + (define-policy ext:debug-ihs-frame :on debug 3 + "Let the functions appear in backtraces")) -(define-policy ext:debug-variable-bindings :on debug 3 - :requires (policy-debug-ihs-frame env) - ;; We can only create variable bindings when the function has an IHS frame!!! - "Create a debug vector with the bindings of each LET/LET*/LAMBDA form?") +(macrolet ((define-function (fun-name offset) + `(defun ,fun-name (policy) + (declare (ext:assume-right-type)) + (loop for level from 0 to 3 + when (logbitp (+ level ,offset) policy) + return level)))) + (define-function policy-to-debug-level 0) + (define-function policy-to-safety-level 4) + (define-function policy-to-speed-level 8) + (define-function policy-to-space-level 12)) -(define-policy ext:debug-ihs-frame :on debug 3 - "Let the functions appear in backtraces") +(defun cmp-env-all-optimizations (&optional (env *cmp-env*)) + (let ((o (cmp-env-policy env))) + (list (policy-to-debug-level o) + (policy-to-safety-level o) + (policy-to-space-level o) + (policy-to-speed-level o)))) -); eval-when +(defun cmp-env-optimization (property &optional (env *cmp-env*)) + (let ((o (cmp-env-policy env))) + (case property + (debug (policy-to-debug-level o)) + (safety (policy-to-safety-level o)) + (space (policy-to-space-level o)) + (speed (policy-to-speed-level o))))) (defun safe-compile () (>= (cmp-env-optimization 'safety) 2)) -- GitLab From 81a671dea7a41bb7c607bbacf1b6744bb238a57b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 16 Feb 2023 21:32:51 +0100 Subject: [PATCH 23/33] cmp: defun-cached: fix reset-cache and a declaration reset-cache did cons a new array but did not assign it to the cache variable so it was essentially a no-op. Also we bind cache to lexvar and then declare that lexvar to preserve declaration semantics. --- src/cmp/cmputil.lsp | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 356176dfe..47a3aa976 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -488,18 +488,20 @@ comparing circular objects." ((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL) (t (setf test 'EQUALP) 'SI::HASH-EQUALP)))) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil))) - (defun ,reset-name () + (defvar ,cache-name (make-array 1024 :element-type t :adjustable nil)) + (defun ,reset-name () + (setf ,cache-name + (make-array 1024 :element-type t :adjustable nil))) (defun ,name ,lambda-list (flet ((,name ,lambda-list ,@body)) (let* ((hash (logand (,hash-function ,@lambda-list) 1023)) - (elt (aref ,cache-name hash))) + (cache ,cache-name) + (elt (aref cache hash))) (declare (type (integer 0 1023) hash) - (type (array t (*)) ,cache-name)) + (type (array t (*)) cache)) (if (and elt ,@(loop for arg in lambda-list - collect `(,test (pop (ext:truly-the cons elt)) ,arg))) + collect `(,test (pop (ext:truly-the cons elt)) ,arg))) (first (ext:truly-the cons elt)) (let ((output (,name ,@lambda-list))) (setf (aref ,cache-name hash) (list ,@lambda-list output)) -- GitLab From 76f0ac23998e899406c4463a37be26b87b93ffa5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 17 Feb 2023 11:09:04 +0100 Subject: [PATCH 24/33] cmp: remove obsolete function push-vars The function push-vars initialized a slot var-index and called cmp-env-register-var however var-index is never read so there is no need for that. Remove both function and the unused slot. --- src/cmp/cmppass1-call.lsp | 2 +- src/cmp/cmppass1-fun.lsp | 15 +++++++++------ src/cmp/cmppass1-var.lsp | 7 ++++--- src/cmp/cmptypes.lsp | 1 - src/cmp/cmpvar.lsp | 4 ---- 5 files changed, 14 insertions(+), 15 deletions(-) diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index 762900507..c282be923 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -181,7 +181,7 @@ ;; environment in which the function was defined to get ;; inlining of closures right. (let ((*cmp-env* (cmp-env-copy (fun-cmp-env fun)))) - (mapc #'push-vars let-vars) + (mapc #'cmp-env-register-var let-vars) (process-let-body 'LET* let-vars let-inits specials other-decls body setjmps)))))) (defun c1call-local (fname fun args) diff --git a/src/cmp/cmppass1-fun.lsp b/src/cmp/cmppass1-fun.lsp index 23086823a..9bad5f480 100644 --- a/src/cmp/cmppass1-fun.lsp +++ b/src/cmp/cmppass1-fun.lsp @@ -248,7 +248,7 @@ (var (c1make-var name ss is ts))) (push var type-checks) (setf (first specs) var) - (push-vars var))) + (cmp-env-register-var var))) (do ((specs (setq optionals (cdr optionals)) (cdddr specs))) ((endp specs)) @@ -261,15 +261,17 @@ :safe "In (LAMBDA ~a...)" function-name) (default-init var))) (push var type-checks) - (push-vars var) + (cmp-env-register-var var) (when flag - (push-vars (setq flag (c1make-var flag ss is ts)))) + (setq flag (c1make-var flag ss is ts)) + (cmp-env-register-var flag)) (setf (first specs) var (second specs) init (third specs) flag))) (when rest - (push-vars (setq rest (c1make-var rest ss is ts)))) + (setq rest (c1make-var rest ss is ts)) + (cmp-env-register-var rest)) (do ((specs (setq keywords (cdr keywords)) (cddddr specs))) ((endp specs)) @@ -284,9 +286,10 @@ :safe "In (LAMBDA ~a...)" function-name) (default-init var))) (push var type-checks) - (push-vars var) + (cmp-env-register-var var) (when flag - (push-vars (setq flag (c1make-var flag ss is ts)))) + (setq flag (c1make-var flag ss is ts)) + (cmp-env-register-var flag)) (setf (second specs) var (third specs) init (fourth specs) flag))) diff --git a/src/cmp/cmppass1-var.lsp b/src/cmp/cmppass1-var.lsp index b9a42d0d4..1448935a6 100644 --- a/src/cmp/cmppass1-var.lsp +++ b/src/cmp/cmppass1-var.lsp @@ -111,11 +111,12 @@ (when var (push var vars) (push init forms) - (when (eq let/let* 'LET*) (push-vars var))))) + (when (eq let/let* 'LET*) + (cmp-env-register-var var))))) (setf vars (nreverse vars) forms (nreverse forms)) (when (eq let/let* 'LET) - (mapc #'push-vars vars)) + (mapc #'cmp-env-register-var vars)) (check-vdecl (mapcar #'var-name vars) types ignoreds) (values vars forms specials other-decls body)))) @@ -361,7 +362,7 @@ (let* ((vars (loop for name in variables collect (c1make-var name ss is ts)))) (setq init-form (c1expr init-form)) - (mapc #'push-vars vars) + (mapc #'cmp-env-register-var vars) (check-vdecl variables ts is) (setq body (c1decl-body other-decls body)) (mapc #'check-vref vars) diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp index 369ac8ef1..f225dc046 100644 --- a/src/cmp/cmptypes.lsp +++ b/src/cmp/cmptypes.lsp @@ -73,7 +73,6 @@ ;;; lex-ndx is the index within the array for this env. ;;; For SPECIAL and GLOBAL: the vv-index for variable name. (type t) ;;; Type of the variable. - (index -1) ;;; position in *vars*. Used by similar. (ignorable nil) ;;; Whether there was an IGNORABLE/IGNORE declaration ) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 5c20300d7..fd049e4f3 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -239,7 +239,3 @@ (defun useful-var-p (var) (or (plusp (var-ref var)) (global-var-p var))) - -(defun push-vars (v) - (setf (var-index v) (length (cmp-env-variables))) - (cmp-env-register-var v)) -- GitLab From 2c09a82c1126818edce8db2d4dac97d831dc7347 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 17 Feb 2023 13:30:21 +0100 Subject: [PATCH 25/33] cmp: move locations and representations into separate files --- src/cmp/cmplocs.lsp | 249 ++++++++++++++++++++++ src/cmp/{cmpc-machine.lsp => cmpmach.lsp} | 73 +++++-- src/cmp/cmppass2-call.lsp | 5 + src/cmp/cmppass2-data.lsp | 5 - src/cmp/cmppass2-exit.lsp | 4 +- src/cmp/cmppass2-ffi.lsp | 104 --------- src/cmp/cmppass2-loc.lsp | 165 -------------- src/cmp/cmppass2-var.lsp | 4 +- src/cmp/cmptypes.lsp | 24 --- src/cmp/load.lsp.in | 4 +- 10 files changed, 321 insertions(+), 316 deletions(-) create mode 100644 src/cmp/cmplocs.lsp rename src/cmp/{cmpc-machine.lsp => cmpmach.lsp} (85%) diff --git a/src/cmp/cmplocs.lsp b/src/cmp/cmplocs.lsp new file mode 100644 index 000000000..3071c44de --- /dev/null +++ b/src/cmp/cmplocs.lsp @@ -0,0 +1,249 @@ + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański +;;;; +;;;; See file 'LICENSE' for the copyright details. + +(in-package #:compiler) + +;;; ---------------------------------------------------------------------------- +;;; LOCATIONS and representation types +;;; +;;; Locations are lisp expressions which represent actual target (i.e C) data. +;;; To each location we can associate a representation type, which is the type +;;; of the target data (i.e uint32_t). + +;;; The following routines help in determining these types, and also in moving +;;; data from one location to another. + +(defstruct vv + (location nil) + (used-p nil) + (permanent-p t) + (value nil)) + +(defun vv-type (loc) + (let ((value (vv-value loc))) + (if (and value (not (ext:fixnump value))) + (type-of value) + t))) + +(defun loc-movable-p (loc) + (if (atom loc) + t + (case (first loc) + ((CALL CALL-LOCAL) NIL) + ((ffi:c-inline) (not (fifth loc))) ; side effects? + (otherwise t)))) + +(defun loc-type (loc) + (cond ((eq loc NIL) 'NULL) + ((var-p loc) (var-type loc)) + ((vv-p loc) (vv-type loc)) + ((numberp loc) (lisp-type->rep-type (type-of loc))) + ((atom loc) 'T) + (t + (case (first loc) + (FIXNUM-VALUE 'FIXNUM) + (CHARACTER-VALUE (type-of (code-char (second loc)))) + (DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT) + (SINGLE-FLOAT-VALUE 'SINGLE-FLOAT) + (LONG-FLOAT-VALUE 'LONG-FLOAT) + (CSFLOAT-VALUE 'SI:COMPLEX-SINGLE-FLOAT) + (CDFLOAT-VALUE 'SI:COMPLEX-DOUBLE-FLOAT) + (CLFLOAT-VALUE 'SI:COMPLEX-LONG-FLOAT) + (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)) + (CALL-NORMAL (fourth loc)) + (otherwise T))))) + +(defun loc-representation-type (loc) + (cond ((member loc '(NIL T)) :object) + ((var-p loc) (var-rep-type loc)) + ((vv-p loc) :object) + ((numberp loc) (lisp-type->rep-type (type-of loc))) + ((eq loc 'TRASH) :void) + ((atom loc) :object) + (t + (case (first loc) + (FIXNUM-VALUE :fixnum) + (CHARACTER-VALUE (if (<= (second loc) 255) :unsigned-char :wchar)) + (DOUBLE-FLOAT-VALUE :double) + (SINGLE-FLOAT-VALUE :float) + (LONG-FLOAT-VALUE :long-double) + (CSFLOAT-VALUE :csfloat) + (CDFLOAT-VALUE :cdfloat) + (CLFLOAT-VALUE :clfloat) + (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) + (THE (loc-representation-type (third loc))) + (otherwise :object))))) + +(defun loc-with-side-effects-p (loc &aux name) + (cond ((var-p loc) + (and (global-var-p loc) + (policy-global-var-checking))) + ((atom loc) + nil) + ((member (setf name (first loc)) '(CALL CALL-NORMAL CALL-INDIRECT) + :test #'eq) + t) + ((eq name 'cl:THE) + (loc-with-side-effects-p (third loc))) + ((eq name 'cl:FDEFINITION) + (policy-global-function-checking)) + ((eq name 'ffi:C-INLINE) + (or (eq (sixth loc) 'cl:VALUES) ;; Uses VALUES + (fifth loc))))) ;; or side effects + +(defun loc-refers-to-special-p (loc) + (cond ((var-p loc) + (member (var-kind loc) '(SPECIAL GLOBAL))) + ((atom loc) + nil) + ((eq (first loc) 'THE) + (loc-refers-to-special-p (third loc))) + ((eq (setf loc (first loc)) 'BIND) + t) + ((eq loc 'ffi:C-INLINE) + t) ; We do not know, so guess yes + (t nil))) + +;;; Valid locations are: +;;; NIL +;;; T +;;; fixnum +;;; VALUE0 +;;; VALUES +;;; var-object +;;; a string designating a C expression +;;; ( VALUE i ) VALUES(i) +;;; ( VV vv-index ) +;;; ( VV-temp vv-index ) +;;; ( LCL lcl [representation-type]) local variable, type unboxed +;;; ( TEMP temp ) local variable, type object +;;; ( 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 +;;; ( FFI:C-INLINE output-type fun/string locs side-effects output-var ) +;;; ( COERCE-LOC representation-type location) +;;; ( FDEFINITION vv-index ) +;;; ( MAKE-CCLOSURE cfun ) +;;; ( FIXNUM-VALUE fixnum-value ) +;;; ( CHARACTER-VALUE character-code ) +;;; ( LONG-FLOAT-VALUE long-float-value vv ) +;;; ( DOUBLE-FLOAT-VALUE double-float-value vv ) +;;; ( SINGLE-FLOAT-VALUE single-float-value vv ) +;;; ( CSFLOAT-VALUE csfloat-value vv ) +;;; ( CDFLOAT-VALUE cdfloat-value vv ) +;;; ( CLFLOAT-VALUE clfloat-value vv ) +;;; ( STACK-POINTER index ) retrieve a value from the stack +;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) +;;; ( THE type location ) +;;; ( KEYVARS n ) +;;; VA-ARG +;;; CL-VA-ARG + +;;; Valid *DESTINATION* locations are: +;;; +;;; VALUE0 +;;; RETURN Object returned from current function. +;;; TRASH Value may be thrown away. +;;; VALUES Values vector. +;;; var-object +;;; ( LCL lcl ) +;;; ( LEX lex-address ) +;;; ( BIND var alternative ) Alternative is optional +;;; ( JUMP-TRUE label ) +;;; ( JUMP-FALSE label ) + +(defun tmp-destination (loc) + (case loc + (VALUES 'VALUES) + (TRASH 'TRASH) + (T 'RETURN))) + +(defun precise-loc-type (loc new-type) + (if (subtypep (loc-type loc) new-type) + loc + `(the ,new-type ,loc))) + +(defun loc-in-c1form-movable-p (loc) + "A location that is in a C1FORM and can be moved" + (cond ((member loc '(t nil)) + t) + ((numberp loc) + t) + ((stringp loc) + t) + ((vv-p loc) + t) + ((member loc '(value0 values va-arg cl-va-arg)) + nil) + ((atom loc) + (baboon :format-control "Unknown location ~A found in C1FORM" + :format-arguments (list loc))) + ((eq (first loc) 'THE) + (loc-in-c1form-movable-p (third loc))) + ((member (setf loc (car loc)) + '(VV VV-TEMP FIXNUM-VALUE CHARACTER-VALUE + DOUBLE-FLOAT-VALUE SINGLE-FLOAT-VALUE LONG-FLOAT-VALUE + #+complex-float CSFLOAT-VALUE + #+complex-float CDFLOAT-VALUE + #+complex-float CLFLOAT-VALUE + KEYVARS)) + t) + (t + (baboon :format-control "Unknown location ~A found in C1FORM" + :format-arguments (list loc))))) + +(defun uses-values (loc) + (and (consp loc) + (or (member (car loc) '(CALL CALL-NORMAL CALL-INDIRECT) :test #'eq) + (and (eq (car loc) 'ffi:C-INLINE) + (eq (sixth loc) 'cl:VALUES))))) + +(defun loc-immediate-value-p (loc) + (cond ((eq loc t) + (values t t)) + ((eq loc nil) + (values t nil)) + ((numberp loc) + (values t loc)) + ((vv-p loc) + (let ((value (vv-value loc))) + (if (or (null value) (ext:fixnump value)) + (values nil nil) + (values t value)))) + ((atom loc) + (values nil nil)) + ((eq (first loc) 'THE) + (loc-immediate-value-p (third loc))) + ((member (first loc) + '(fixnum-value long-float-value + double-float-value single-float-value + csfloat-value cdfloat-value clfloat-value)) + (values t (second loc))) + ((eq (first loc) 'character-value) + (values t (code-char (second loc)))) + (t + (values nil nil)))) + +(defun loc-immediate-value (loc) + (nth-value 1 (loc-immediate-value-p loc))) + +(defun unknown-location (where loc) + (baboon :format-control "Unknown location found in ~A~%~S" + :format-arguments (list where loc))) diff --git a/src/cmp/cmpc-machine.lsp b/src/cmp/cmpmach.lsp similarity index 85% rename from src/cmp/cmpc-machine.lsp rename to src/cmp/cmpmach.lsp index eff6d6fb2..1ccb8c698 100644 --- a/src/cmp/cmpc-machine.lsp +++ b/src/cmp/cmpmach.lsp @@ -1,20 +1,65 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański ;;;; -;;;; 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 file '../Copyright' for full details. -;;;; -;;;; CMPC-MACHINE -- Abstract target machine details -;;;; +;;;; See file 'LICENSE' for the copyright details. + +(in-package #:compiler) + +;;; Abstract target machine details + +(defstruct machine + (c-types '()) + rep-type-hash + 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) + (lisp-type t) + (bits nil) + (numberp nil) + (integerp nil) + (c-name nil) + (to-lisp nil) + (from-lisp nil) + (from-lisp-unsafe nil)) + +(defun lisp-type-p (type) + (subtypep type 'T)) + +(defun rep-type-record-unsafe (rep-type) + (gethash rep-type (machine-rep-type-hash *machine*))) + +(defun rep-type-record (rep-type) + (ext:if-let ((record (gethash rep-type (machine-rep-type-hash *machine*)))) + record + (cmperr "Not a valid C type name ~A" rep-type))) + +(defun rep-type->lisp-type (name) + (let ((output (rep-type-record-unsafe name))) + (cond (output + (rep-type-lisp-type output)) + ((lisp-type-p name) name) + (t (error "Unknown representation type ~S" name))))) -(in-package "COMPILER") +(defun lisp-type->rep-type (type) + (cond + ;; We expect type = NIL when we have no information. Should be fixed. FIXME! + ((null type) + :object) + ((let ((r (rep-type-record-unsafe type))) + (and r (rep-type-name r)))) + (t + ;; Find the most specific type that fits + (dolist (record (machine-sorted-types *machine*) :object) + (when (subtypep type (rep-type-lisp-type record)) + (return-from lisp-type->rep-type (rep-type-name record))))))) ;; These types can be used by ECL to unbox data They are sorted from ;; the most specific, to the least specific one. All functions must diff --git a/src/cmp/cmppass2-call.lsp b/src/cmp/cmppass2-call.lsp index 6b98066a9..34b4cd8a4 100644 --- a/src/cmp/cmppass2-call.lsp +++ b/src/cmp/cmppass2-call.lsp @@ -78,6 +78,11 @@ ((or (consp ue) (eq ue 'JUMP) (eq ue 'IHS-ENV))) (t (baboon :format-control "tail-recursion-possible: unexpected situation."))))) +(defun last-call-p () + (member *exit* + '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SINGLE-FLOAT + RETURN-DOUBLE-FLOAT RETURN-LONG-FLOAT RETURN-OBJECT))) + (defun c2try-tail-recursive-call (fun args) (when (and *tail-recursion-info* (eq fun (first *tail-recursion-info*)) diff --git a/src/cmp/cmppass2-data.lsp b/src/cmp/cmppass2-data.lsp index 776b9dd01..4d518a1b2 100644 --- a/src/cmp/cmppass2-data.lsp +++ b/src/cmp/cmppass2-data.lsp @@ -252,8 +252,3 @@ (setf (vv-used-p vv-loc) t) (set-vv-index loc (vv-location vv-loc) (vv-permanent-p vv-loc))) -(defun vv-type (loc) - (let ((value (vv-value loc))) - (if (and value (not (ext:fixnump value))) - (type-of value) - t))) diff --git a/src/cmp/cmppass2-exit.lsp b/src/cmp/cmppass2-exit.lsp index ebb06ad29..5217d377b 100644 --- a/src/cmp/cmppass2-exit.lsp +++ b/src/cmp/cmppass2-exit.lsp @@ -89,8 +89,8 @@ (set-loc loc)) ;; Save the value if LOC may possibly refer ;; to special binding. - ((or (loc-refers-to-special loc) - (loc-refers-to-special *destination*)) + ((or (loc-refers-to-special-p loc) + (loc-refers-to-special-p *destination*)) (let* ((*temp* *temp*) (temp (make-temp-var))) (let ((*destination* temp)) diff --git a/src/cmp/cmppass2-ffi.lsp b/src/cmp/cmppass2-ffi.lsp index bb21e2f54..bc36c7140 100644 --- a/src/cmp/cmppass2-ffi.lsp +++ b/src/cmp/cmppass2-ffi.lsp @@ -15,38 +15,6 @@ (in-package "COMPILER") -;; ---------------------------------------------------------------------- -;; REPRESENTATION TYPES -;; - -(defun rep-type-record-unsafe (rep-type) - (gethash rep-type (machine-rep-type-hash *machine*))) - -(defun rep-type-record (rep-type) - (ext:if-let ((record (gethash rep-type (machine-rep-type-hash *machine*)))) - record - (cmperr "Not a valid C type name ~A" rep-type))) - -(defun rep-type->lisp-type (name) - (let ((output (rep-type-record-unsafe name))) - (cond (output - (rep-type-lisp-type output)) - ((lisp-type-p name) name) - (t (error "Unknown representation type ~S" name))))) - -(defun lisp-type->rep-type (type) - (cond - ;; We expect type = NIL when we have no information. Should be fixed. FIXME! - ((null type) - :object) - ((let ((r (rep-type-record-unsafe type))) - (and r (rep-type-name r)))) - (t - ;; Find the most specific type that fits - (dolist (record (machine-sorted-types *machine*) :object) - (when (subtypep type (rep-type-lisp-type record)) - (return-from lisp-type->rep-type (rep-type-name record))))))) - (defun c-number-rep-type-p (rep-type) (let ((r (rep-type-record-unsafe rep-type))) (and r (rep-type-numberp r)))) @@ -71,9 +39,6 @@ (defun rep-type->c-name (type) (rep-type-c-name (rep-type-record type))) -(defun lisp-type-p (type) - (subtypep type 'T)) - (defun wt-to-object-conversion (loc-rep-type loc) (when (and (consp loc) (member (first loc) '(single-float-value @@ -100,75 +65,6 @@ coercer) "(" loc ")"))) -;; ---------------------------------------------------------------------- -;; LOCATIONS and representation types -;; -;; Locations are lisp expressions which represent actual C data. To each -;; location we can associate a representation type, which is the type of -;; the C data. The following routines help in determining these types, -;; and also in moving data from one location to another. - -(defun loc-movable-p (loc) - (if (atom loc) - t - (case (first loc) - ((CALL CALL-LOCAL) NIL) - ((ffi:c-inline) (not (fifth loc))) ; side effects? - (otherwise t)))) - -(defun loc-type (loc) - (cond ((eq loc NIL) 'NULL) - ((var-p loc) (var-type loc)) - ((vv-p loc) (vv-type loc)) - ((numberp loc) (lisp-type->rep-type (type-of loc))) - ((atom loc) 'T) - (t - (case (first loc) - (FIXNUM-VALUE 'FIXNUM) - (CHARACTER-VALUE (type-of (code-char (second loc)))) - (DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT) - (SINGLE-FLOAT-VALUE 'SINGLE-FLOAT) - (LONG-FLOAT-VALUE 'LONG-FLOAT) - (CSFLOAT-VALUE 'SI:COMPLEX-SINGLE-FLOAT) - (CDFLOAT-VALUE 'SI:COMPLEX-DOUBLE-FLOAT) - (CLFLOAT-VALUE 'SI:COMPLEX-LONG-FLOAT) - (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)) - (CALL-NORMAL (fourth loc)) - (otherwise T))))) - -(defun loc-representation-type (loc) - (cond ((member loc '(NIL T)) :object) - ((var-p loc) (var-rep-type loc)) - ((vv-p loc) :object) - ((numberp loc) (lisp-type->rep-type (type-of loc))) - ((eq loc 'TRASH) :void) - ((atom loc) :object) - (t - (case (first loc) - (FIXNUM-VALUE :fixnum) - (CHARACTER-VALUE (if (<= (second loc) 255) :unsigned-char :wchar)) - (DOUBLE-FLOAT-VALUE :double) - (SINGLE-FLOAT-VALUE :float) - (LONG-FLOAT-VALUE :long-double) - (CSFLOAT-VALUE :csfloat) - (CDFLOAT-VALUE :cdfloat) - (CLFLOAT-VALUE :clfloat) - (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) - (THE (loc-representation-type (third loc))) - (otherwise :object))))) - (defun wt-coerce-loc (dest-rep-type loc) (setq dest-rep-type (lisp-type->rep-type dest-rep-type)) ;(print dest-rep-type) diff --git a/src/cmp/cmppass2-loc.lsp b/src/cmp/cmppass2-loc.lsp index 2f6d134f1..14525bc63 100644 --- a/src/cmp/cmppass2-loc.lsp +++ b/src/cmp/cmppass2-loc.lsp @@ -16,133 +16,6 @@ (in-package "COMPILER") -;;; Valid locations are: -;;; NIL -;;; T -;;; fixnum -;;; VALUE0 -;;; VALUES -;;; var-object -;;; a string designating a C expression -;;; ( VALUE i ) VALUES(i) -;;; ( VV vv-index ) -;;; ( VV-temp vv-index ) -;;; ( LCL lcl [representation-type]) local variable, type unboxed -;;; ( TEMP temp ) local variable, type object -;;; ( 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 -;;; ( FFI:C-INLINE output-type fun/string locs side-effects output-var ) -;;; ( COERCE-LOC representation-type location) -;;; ( FDEFINITION vv-index ) -;;; ( MAKE-CCLOSURE cfun ) -;;; ( FIXNUM-VALUE fixnum-value ) -;;; ( CHARACTER-VALUE character-code ) -;;; ( LONG-FLOAT-VALUE long-float-value vv ) -;;; ( DOUBLE-FLOAT-VALUE double-float-value vv ) -;;; ( SINGLE-FLOAT-VALUE single-float-value vv ) -;;; ( CSFLOAT-VALUE csfloat-value vv ) -;;; ( CDFLOAT-VALUE cdfloat-value vv ) -;;; ( CLFLOAT-VALUE clfloat-value vv ) -;;; ( STACK-POINTER index ) retrieve a value from the stack -;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) -;;; ( THE type location ) -;;; ( KEYVARS n ) -;;; VA-ARG -;;; CL-VA-ARG - -;;; Valid *DESTINATION* locations are: -;;; -;;; VALUE0 -;;; RETURN Object returned from current function. -;;; TRASH Value may be thrown away. -;;; VALUES Values vector. -;;; var-object -;;; ( LCL lcl ) -;;; ( LEX lex-address ) -;;; ( BIND var alternative ) Alternative is optional -;;; ( JUMP-TRUE label ) -;;; ( JUMP-FALSE label ) - -(defun tmp-destination (loc) - (case loc - (VALUES 'VALUES) - (TRASH 'TRASH) - (T 'RETURN))) - -(defun precise-loc-type (loc new-type) - (if (subtypep (loc-type loc) new-type) - loc - `(the ,new-type ,loc))) - -(defun loc-in-c1form-movable-p (loc) - "A location that is in a C1FORM and can be moved" - (cond ((member loc '(t nil)) - t) - ((numberp loc) - t) - ((stringp loc) - t) - ((vv-p loc) - t) - ((member loc '(value0 values va-arg cl-va-arg)) - nil) - ((atom loc) - (baboon :format-control "Unknown location ~A found in C1FORM" - :format-arguments (list loc))) - ((eq (first loc) 'THE) - (loc-in-c1form-movable-p (third loc))) - ((member (setf loc (car loc)) - '(VV VV-TEMP FIXNUM-VALUE CHARACTER-VALUE - DOUBLE-FLOAT-VALUE SINGLE-FLOAT-VALUE LONG-FLOAT-VALUE - #+complex-float CSFLOAT-VALUE - #+complex-float CDFLOAT-VALUE - #+complex-float CLFLOAT-VALUE - KEYVARS)) - t) - (t - (baboon :format-control "Unknown location ~A found in C1FORM" - :format-arguments (list loc))))) - -(defun uses-values (loc) - (and (consp loc) - (or (member (car loc) '(CALL CALL-NORMAL CALL-INDIRECT) :test #'eq) - (and (eq (car loc) 'ffi:C-INLINE) - (eq (sixth loc) 'cl:VALUES))))) - -(defun loc-immediate-value-p (loc) - (cond ((eq loc t) - (values t t)) - ((eq loc nil) - (values t nil)) - ((numberp loc) - (values t loc)) - ((vv-p loc) - (let ((value (vv-value loc))) - (if (or (null value) (ext:fixnump value)) - (values nil nil) - (values t value)))) - ((atom loc) - (values nil nil)) - ((eq (first loc) 'THE) - (loc-immediate-value-p (third loc))) - ((member (first loc) - '(fixnum-value long-float-value - double-float-value single-float-value - csfloat-value cdfloat-value clfloat-value)) - (values t (second loc))) - ((eq (first loc) 'character-value) - (values t (code-char (second loc)))) - (t - (values nil nil)))) - -(defun loc-immediate-value (loc) - (nth-value 1 (loc-immediate-value-p loc))) - -(defun unknown-location (where loc) - (baboon :format-control "Unknown location found in ~A~%~S" - :format-arguments (list where loc))) - (defun wt-loc (loc) (cond ((consp loc) (let ((fd (gethash (car loc) *wt-loc-dispatch-table*))) @@ -163,11 +36,6 @@ (t (unknown-location 'wt-loc loc)))) -(defun last-call-p () - (member *exit* - '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SINGLE-FLOAT - RETURN-DOUBLE-FLOAT RETURN-LONG-FLOAT RETURN-OBJECT))) - (defun wt-lcl (lcl) (unless (numberp lcl) (baboon :format-control "wt-lcl: ~s NaN" :format-arguments (list lcl))) @@ -219,22 +87,6 @@ (declare (ignore type)) (wt-loc loc)) -(defun loc-refers-to-special (loc) - (cond ((var-p loc) - (member (var-kind loc) '(SPECIAL GLOBAL))) - ((atom loc) - nil) - ((eq (first loc) 'THE) - (loc-refers-to-special (third loc))) - ((eq (setf loc (first loc)) 'BIND) - t) - ((eq loc 'ffi:C-INLINE) - t) ; We do not know, so guess yes - (t nil))) - -(defun values-loc (n) - (list 'VALUE n)) - ;;; ;;; SET-LOC ;;; @@ -292,23 +144,6 @@ (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";") (wt-nl "cl_env_copy->nvalues = 1;")))) -(defun loc-with-side-effects-p (loc &aux name) - (cond ((var-p loc) - (and (global-var-p loc) - (policy-global-var-checking))) - ((atom loc) - nil) - ((member (setf name (first loc)) '(CALL CALL-NORMAL CALL-INDIRECT) - :test #'eq) - t) - ((eq name 'cl:THE) - (loc-with-side-effects-p (third loc))) - ((eq name 'cl:FDEFINITION) - (policy-global-function-checking)) - ((eq name 'ffi:C-INLINE) - (or (eq (sixth loc) 'cl:VALUES) ;; Uses VALUES - (fifth loc))))) ;; or side effects - (defun set-trash-loc (loc) (when (loc-with-side-effects-p loc) (wt-nl loc ";") diff --git a/src/cmp/cmppass2-var.lsp b/src/cmp/cmppass2-var.lsp index 67416d224..ae1ec2e09 100644 --- a/src/cmp/cmppass2-var.lsp +++ b/src/cmp/cmppass2-var.lsp @@ -282,7 +282,9 @@ (defun values-loc-or-value0 (i) (declare (si::c-local)) - (if (plusp i) (values-loc i) 'VALUE0)) + (if (plusp i) + (list 'VALUE i) + 'VALUE0)) (defun do-m-v-setq (vars form use-bind) ;; This routine moves values from the multiple-value stack into the diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp index f225dc046..ba3e1d742 100644 --- a/src/cmp/cmptypes.lsp +++ b/src/cmp/cmptypes.lsp @@ -210,27 +210,3 @@ (toplevel-form nil) (file nil) (file-position 0)) - -(defstruct vv - (location nil) - (used-p nil) - (permanent-p t) - (value nil)) - -(defstruct machine - (c-types '()) - rep-type-hash - sorted-types - inline-information) - -(defstruct (rep-type (:constructor %make-rep-type)) - (index 0) ; Precedence order in the type list - (name t) - (lisp-type t) - (bits nil) - (numberp nil) - (integerp nil) - (c-name nil) - (to-lisp nil) - (from-lisp nil) - (from-lisp-unsafe nil)) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index a65775c75..8360567bb 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -7,6 +7,9 @@ "build:cmp;cmpdefs.lsp" "src:cmp;cmputil.lsp" "src:cmp;cmpcond.lsp" + ;; Internal representation + "src:cmp;cmpmach.lsp" + "src:cmp;cmplocs.lsp" ;; Environment "src:cmp;cmpenv-api.lsp" "src:cmp;cmpenv-var.lsp" @@ -28,7 +31,6 @@ "src:cmp;cmptype.lsp" "src:cmp;cmptype-assert.lsp" ;; Abstract C machine - "src:cmp;cmpc-machine.lsp" "src:cmp;cmpc-wt.lsp" "src:cmp;cmpc-inliner.lsp" ;; AST building pass -- GitLab From b4eeff082d46916696d1e43cf20d660e52851134 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 17 Feb 2023 16:20:40 +0100 Subject: [PATCH 26/33] cmp: move refs to a separate file cmprefs Also load cmptype-arith.lsp much sooner than before. --- src/cmp/cmpform.lsp | 6 -- src/cmp/cmprefs.lsp | 180 ++++++++++++++++++++++++++++++++++++++ src/cmp/cmptypes.lsp | 200 ++++++------------------------------------- src/cmp/cmputil.lsp | 20 ----- src/cmp/load.lsp.in | 3 +- 5 files changed, 208 insertions(+), 201 deletions(-) create mode 100644 src/cmp/cmprefs.lsp diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index d4800579e..e299f116c 100644 --- a/src/cmp/cmpform.lsp +++ b/src/cmp/cmpform.lsp @@ -26,9 +26,6 @@ ;;; lambda-list = (requireds optionals rest key-flag keywords allow-other-keys) ;;; -(defun print-c1form (form stream) - (format stream "#
" (c1form-name form) (si:pointer form))) - (defun make-c1form (name subform &rest args) (let ((form (do-make-c1form :name name :args args :type (info-type subform) @@ -100,9 +97,6 @@ (error "Internal error: illegal number of arguments in ~A" form)))) (c1form-add-info-loop form dependents)) -(defun copy-c1form (form) - (copy-structure form)) - (defmacro c1form-arg (nth form) (case nth (0 `(first (c1form-args ,form))) diff --git a/src/cmp/cmprefs.lsp b/src/cmp/cmprefs.lsp new file mode 100644 index 000000000..008261956 --- /dev/null +++ b/src/cmp/cmprefs.lsp @@ -0,0 +1,180 @@ + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański +;;;; +;;;; See file 'LICENSE' for the copyright details. + +(in-package #:compiler) + +;;; +;;; REF OBJECT +;;; +;;; Base object for functions, variables and statements. We use it to +;;; keep track of references to objects, how many times the object is +;;; referenced, by whom, and whether the references cross some closure +;;; boundaries. +;;; + +(defstruct (ref (:print-object print-ref)) + name ;; Identifier of reference. + (ref 0 :type fixnum) ;; Number of references. + ref-ccb ;; Cross closure reference: T or NIL. + ref-clb ;; Cross local function reference: T or NIL. + read-nodes ;; Nodes (c1forms) in which the reference occurs. + ) + +(defun print-ref (ref-object stream) + (ext:if-let ((name (ref-name ref-object))) + (format stream "#" (type-of ref-object) name) + (format stream "#" (type-of ref-object)))) + +(deftype OBJECT () `(not (or fixnum character float))) + +(defstruct (var (:include ref) (:constructor %make-var) (:print-object print-var)) +#| + name ;;; Variable name. + (ref 0 :type fixnum) ;;; Number of references to the variable (-1 means IGNORE). + ref-ccb ;;; Cross closure reference: T or NIL. + ref-clb ;;; Cross local function reference: T or NIL. + read-nodes ;;; Nodes (c1forms) in which the reference occurs +|# + set-nodes ;;; Nodes in which the variable is modified + kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, + ;;; or some C representation type (:FIXNUM, :CHAR, etc) + (function *current-function*) + ;;; For local variables, in which function it was created. + ;;; For global variables, it doesn't have a meaning. + (functions-setting nil) + (functions-reading nil) + ;;; Functions in which the variable has been modified or read. + (loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can + ;;; be allocated on the c-stack: OBJECT means + ;;; the variable is declared as OBJECT, and CLB means + ;;; the variable is referenced across Level Boundary and thus + ;;; cannot be allocated on the C stack. Note that OBJECT is + ;;; set during variable binding and CLB is set when the + ;;; variable is used later, and therefore CLB may supersede + ;;; OBJECT. + ;;; During Pass 2: + ;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT: + ;;; the cvar for the C variable that holds the value. + ;;; For LEXICAL or CLOSURE: the frame-relative address for + ;;; the variable in the form of a cons '(lex-levl . lex-ndx) + ;;; lex-levl is the level of lexical environment + ;;; lex-ndx is the index within the array for this env. + ;;; For SPECIAL and GLOBAL: the vv-index for variable name. + (type t) ;;; Type of the variable. + (ignorable nil) ;;; Whether there was an IGNORABLE/IGNORE declaration + ) + +(defun print-var (var-object stream) + (format stream "#" (var-name var-object) (var-kind var-object))) + +;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE +;;; Here are examples of function FOO for the 3 cases: +;;; 1. (flet ((foo () (bar))) (foo)) CFUN +;;; 2. (flet ((foo () (bar))) #'foo) CFUN+LISP_CFUN +;;; 3. (flet ((foo () x)) #'(lambda () (foo))) CCLOSURE +;;; 4. (flet ((foo () x)) #'foo) CCLOSURE+LISP_CLOSURE + +;;; A function can be referenced across a ccb without being a closure, e.g: +;;; (flet ((foo () (bar))) #'(lambda () (foo))) +;;; [the lambda also need not be a closure] +;;; and it can be a closure without being referenced across ccb, e.g.: +;;; (flet ((foo () x)) #'foo) [ is this a mistake in local-function-ref?] +;;; Here instead the lambda must be a closure, but no closure is needed for foo +;;; (flet ((foo () x)) #'(lambda () (foo))) +;;; So we use two separate fields: ref-ccb and closure. +;;; A CCLOSURE must be created for a function when: +;;; 1. it appears within a FUNCTION construct and +;;; 2. it uses some ccb references (directly or indirectly). +;;; ref-ccb corresponds to the first condition, i.e. function is referenced +;;; across CCB. It is computed during Pass 1. A value of 'RETURNED means +;;; that it is immediately within FUNCTION. +;;; closure corresponds to second condition and is computed in Pass 2 by +;;; looking at the info-referenced-vars and info-local-referenced of its body. + +;;; A LISP_CFUN or LISP_CLOSURE must be created when the function is returned. +;;; The LISP funob may then be referenced locally or across a function boundary: +;;; (flet ((foo (z) (bar z))) (list #'foo))) +;;; (flet ((foo (z) z)) (flet ((bar () #'foo)) (bar))) +;;; (flet ((foo (z) (bar z))) #'(lambda () #'foo))) +;;; therefore we need field funob. + +(defstruct (fun (:include ref)) +#| + name ;;; Function name. + (ref 0 :type fixnum) ;;; Number of references. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the vs-address for the + ;;; function closure, or NIL. + ref-ccb ;;; Cross closure reference: T or NIL. + ref-clb ;;; Unused. + read-nodes ;;; Nodes (c1forms) in which the reference occurs. +|# + cfun ;;; The cfun for the function. + (level 0) ;;; Level of lexical nesting for a function. + (env 0) ;;; Size of env of closure. + (global nil) ;;; Global lisp function. + (exported nil) ;;; Its C name can be seen outside the module. + (no-entry nil) ;;; NIL if declared as C-LOCAL. Then we create no + ;;; function object and the C function is called + ;;; directly + (shares-with nil) ;;; T if this function shares the C code with another one. + ;;; In that case we need not emit this one. + closure ;;; During Pass2, T if env is used inside the function + var ;;; the variable holding the funob + description ;;; Text for the object, in case NAME == NIL. + lambda ;;; Lambda c1-form for this function. + lambda-expression ;;; LAMBDA or LAMBDA-BLOCK expression + (minarg 0) ;;; Min. number arguments that the function receives. + (maxarg call-arguments-limit) + ;;; Max. number arguments that the function receives. + (return-type '(VALUES &REST T)) + (parent *current-function*) + ;;; Parent function, NIL if global. + (local-vars nil) ;;; List of local variables created here. + (referenced-vars nil) ;;; List of external variables referenced here. + (referenced-funs nil) ;;; List of external functions called in this one. + ;;; We only register direct calls, not calls via object. + (referencing-funs nil);;; Functions that reference this one + (child-funs nil) ;;; List of local functions defined here. + (file (car ext:*source-location*)) + ;;; Source file or NIL + (file-position (or (cdr ext:*source-location*) *compile-file-position*)) + ;;; Top-level form number in source file + (cmp-env (cmp-env-copy)) ;;; Environment + required-lcls ;;; Names of the function arguments + (optional-type-check-forms nil) ;;; Type check forms for optional arguments + (keyword-type-check-forms nil) ;;; Type check forms for keyword arguments + ) + +(defstruct (blk (:include ref)) +#| + name ;;; Block name. + (ref 0 :type fixnum) ;;; Total number of block references. + ref-ccb ;;; Unused (see blk-var). + ref-clb ;;; Unused (see blk-var). + read-nodes ;;; Unused (see blk-var). +|# + exit ;;; Where to return. A label. + destination ;;; Where the value of the block to go. + var ;;; Variable containing the block id and its references. + (type '(VALUES &REST T)) ;;; Estimated type. + ) + +(defstruct (tag (:include ref)) +#| + name ;;; Tag name. + (ref 0 :type fixnum) ;;; Number of references. + ref-ccb ;;; Unused (see tag-var). + ref-clb ;;; Unused (see tag-var). + read-nodes ;;; Unused (see tag-var). +|# + label ;;; Where to jump: a label. + unwind-exit ;;; Where to unwind-no-exit. + var ;;; Variable containing frame ID. + index ;;; An integer denoting the label. + ) diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp index ba3e1d742..053bc99c7 100644 --- a/src/cmp/cmptypes.lsp +++ b/src/cmp/cmptypes.lsp @@ -16,167 +16,6 @@ (in-package "COMPILER") -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; COMPILER STRUCTURES -;;; - -;;; -;;; REF OBJECT -;;; -;;; Base object for functions, variables and statements. We use it to -;;; keep track of references to objects, how many times the object is -;;; referenced, by whom, and whether the references cross some closure -;;; boundaries. -;;; - -(defstruct (ref (:print-object print-ref)) - name ;;; Identifier of reference. - (ref 0 :type fixnum) ;;; Number of references. - ref-ccb ;;; Cross closure reference: T or NIL. - ref-clb ;;; Cross local function reference: T or NIL. - read-nodes ;;; Nodes (c1forms) in which the reference occurs. -) - -(deftype OBJECT () `(not (or fixnum character float))) - -(defstruct (var (:include ref) (:constructor %make-var) (:print-object print-var)) -; name ;;; Variable name. -; (ref 0 :type fixnum) - ;;; Number of references to the variable (-1 means IGNORE). -; ref-ccb ;;; Cross closure reference: T or NIL. -; ref-clb ;;; Cross local function reference: T or NIL. -; read-nodes ;;; Nodes (c1forms) in which the reference occurs - set-nodes ;;; Nodes in which the variable is modified - kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, - ;;; or some C representation type (:FIXNUM, :CHAR, etc) - (function *current-function*) - ;;; For local variables, in which function it was created. - ;;; For global variables, it doesn't have a meaning. - (functions-setting nil) - (functions-reading nil) - ;;; Functions in which the variable has been modified or read. - (loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can - ;;; be allocated on the c-stack: OBJECT means - ;;; the variable is declared as OBJECT, and CLB means - ;;; the variable is referenced across Level Boundary and thus - ;;; cannot be allocated on the C stack. Note that OBJECT is - ;;; set during variable binding and CLB is set when the - ;;; variable is used later, and therefore CLB may supersede - ;;; OBJECT. - ;;; During Pass 2: - ;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT: - ;;; the cvar for the C variable that holds the value. - ;;; For LEXICAL or CLOSURE: the frame-relative address for - ;;; the variable in the form of a cons '(lex-levl . lex-ndx) - ;;; lex-levl is the level of lexical environment - ;;; lex-ndx is the index within the array for this env. - ;;; For SPECIAL and GLOBAL: the vv-index for variable name. - (type t) ;;; Type of the variable. - (ignorable nil) ;;; Whether there was an IGNORABLE/IGNORE declaration - ) - -;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE -;;; Here are examples of function FOO for the 3 cases: -;;; 1. (flet ((foo () (bar))) (foo)) CFUN -;;; 2. (flet ((foo () (bar))) #'foo) CFUN+LISP_CFUN -;;; 3. (flet ((foo () x)) #'(lambda () (foo))) CCLOSURE -;;; 4. (flet ((foo () x)) #'foo) CCLOSURE+LISP_CLOSURE - -;;; A function can be referenced across a ccb without being a closure, e.g: -;;; (flet ((foo () (bar))) #'(lambda () (foo))) -;;; [the lambda also need not be a closure] -;;; and it can be a closure without being referenced across ccb, e.g.: -;;; (flet ((foo () x)) #'foo) [ is this a mistake in local-function-ref?] -;;; Here instead the lambda must be a closure, but no closure is needed for foo -;;; (flet ((foo () x)) #'(lambda () (foo))) -;;; So we use two separate fields: ref-ccb and closure. -;;; A CCLOSURE must be created for a function when: -;;; 1. it appears within a FUNCTION construct and -;;; 2. it uses some ccb references (directly or indirectly). -;;; ref-ccb corresponds to the first condition, i.e. function is referenced -;;; across CCB. It is computed during Pass 1. A value of 'RETURNED means -;;; that it is immediately within FUNCTION. -;;; closure corresponds to second condition and is computed in Pass 2 by -;;; looking at the info-referenced-vars and info-local-referenced of its body. - -;;; A LISP_CFUN or LISP_CLOSURE must be created when the function is returned. -;;; The LISP funob may then be referenced locally or across a function boundary: -;;; (flet ((foo (z) (bar z))) (list #'foo))) -;;; (flet ((foo (z) z)) (flet ((bar () #'foo)) (bar))) -;;; (flet ((foo (z) (bar z))) #'(lambda () #'foo))) -;;; therefore we need field funob. - -(defstruct (fun (:include ref)) -; name ;;; Function name. -; (ref 0 :type fixnum) ;;; Number of references. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the vs-address for the - ;;; function closure, or NIL. -; ref-ccb ;;; Cross closure reference: T or NIL. -; ref-clb ;;; Unused. -; read-nodes ;;; Nodes (c1forms) in which the reference occurs. - cfun ;;; The cfun for the function. - (level 0) ;;; Level of lexical nesting for a function. - (env 0) ;;; Size of env of closure. - (global nil) ;;; Global lisp function. - (exported nil) ;;; Its C name can be seen outside the module. - (no-entry nil) ;;; NIL if declared as C-LOCAL. Then we create no - ;;; function object and the C function is called - ;;; directly - (shares-with nil) ;;; T if this function shares the C code with another one. - ;;; In that case we need not emit this one. - closure ;;; During Pass2, T if env is used inside the function - var ;;; the variable holding the funob - description ;;; Text for the object, in case NAME == NIL. - lambda ;;; Lambda c1-form for this function. - lambda-expression ;;; LAMBDA or LAMBDA-BLOCK expression - (minarg 0) ;;; Min. number arguments that the function receives. - (maxarg call-arguments-limit) - ;;; Max. number arguments that the function receives. - (return-type '(VALUES &REST T)) - (parent *current-function*) - ;;; Parent function, NIL if global. - (local-vars nil) ;;; List of local variables created here. - (referenced-vars nil) ;;; List of external variables referenced here. - (referenced-funs nil) ;;; List of external functions called in this one. - ;;; We only register direct calls, not calls via object. - (referencing-funs nil);;; Functions that reference this one - (child-funs nil) ;;; List of local functions defined here. - (file (car ext:*source-location*)) - ;;; Source file or NIL - (file-position (or (cdr ext:*source-location*) *compile-file-position*)) - ;;; Top-level form number in source file - (cmp-env (cmp-env-copy)) ;;; Environment - required-lcls ;;; Names of the function arguments - (optional-type-check-forms nil) ;;; Type check forms for optional arguments - (keyword-type-check-forms nil) ;;; Type check forms for keyword arguments - ) - -(defstruct (blk (:include ref)) -; name ;;; Block name. -; (ref 0 :type fixnum) ;;; Total number of block references. -; ref-ccb ;;; Unused (see blk-var). -; ref-clb ;;; Unused (see blk-var). -; read-nodes ;;; Unused (see blk-var). - exit ;;; Where to return. A label. - destination ;;; Where the value of the block to go. - var ;;; Variable containing the block id and its references. - (type '(VALUES &REST T)) ;;; Estimated type. - ) - -(defstruct (tag (:include ref)) -; name ;;; Tag name. -; (ref 0 :type fixnum) ;;; Number of references. -; ref-ccb ;;; Unused (see tag-var). -; ref-clb ;;; Unused (see tag-var). -; read-nodes ;;; Unused (see tag-var). - label ;;; Where to jump: a label. - unwind-exit ;;; Where to unwind-no-exit. - var ;;; Variable containing frame ID. - index ;;; An integer denoting the label. - ) - (defstruct (info) (local-vars nil) ;;; List of var-objects created directly in the form. (type '(VALUES &REST T)) ;;; Type of the form. @@ -185,19 +24,6 @@ (volatile nil) ;;; whether there is a possible setjmp. Beppe ) -(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 -) - (defstruct (c1form (:include info) (:print-object print-c1form) (:constructor do-make-c1form)) @@ -210,3 +36,29 @@ (toplevel-form nil) (file nil) (file-position 0)) + +(defun print-c1form (form stream) + (format stream "#" (c1form-name form) (si:pointer form))) + +(defvar *c1form-level* 0) +(defun print-c1forms (form) + (cond ((consp form) + (let ((*c1form-level* (1+ *c1form-level*))) + (mapc #'print-c1forms form))) + ((c1form-p form) + (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 +) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 47a3aa976..97ce7b1cb 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -80,26 +80,6 @@ (abort ())) (setf ,compiler-conditions *compiler-conditions*))) -(defvar *c1form-level* 0) -(defun print-c1forms (form) - (cond ((consp form) - (let ((*c1form-level* (1+ *c1form-level*))) - (mapc #'print-c1forms form))) - ((c1form-p form) - (format t "~% ~D > ~A, parent ~A" *c1form-level* form (c1form-parent form)) - (print-c1forms (c1form-args form)) - form - ))) - -(defun print-ref (ref-object stream) - (let ((name (ref-name ref-object))) - (if name - (format stream "#" (type-of ref-object) name) - (format stream "#" (type-of ref-object))))) - -(defun print-var (var-object stream) - (format stream "#" (var-name var-object) (var-kind var-object))) - (defun safe-list-length (l) ;; Computes the length of a proper list or returns NIL if it ;; is a circular list or terminates with a non-NIL atom. diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 8360567bb..2d2d54416 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -7,8 +7,10 @@ "build:cmp;cmpdefs.lsp" "src:cmp;cmputil.lsp" "src:cmp;cmpcond.lsp" + "src:cmp;cmptype-arith.lsp" ;; Internal representation "src:cmp;cmpmach.lsp" + "src:cmp;cmprefs.lsp" "src:cmp;cmplocs.lsp" ;; Environment "src:cmp;cmpenv-api.lsp" @@ -26,7 +28,6 @@ "src:cmp;cmptables.lsp" "src:cmp;cmpinline.lsp" ;; Types - "src:cmp;cmptype-arith.lsp" "src:cmp;cmptype-prop.lsp" "src:cmp;cmptype.lsp" "src:cmp;cmptype-assert.lsp" -- GitLab From 523460b874485f005b308bbbe6b2da731114d1cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 17 Feb 2023 16:57:50 +0100 Subject: [PATCH 27/33] cmp: cleanup to avoid some forward-references --- src/cmp/cmpenv-api.lsp | 10 +++++++++- src/cmp/cmpform.lsp | 3 ++- src/cmp/cmpopt-type.lsp | 3 ++- src/cmp/cmppass2-top.lsp | 4 +++- src/cmp/cmputil.lsp | 32 ++++++++++++-------------------- src/cmp/cmpvar.lsp | 11 ----------- 6 files changed, 28 insertions(+), 35 deletions(-) diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index bc1fad6b2..8f4aed3fe 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -156,7 +156,15 @@ that are susceptible to be changed by PROCLAIM." (defun cmp-env-search-macro (name &optional (env *cmp-env*)) (let ((f (cmp-env-search-function name env))) - (if (functionp f) f nil))) + (if (functionp f) + f + nil))) + +;;; Like macro-function except it searches the lexical environment, +;;; to determine if the macro is shadowed by a function or a macro. +(defun cmp-macro-function (name) + (or (cmp-env-search-macro name) + (macro-function name))) (defun cmp-env-search-ftype (name &optional (env *cmp-env*)) (dolist (i env nil) diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index e299f116c..e5ede9ad0 100644 --- a/src/cmp/cmpform.lsp +++ b/src/cmp/cmpform.lsp @@ -204,7 +204,8 @@ (baboon :format-control "Attempted to move a form with side-effects")) ;; The following protocol is only valid for VAR references. (unless (eq (c1form-name dest) 'VAR) - (baboon :format-control "Cannot replace forms other than VARs:~%~4I~A" dest)) + (baboon :format-control "Cannot replace forms other than VARs:~%~4I~A" + :format-arguments (list dest))) ;; We have to relocate the children nodes of NEW-FIELDS in ;; the new branch. This implies rewriting the parents chain, ;; but only for non-location nodes (these are reused). The only diff --git a/src/cmp/cmpopt-type.lsp b/src/cmp/cmpopt-type.lsp index ca2904a6a..b81744971 100644 --- a/src/cmp/cmpopt-type.lsp +++ b/src/cmp/cmpopt-type.lsp @@ -32,7 +32,8 @@ ,@declarations) (si::while (< ,variable ,%limit) ,@body - (reckless (setq ,variable (1+ ,variable)))) + (locally (declare (optimize (safety 0))) + (setq ,variable (1+ ,variable)))) ,@output)) (t (let ((,variable 0)) diff --git a/src/cmp/cmppass2-top.lsp b/src/cmp/cmppass2-top.lsp index c724d2200..9af4d6535 100644 --- a/src/cmp/cmppass2-top.lsp +++ b/src/cmp/cmppass2-top.lsp @@ -304,7 +304,9 @@ (declare (type fun fun)) ;; Compiler note about compiling this function - (print-emitting fun) + (when *compile-print* + (ext:when-let ((name (or (fun-name fun) (fun-description fun)))) + (format t "~&;;; Emitting code for ~s.~%" name))) (let* ((lambda-expr (fun-lambda fun)) (*cmp-env* (c1form-env lambda-expr)) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 97ce7b1cb..02d3fc2bd 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -121,12 +121,6 @@ (innermost-non-expanded-form *current-toplevel-form*)))) nil) -(defun print-emitting (f) - (when *compile-print* - (let* ((name (or (fun-name f) (fun-description f)))) - (when name - (format t "~&;;; Emitting code for ~s.~%" name))))) - (defun cmpprogress (&rest args) (when *compile-verbose* (apply #'format t args))) @@ -140,12 +134,6 @@ form c) nil))) -;;; Like macro-function except it searches the lexical environment, -;;; to determine if the macro is shadowed by a function or a macro. -(defun cmp-macro-function (name) - (or (cmp-env-search-macro name) - (macro-function name))) - (defun cmp-expand-macro (fd form &optional (env *cmp-env*)) (handler-case (let ((new-form (funcall *macroexpand-hook* fd form env))) @@ -518,10 +506,6 @@ comparing circular objects." *exit* (next-label))) -(defun maybe-wt-label (label) - (unless (eq label *exit*) - (wt-label label))) - (defmacro with-exit-label ((label) &body body) `(let* ((,label (next-label)) (*unwind-exit* (cons ,label *unwind-exit*))) @@ -532,7 +516,8 @@ comparing circular objects." `(let* ((,label (maybe-next-label)) (*unwind-exit* (adjoin ,label *unwind-exit*))) ,@body - (maybe-wt-label ,label))) + (unless (eq ,label *exit*) + (wt-label ,label)))) (defun next-lcl (&optional name) (list 'LCL (incf *lcl*) T @@ -559,6 +544,13 @@ comparing circular objects." (incf *env*) (setq *max-env* (max *env* *max-env*)))) -(defmacro reckless (&rest body) - `(locally (declare (optimize (safety 0))) - ,@body)) +(defun env-grows (possibily) + ;; if additional closure variables are introduced and this is not + ;; last form, we must use a new env. + (and possibily + (plusp *env*) + (dolist (exit *unwind-exit*) + (case exit + (RETURN (return NIL)) + (BDS-BIND) + (t (return T)))))) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index fd049e4f3..40ca8d8de 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -14,17 +14,6 @@ (in-package #:compiler) -(defun env-grows (possibily) - ;; if additional closure variables are introduced and this is not - ;; last form, we must use a new env. - (and possibily - (plusp *env*) - (dolist (exit *unwind-exit*) - (case exit - (RETURN (return NIL)) - (BDS-BIND) - (t (return T)))))) - ;; should check whether a form before var causes a side-effect ;; exactly one occurrence of var is present in forms (defun replaceable (var form) -- GitLab From 621720b4577a9de1cd839ed831de235e103c0dda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2023 13:24:54 +0100 Subject: [PATCH 28/33] cmp: separate policy definition and environment OPTIMIZE accessors --- src/cmp/cmpenv-optimize.lsp | 56 +++++++++++++++++++++++++++++++++++++ src/cmp/cmppolicy.lsp | 47 ------------------------------- src/cmp/load.lsp.in | 3 +- 3 files changed, 58 insertions(+), 48 deletions(-) create mode 100644 src/cmp/cmpenv-optimize.lsp diff --git a/src/cmp/cmpenv-optimize.lsp b/src/cmp/cmpenv-optimize.lsp new file mode 100644 index 000000000..c7ea02d05 --- /dev/null +++ b/src/cmp/cmpenv-optimize.lsp @@ -0,0 +1,56 @@ + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański +;;;; +;;;; See file 'LICENSE' for the copyright details. + +(in-package #:compiler) + +(defun default-policy () + (compute-policy `((space ,*space*) + (safety ,*safety*) + (debug ,*debug*) + (speed ,*speed*)) + 0)) + +(defun add-default-optimizations (env) + (if (cmp-env-search-declaration 'optimization env) + env + (cmp-env-add-declaration 'optimization (list (default-policy)) env))) + +(defun cmp-env-add-optimizations (decl &optional (env *cmp-env*)) + (let* ((old (cmp-env-policy env)) + (new (compute-policy decl old))) + (cmp-env-add-declaration 'optimization (list new) env))) + +(defun maybe-add-policy (decl &optional (env *cmp-env*)) + (when (and (consp decl) + (<= (list-length decl) 2) + (gethash (first decl) *optimization-quality-switches*)) + (let* ((old (cmp-env-policy env)) + (flag (if (or (endp (rest decl)) (second decl)) 3 0)) + (new (compute-policy (list (list (first decl) flag)) old))) + (cmp-env-add-declaration 'optimization (list new) env)))) + +(defun cmp-env-all-optimizations (&optional (env *cmp-env*)) + (let ((o (cmp-env-policy env))) + (list (policy-to-debug-level o) + (policy-to-safety-level o) + (policy-to-space-level o) + (policy-to-speed-level o)))) + +(defun cmp-env-optimization (property &optional (env *cmp-env*)) + (let ((o (cmp-env-policy env))) + (case property + (debug (policy-to-debug-level o)) + (safety (policy-to-safety-level o)) + (space (policy-to-space-level o)) + (speed (policy-to-speed-level o))))) + +(defun safe-compile () + (>= (cmp-env-optimization 'safety) 2)) + +(defun compiler-push-events () + (>= (cmp-env-optimization 'safety) 3)) diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index 12cfe8264..cf1221c8c 100644 --- a/src/cmp/cmppolicy.lsp +++ b/src/cmp/cmppolicy.lsp @@ -60,39 +60,13 @@ ;;(format t "~% ~64b" off) (logandc2 (logior bits on) off))) -(defun default-policy () - (compute-policy `((space ,*space*) - (safety ,*safety*) - (debug ,*debug*) - (speed ,*speed*)) - 0)) - (defun cmp-env-policy (env) (or (first (cmp-env-search-declaration 'optimization env)) (default-policy))) -(defun cmp-env-add-optimizations (decl &optional (env *cmp-env*)) - (let* ((old (cmp-env-policy env)) - (new (compute-policy decl old))) - (cmp-env-add-declaration 'optimization (list new) env))) - (defun policy-declaration-name-p (name) (and (gethash name *optimization-quality-switches*) t)) -(defun maybe-add-policy (decl &optional (env *cmp-env*)) - (when (and (consp decl) - (<= (list-length decl) 2) - (gethash (first decl) *optimization-quality-switches*)) - (let* ((old (cmp-env-policy env)) - (flag (if (or (endp (rest decl)) (second decl)) 3 0)) - (new (compute-policy (list (list (first decl) flag)) old))) - (cmp-env-add-declaration 'optimization (list new) env)))) - -(defun add-default-optimizations (env) - (if (cmp-env-search-declaration 'optimization env) - env - (cmp-env-add-declaration 'optimization (list (default-policy)) env))) - (eval-when (:compile-toplevel :execute) (defparameter +last-optimization-bit+ 17) (defun augment-policy (quality level on-off flag) @@ -293,27 +267,6 @@ INTGERP, STRINGP.") (define-function policy-to-speed-level 8) (define-function policy-to-space-level 12)) -(defun cmp-env-all-optimizations (&optional (env *cmp-env*)) - (let ((o (cmp-env-policy env))) - (list (policy-to-debug-level o) - (policy-to-safety-level o) - (policy-to-space-level o) - (policy-to-speed-level o)))) - -(defun cmp-env-optimization (property &optional (env *cmp-env*)) - (let ((o (cmp-env-policy env))) - (case property - (debug (policy-to-debug-level o)) - (safety (policy-to-safety-level o)) - (space (policy-to-space-level o)) - (speed (policy-to-speed-level o))))) - -(defun safe-compile () - (>= (cmp-env-optimization 'safety) 2)) - -(defun compiler-push-events () - (>= (cmp-env-optimization 'safety) 3)) - (eval-when (:load-toplevel) (defparameter *optimization-quality-switches* #.*optimization-quality-switches*)) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 2d2d54416..60d58aec4 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -12,14 +12,15 @@ "src:cmp;cmpmach.lsp" "src:cmp;cmprefs.lsp" "src:cmp;cmplocs.lsp" + "src:cmp;cmppolicy.lsp" ;; Environment "src:cmp;cmpenv-api.lsp" "src:cmp;cmpenv-var.lsp" "src:cmp;cmpenv-fun.lsp" + "src:cmp;cmpenv-optimize.lsp" "src:cmp;cmpenv-declare.lsp" "src:cmp;cmpenv-proclaim.lsp" "src:cmp;cmpenv-declaim.lsp" - "src:cmp;cmppolicy.lsp" ;; Internal representation "src:cmp;cmptypes.lsp" "src:cmp;cmpform.lsp" -- GitLab From 6a4d094f0ffc1b86811823580c94671c3c59b871 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2023 17:02:42 +0100 Subject: [PATCH 29/33] cmp: refactor cmppolicy (part 1) - make compilation-speed supported similar to other optimzie qualities - make define-policy idempotent for recompilation with the same options - remove dead code branches - rework code to eliminate multiple EVAL-WHENs (for readibility) --- src/cmp/cmpenv-declare.lsp | 19 ++- src/cmp/cmpenv-optimize.lsp | 87 ++++++++++- src/cmp/cmpglobals.lsp | 3 +- src/cmp/cmppolicy.lsp | 297 +++++++++++------------------------- 4 files changed, 188 insertions(+), 218 deletions(-) diff --git a/src/cmp/cmpenv-declare.lsp b/src/cmp/cmpenv-declare.lsp index 139ee6f35..9e709970f 100644 --- a/src/cmp/cmpenv-declare.lsp +++ b/src/cmp/cmpenv-declare.lsp @@ -43,16 +43,19 @@ (member name (cmp-env-search-declaration 'alien env si::*alien-declarations*) :test 'eq))) +(defun policy-declaration-p (name) + (and (gethash name *optimization-quality-switches*) t)) + (defun parse-ignore-declaration (decl-args expected-ref-number tail) (declare (si::c-local)) (loop for name in decl-args - do (if (symbolp name) - (push (cons name expected-ref-number) tail) - (cmpassert (and (consp name) - (= (length name) 2) - (eq (first name) 'function)) - "Invalid argument to IGNORE/IGNORABLE declaration:~&~A" - name))) + do (if (symbolp name) + (push (cons name expected-ref-number) tail) + (cmpassert (and (consp name) + (= (length name) 2) + (eq (first name) 'function)) + "Invalid argument to IGNORE/IGNORABLE declaration:~&~A" + name))) tail) (defun collect-declared (type var-list tail) @@ -107,7 +110,7 @@ and a possible documentation string (only accepted when DOC-P is true)." (SI:FUNCTION-BLOCK-NAME) (otherwise (if (or (alien-declaration-p decl-name) - (policy-declaration-name-p decl-name)) + (policy-declaration-p decl-name)) (push decl others) (multiple-value-bind (ok type) (if (machine-c-type-p decl-name) diff --git a/src/cmp/cmpenv-optimize.lsp b/src/cmp/cmpenv-optimize.lsp index c7ea02d05..bf94768da 100644 --- a/src/cmp/cmpenv-optimize.lsp +++ b/src/cmp/cmpenv-optimize.lsp @@ -4,7 +4,7 @@ ;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll ;;;; Copyright (c) 2023, Daniel Kochmański ;;;; -;;;; See file 'LICENSE' for the copyright details. +;;;; See the file 'LICENSE' for the copyright details. (in-package #:compiler) @@ -12,9 +12,14 @@ (compute-policy `((space ,*space*) (safety ,*safety*) (debug ,*debug*) - (speed ,*speed*)) + (speed ,*speed*) + (compilation-speed ,*compilation-speed*)) 0)) +(defun cmp-env-policy (env) + (or (first (cmp-env-search-declaration 'optimization env)) + (default-policy))) + (defun add-default-optimizations (env) (if (cmp-env-search-declaration 'optimization env) env @@ -54,3 +59,81 @@ (defun compiler-push-events () (>= (cmp-env-optimization 'safety) 3)) + + + +;; +;; ERROR CHECKING POLICY +;; + +(define-policy ext:assume-no-errors :off safety 1) + +(define-policy ext:assume-right-type :alias ext:assume-no-errors) + +(define-policy ext:type-assertions :anti-alias ext:assume-no-errors + "Generate type assertions when inlining accessors and other functions.") + +(define-policy ext:check-stack-overflow :on safety 2 + "Add a stack check to every function") + +(define-policy ext:check-arguments-type :on safety 1 + "Generate CHECK-TYPE forms for function arguments with type declarations") + +(define-policy ext:array-bounds-check :on safety 1 + "Check out of bounds access to arrays") + +(define-policy ext:global-var-checking :on safety 3 + "Read the value of a global variable even if it is discarded, ensuring it is bound") + +(define-policy ext:global-function-checking :on safety 3 + "Read the binding of a global function even if it is discarded") + +(define-policy ext:check-nargs :on safety 1 :only-on ext:check-arguments-type 1 + "Check that the number of arguments a function receives is within bounds") + +(define-policy ext:the-is-checked :on safety 1 + "THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE.") + +;; +;; INLINING POLICY +;; + +(define-policy ext:assume-types-dont-change :off safety 1 + "Assume that type and class definitions will not change") + +(define-policy ext:inline-slot-access :on speed 1 :off debug 2 :off safety 2 + "Inline access to structures and sealed classes") + +(define-policy ext:inline-accessors :off debug 2 :off space 2 + "Inline access to object slots, including conses and arrays") + +(define-policy ext:inline-bit-operations :off space 2 + "Inline LDB and similar functions") + +(define-policy ext:open-code-aref/aset :alias ext:inline-accessors + "Inline access to arrays") + +(define-policy ext:evaluate-forms :off debug 1 + "Pre-evaluate a function that takes constant arguments") + +(define-policy ext:use-direct-C-call :off debug 2 + "Emit direct calls to a function whose C name is known") + +(define-policy ext:inline-type-checks :off space 2 + "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP, +INTGERP, STRINGP.") + +(define-policy ext:inline-sequence-functions :off space 2 + "Inline functions such as MAP, MEMBER, FIND, etc") + +;; +;; DEBUG POLICY +;; + +(define-policy ext:debug-variable-bindings :on debug 3 + :requires (policy-debug-ihs-frame env) + ;; We can only create variable bindings when the function has an IHS frame!!! + "Create a debug vector with the bindings of each LET/LET*/LAMBDA form?") + +(define-policy ext:debug-ihs-frame :on debug 3 + "Let the functions appear in backtraces") diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 9df876fca..a3eb614e9 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -92,12 +92,13 @@ running the compiler. It may be updated by running ") ;;; --cmpenv.lsp-- ;;; -;;; These default settings are equivalent to (optimize (speed 3) (space 0) (safety 2)) +;;; Default optimization settings. ;;; (defvar *safety* 2) (defvar *speed* 3) (defvar *space* 0) (defvar *debug* 0) +(defvar *compilation-speed* 2) ;;; ;;; Compiled code uses the following kinds of variables: diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index cf1221c8c..c1b5435d0 100644 --- a/src/cmp/cmppolicy.lsp +++ b/src/cmp/cmppolicy.lsp @@ -3,32 +3,43 @@ ;;;; ;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański ;;;; -;;;; 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. + ;;;; ;;;; CMPPOLICY -- Code generation choices ;;;; (in-package "COMPILER") +(defconstant *standard-optimization-quality-names* + '(debug safety speed space compilation-speed)) + (eval-when (:compile-toplevel :execute) - (defparameter *optimization-quality-switches* + (defvar *optimization-quality-switches* (loop with hash = (make-hash-table :size 64 :test #'eq) - for name in '(debug safety speed space) + for name in '(debug safety speed space compilation-speed) for i from 0 by 4 for list = (loop with mask = (ash #b1111 i) for level from 0 to 3 for bits = (ash 1 (+ level i)) collect (cons bits (logxor bits mask))) do (setf (gethash name hash) list) - finally (setf (gethash 'compilation-speed hash) - '#1=((0 . 0) . #1#)) - (return hash)))) + finally (return hash))) + (defvar *last-optimization-bit* 20) + (defvar *optimization-bits* (make-hash-table))) + +(eval-when (:load-toplevel :execute) + (defvar *optimization-quality-switches* #.*optimization-quality-switches*) + (defvar *last-optimization-bit* #.*last-optimization-bit*) + (defvar *optimization-bits* #.*optimization-bits*)) + +(defun take-optimization-bit (name) + (or (gethash name *optimization-bits*) + (setf (gethash name *optimization-bits*) + (incf *last-optimization-bit*)))) (defun optimization-quality-switches (type index) (nth index (gethash type *optimization-quality-switches*))) @@ -60,201 +71,76 @@ ;;(format t "~% ~64b" off) (logandc2 (logior bits on) off))) -(defun cmp-env-policy (env) - (or (first (cmp-env-search-declaration 'optimization env)) - (default-policy))) - -(defun policy-declaration-name-p (name) - (and (gethash name *optimization-quality-switches*) t)) - -(eval-when (:compile-toplevel :execute) - (defparameter +last-optimization-bit+ 17) - (defun augment-policy (quality level on-off flag) - #+(or) - (if (eq on-off :on) - (loop for i from 0 to 3 - for bits = (optimization-quality-switches quality i) - if (>= i level) - do (rplaca bits (logior (car bits) flag)) - else do (rplacd bits (logior (cdr bits) flag))) - (loop for i from 0 to 3 - for bits = (optimization-quality-switches quality i) - when (>= i level) - do (rplacd bits (logior (cdr bits) flag)))) - #+(or) - (loop for i from level to 3 - for bits = (optimization-quality-switches quality i) - if (eq on-off :on) - do (rplaca bits (logior (car bits) flag)) - else do (rplacd bits (logior (cdr bits) flag))) - (loop for i from 0 to 3 - for bits = (optimization-quality-switches quality i) - if (< i level) - do +;;; for example debug 2 :on #x10 +(defun augment-policy (quality level on-off flag) + (loop for i from 0 to 3 + for bits = (optimization-quality-switches quality i) + do (if (< i level) (case on-off (:on (rplacd bits (logior (cdr bits) flag))) (:off (rplaca bits (logior (car bits) flag)))) - else do - (case on-off - ((:only-on :on) (rplaca bits (logior (car bits) flag))) - ((:only-off :off) (rplacd bits (logior (cdr bits) flag)))))) - - (defun policy-declaration-name (base) - (intern (symbol-name base) (find-package "EXT"))) - - (defun policy-function-name (base) - (intern (concatenate 'string "POLICY-" (symbol-name base)) - (find-package "C"))) - - (defmacro define-policy (&whole whole name &rest conditions) - (let* ((test (ash 1 +last-optimization-bit+)) - (declaration-name (policy-declaration-name name)) - (function-name (policy-function-name name)) - (doc (find-if #'stringp conditions)) - (emit-function t)) - ;; If it is an alias, just copy the bits - ;; Register as an optimization quality with its own flags - (let* ((circular-list (list (cons test 0))) - (flags-list (list* (cons 0 test) - circular-list))) - (rplacd circular-list circular-list) - (setf (gethash declaration-name *optimization-quality-switches*) - flags-list)) - ;; Scan the definition and correct the flags - (loop with extra = '() - with slow = '() - with conditions = (remove doc conditions) - for case = (pop conditions) - while case - do - (case case - (:no-function - (setf emit-function nil)) - (:alias - (let* ((alias (first conditions))) - (setf (gethash declaration-name *optimization-quality-switches*) - (gethash (policy-declaration-name alias) - *optimization-quality-switches*)) - (return `(defun ,function-name (&optional (env *cmp-env*)) - ,@(and doc (list doc)) - (,(policy-function-name alias) env))))) - (:anti-alias - (let* ((alias (first conditions)) - (bits (gethash (policy-declaration-name alias) - *optimization-quality-switches*))) - (setf bits (list (second bits) - (first bits))) - (rplacd (cdr bits) (cdr bits)) - (setf (gethash declaration-name *optimization-quality-switches*) - bits) - (return `(defun ,function-name (&optional (env *cmp-env*)) - ,@(and doc (list doc)) - (not (,(policy-function-name alias) env)))))) - ((:only-on :on) - (push `(>= (cmp-env-optimization ',(first conditions) env) - ,(second conditions)) - slow) - (augment-policy (pop conditions) (pop conditions) - case test)) - ((:only-off :off) - (push `(< (cmp-env-optimization ',(first conditions) env) - ,(second conditions)) - slow) - (augment-policy (pop conditions) (pop conditions) - case test)) - (:requires - (push (pop conditions) extra)) - (otherwise - (error "Syntax error in macro~% ~A" - `(define-policy ,@whole)))) - finally - (progn - (incf +last-optimization-bit+) - (return - (and emit-function - `(defun ,function-name (&optional (env *cmp-env*)) - ,@(and doc (list doc)) - (let ((bits (cmp-env-policy env))) - (and (logtest bits ,test) - ,@extra)))))))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - - ;; - ;; ERROR CHECKING POLICY - ;; - - (define-policy ext:assume-no-errors :off safety 1) - - (define-policy ext:assume-right-type :alias ext:assume-no-errors) - - (define-policy ext:type-assertions :anti-alias ext:assume-no-errors - "Generate type assertions when inlining accessors and other functions.") - - (define-policy ext:check-stack-overflow :on safety 2 - "Add a stack check to every function") - - (define-policy ext:check-arguments-type :on safety 1 - "Generate CHECK-TYPE forms for function arguments with type declarations") - - (define-policy ext:array-bounds-check :on safety 1 - "Check out of bounds access to arrays") - - (define-policy ext:global-var-checking :on safety 3 - "Read the value of a global variable even if it is discarded, ensuring it is bound") - - (define-policy ext:global-function-checking :on safety 3 - "Read the binding of a global function even if it is discarded") - - (define-policy ext:check-nargs :on safety 1 :only-on ext:check-arguments-type 1 - "Check that the number of arguments a function receives is within bounds") - - (define-policy ext:the-is-checked :on safety 1 - "THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE.") - - ;; - ;; INLINING POLICY - ;; - - (define-policy ext:assume-types-dont-change :off safety 1 - "Assume that type and class definitions will not change") - - (define-policy ext:inline-slot-access :on speed 1 :off debug 2 :off safety 2 - "Inline access to structures and sealed classes") - - (define-policy ext:inline-accessors :off debug 2 :off space 2 - "Inline access to object slots, including conses and arrays") - - (define-policy ext:inline-bit-operations :off space 2 - "Inline LDB and similar functions") - - (define-policy ext:open-code-aref/aset :alias ext:inline-accessors - "Inline access to arrays") - - (define-policy ext:evaluate-forms :off debug 1 - "Pre-evaluate a function that takes constant arguments") - - (define-policy ext:use-direct-C-call :off debug 2 - "Emit direct calls to a function whose C name is known") - - (define-policy ext:inline-type-checks :off space 2 - "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP, -INTGERP, STRINGP.") - - (define-policy ext:inline-sequence-functions :off space 2 - "Inline functions such as MAP, MEMBER, FIND, etc") - - ;; - ;; DEBUG POLICY - ;; - - (define-policy ext:debug-variable-bindings :on debug 3 - :requires (policy-debug-ihs-frame env) - ;; We can only create variable bindings when the function has an IHS frame!!! - "Create a debug vector with the bindings of each LET/LET*/LAMBDA form?") - - (define-policy ext:debug-ihs-frame :on debug 3 - "Let the functions appear in backtraces")) + (case on-off + ((:only-on :on) (rplaca bits (logior (car bits) flag))) + ((:only-off :off) (rplacd bits (logior (cdr bits) flag))))))) + +(defun policy-function-name (base) + (intern (concatenate 'string "POLICY-" (symbol-name base)) + (find-package "C"))) + +(defmacro define-policy (&whole whole name &rest conditions) + (let* ((test (ash 1 (take-optimization-bit name))) + (function-name (policy-function-name name)) + (doc (find-if #'stringp conditions)) + (emit-function t)) + ;; If it is an alias, just copy the bits + ;; Register as an optimization quality with its own flags + (let* ((circular-list (list (cons test 0))) + (flags-list (list* (cons 0 test) circular-list))) + (rplacd circular-list circular-list) + (setf (gethash name *optimization-quality-switches*) flags-list)) + ;; Scan the definition and correct the flags + (loop with extra = '() + with conditions = (remove doc conditions) + for case = (pop conditions) + while case + do (case case + (:no-function + (setf emit-function nil)) + (:alias + (let* ((alias (first conditions))) + (setf (gethash name *optimization-quality-switches*) + (gethash alias *optimization-quality-switches*)) + (return `(defun ,function-name (&optional (env *cmp-env*)) + ,@(and doc (list doc)) + (,(policy-function-name alias) env))))) + (:anti-alias + (let* ((alias (first conditions)) + (bits (gethash alias *optimization-quality-switches*))) + + (setf bits (list (second bits) + (first bits))) + (rplacd (cdr bits) (cdr bits)) + (setf (gethash name *optimization-quality-switches*) bits) + (return `(defun ,function-name (&optional (env *cmp-env*)) + ,@(and doc (list doc)) + (not (,(policy-function-name alias) env)))))) + ((:only-on :on) + (augment-policy (pop conditions) (pop conditions) case test)) + ((:only-off :off) + (augment-policy (pop conditions) (pop conditions) case test)) + (:requires + (push (pop conditions) extra)) + (otherwise + (error "Syntax error in macro~% ~A" + `(define-policy ,@whole)))) + finally + (return + (and emit-function + `(defun ,function-name (&optional (env *cmp-env*)) + ,@(and doc (list doc)) + (let ((bits (cmp-env-policy env))) + (and (logtest bits ,test) + ,@extra)))))))) (macrolet ((define-function (fun-name offset) `(defun ,fun-name (policy) @@ -265,8 +151,5 @@ INTGERP, STRINGP.") (define-function policy-to-debug-level 0) (define-function policy-to-safety-level 4) (define-function policy-to-speed-level 8) - (define-function policy-to-space-level 12)) - -(eval-when (:load-toplevel) - (defparameter *optimization-quality-switches* - #.*optimization-quality-switches*)) + (define-function policy-to-space-level 12) + (define-function policy-to-compilation-speed-level 16)) -- GitLab From e9668d798c1b29d2af4736265bddb4cd9e10e714 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2023 20:03:06 +0100 Subject: [PATCH 30/33] cmp: refactor cmppolicy (part 2) - define-policy has more strict syntax checking - define-policy puts clauses in parenthesis - compute-policy is rewritten for readibility - augment-policy is rewritten for readibility - define-policy and define-policy-alias are separate macros --- src/cmp/cmpenv-optimize.lsp | 110 +++++++++++++++---------- src/cmp/cmppolicy.lsp | 160 ++++++++++++++++++------------------ 2 files changed, 146 insertions(+), 124 deletions(-) diff --git a/src/cmp/cmpenv-optimize.lsp b/src/cmp/cmpenv-optimize.lsp index bf94768da..a586e8186 100644 --- a/src/cmp/cmpenv-optimize.lsp +++ b/src/cmp/cmpenv-optimize.lsp @@ -66,74 +66,100 @@ ;; ERROR CHECKING POLICY ;; -(define-policy ext:assume-no-errors :off safety 1) +(define-policy ext:assume-no-errors + "All bets are off." + (:off safety 1)) -(define-policy ext:assume-right-type :alias ext:assume-no-errors) +(define-policy-alias ext:assume-right-type + "Don't insert optional runtime type checks for known types." + (:alias ext:assume-no-errors)) -(define-policy ext:type-assertions :anti-alias ext:assume-no-errors - "Generate type assertions when inlining accessors and other functions.") +(define-policy-alias ext:type-assertions + "Generate type assertions when inlining accessors and other functions." + (:anti-alias ext:assume-no-errors)) -(define-policy ext:check-stack-overflow :on safety 2 - "Add a stack check to every function") +(define-policy ext:check-stack-overflow + "Add a stack check to every function" + (:on safety 2)) -(define-policy ext:check-arguments-type :on safety 1 - "Generate CHECK-TYPE forms for function arguments with type declarations") +(define-policy ext:check-arguments-type + "Generate CHECK-TYPE forms for function arguments with type declarations." + (:on safety 1)) -(define-policy ext:array-bounds-check :on safety 1 - "Check out of bounds access to arrays") +(define-policy ext:array-bounds-check + "Check out of bounds access to arrays." + (:on safety 1)) -(define-policy ext:global-var-checking :on safety 3 - "Read the value of a global variable even if it is discarded, ensuring it is bound") +(define-policy ext:global-var-checking + "Read the value of a global variable even if it is discarded, ensuring it is bound." + (:on safety 3)) -(define-policy ext:global-function-checking :on safety 3 - "Read the binding of a global function even if it is discarded") +(define-policy ext:global-function-checking + "Read the binding of a global function even if it is discarded." + (:on safety 3)) -(define-policy ext:check-nargs :on safety 1 :only-on ext:check-arguments-type 1 - "Check that the number of arguments a function receives is within bounds") +(define-policy ext:check-nargs + "Check that the number of arguments a function receives is within bounds." + (:on safety 1) + (:only-on ext:check-arguments-type)) -(define-policy ext:the-is-checked :on safety 1 - "THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE.") +(define-policy ext:the-is-checked + "THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE." + (:on safety 1)) ;; ;; INLINING POLICY ;; -(define-policy ext:assume-types-dont-change :off safety 1 - "Assume that type and class definitions will not change") +(define-policy ext:assume-types-dont-change + "Assume that type and class definitions will not change." + (:off safety 1)) -(define-policy ext:inline-slot-access :on speed 1 :off debug 2 :off safety 2 - "Inline access to structures and sealed classes") +(define-policy ext:inline-slot-access + "Inline access to structures and sealed classes." + (:on speed 1) + (:off debug 2) + (:off safety 2)) -(define-policy ext:inline-accessors :off debug 2 :off space 2 - "Inline access to object slots, including conses and arrays") +(define-policy ext:inline-accessors + "Inline access to object slots, including conses and arrays." + (:off debug 2) + (:off space 2)) -(define-policy ext:inline-bit-operations :off space 2 - "Inline LDB and similar functions") +(define-policy ext:inline-bit-operations + "Inline LDB and similar functions." + (:off space 2)) -(define-policy ext:open-code-aref/aset :alias ext:inline-accessors - "Inline access to arrays") +(define-policy-alias ext:open-code-aref/aset + "Inline access to arrays." + (:alias ext:inline-accessors)) -(define-policy ext:evaluate-forms :off debug 1 - "Pre-evaluate a function that takes constant arguments") +(define-policy ext:evaluate-forms + "Pre-evaluate a function that takes constant arguments." + (:off debug 1)) -(define-policy ext:use-direct-C-call :off debug 2 - "Emit direct calls to a function whose C name is known") +(define-policy ext:use-direct-C-call + "Emit direct calls to a function whose C name is known." + (:off debug 2)) -(define-policy ext:inline-type-checks :off space 2 - "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP, -INTGERP, STRINGP.") +(define-policy ext:inline-type-checks + "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP, INTGERP, STRINGP." + (:off space 2)) -(define-policy ext:inline-sequence-functions :off space 2 - "Inline functions such as MAP, MEMBER, FIND, etc") +(define-policy ext:inline-sequence-functions + "Inline functions such as MAP, MEMBER, FIND, etc." + (:off space 2)) ;; ;; DEBUG POLICY ;; -(define-policy ext:debug-variable-bindings :on debug 3 - :requires (policy-debug-ihs-frame env) +(define-policy ext:debug-variable-bindings + "Create a debug vector with the bindings of each LET/LET*/LAMBDA form." ;; We can only create variable bindings when the function has an IHS frame!!! - "Create a debug vector with the bindings of each LET/LET*/LAMBDA form?") + (:requires (policy-debug-ihs-frame env)) + (:on debug 3)) -(define-policy ext:debug-ihs-frame :on debug 3 - "Let the functions appear in backtraces") +(define-policy ext:debug-ihs-frame + "Let the functions appear in backtraces." + (:on debug 3)) diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index c1b5435d0..e0d0a438a 100644 --- a/src/cmp/cmppolicy.lsp +++ b/src/cmp/cmppolicy.lsp @@ -14,13 +14,15 @@ (in-package "COMPILER") + (defconstant *standard-optimization-quality-names* '(debug safety speed space compilation-speed)) (eval-when (:compile-toplevel :execute) + (defvar *last-optimization-bit* 20) (defvar *optimization-quality-switches* (loop with hash = (make-hash-table :size 64 :test #'eq) - for name in '(debug safety speed space compilation-speed) + for name in *standard-optimization-quality-names* for i from 0 by 4 for list = (loop with mask = (ash #b1111 i) for level from 0 to 3 @@ -28,12 +30,17 @@ collect (cons bits (logxor bits mask))) do (setf (gethash name hash) list) finally (return hash))) - (defvar *last-optimization-bit* 20) - (defvar *optimization-bits* (make-hash-table))) + ;; For the standard qualities we encode the lowest bit position. + (defvar *optimization-bits* + (loop with hash = (make-hash-table :size 64 :test #'eq) + for name in *standard-optimization-quality-names* + for i from 0 by 4 + do (setf (gethash name hash) i) + finally (return hash)))) (eval-when (:load-toplevel :execute) - (defvar *optimization-quality-switches* #.*optimization-quality-switches*) (defvar *last-optimization-bit* #.*last-optimization-bit*) + (defvar *optimization-quality-switches* #.*optimization-quality-switches*) (defvar *optimization-bits* #.*optimization-bits*)) (defun take-optimization-bit (name) @@ -44,103 +51,92 @@ (defun optimization-quality-switches (type index) (nth index (gethash type *optimization-quality-switches*))) -(defun compute-policy (arguments old-bits) - (let* ((bits old-bits) - (on 0) - (off 0)) +(defun compute-policy (arguments old-bits &aux (on 0) (off 0)) + (flet ((get-flags (x) + (if (atom x) + (optimization-quality-switches x 3) + (destructuring-bind (name value) x + (when (typep value '(integer 0 3)) + (optimization-quality-switches name value)))))) (dolist (x arguments) - (let (flags name value) - (cond ((symbolp x) - (setq name x - value 3 - flags (optimization-quality-switches name value))) - ((or (not (consp x)) - (not (consp (cdr x))) - (not (numberp (second x))) - (not (<= 0 (second x) 3)))) - (t - (setf name (first x) - value (second x) - flags (optimization-quality-switches name value)))) - (if (null flags) - (cmpwarn "Illegal or unknown OPTIMIZE proclamation ~s." x) - (setf on (logior on (car flags)) - off (logior off (cdr flags)))))) - ;;(format t "~%*~64b" bits) - ;;(format t "~% ~64b" on) - ;;(format t "~% ~64b" off) - (logandc2 (logior bits on) off))) + (ext:if-let ((flags (get-flags x))) + (setf on (logior on (car flags)) + off (logior off (cdr flags))) + (cmpwarn "Illegal or unknown OPTIMIZE proclamation ~s." x)))) + (logandc2 (logior old-bits on) off)) ;;; for example debug 2 :on #x10 (defun augment-policy (quality level on-off flag) - (loop for i from 0 to 3 - for bits = (optimization-quality-switches quality i) - do (if (< i level) - (case on-off - (:on (rplacd bits (logior (cdr bits) flag))) - (:off (rplaca bits (logior (car bits) flag)))) - (case on-off - ((:only-on :on) (rplaca bits (logior (car bits) flag))) - ((:only-off :off) (rplacd bits (logior (cdr bits) flag))))))) + (flet ((flip (on-off switches flag) + (ecase on-off + (:on (rplaca switches (logior (car switches) flag))) + (:off (rplacd switches (logior (cdr switches) flag)))))) + (loop for i from 0 to 3 + for bits = (optimization-quality-switches quality i) + do (if (< i level) + (ecase on-off + (:on (flip :off bits flag)) + (:off (flip :on bits flag)) + (:only-on nil) + (:only-off nil)) + (ecase on-off + (:on (flip :on bits flag)) + (:off (flip :off bits flag)) + (:only-on (flip :on bits flag)) + (:only-off (flip :off bits flag))))))) (defun policy-function-name (base) (intern (concatenate 'string "POLICY-" (symbol-name base)) (find-package "C"))) (defmacro define-policy (&whole whole name &rest conditions) - (let* ((test (ash 1 (take-optimization-bit name))) - (function-name (policy-function-name name)) - (doc (find-if #'stringp conditions)) - (emit-function t)) - ;; If it is an alias, just copy the bits - ;; Register as an optimization quality with its own flags + (let ((doc (and (stringp (car conditions)) (pop conditions))) + (test (ash 1 (take-optimization-bit name))) + (function-name (policy-function-name name))) + ;; Register as an optimization quality with its own flags. (let* ((circular-list (list (cons test 0))) (flags-list (list* (cons 0 test) circular-list))) (rplacd circular-list circular-list) (setf (gethash name *optimization-quality-switches*) flags-list)) - ;; Scan the definition and correct the flags + ;; Scan the definition and propagate flags of dependent policies. (loop with extra = '() - with conditions = (remove doc conditions) - for case = (pop conditions) - while case - do (case case - (:no-function - (setf emit-function nil)) - (:alias - (let* ((alias (first conditions))) - (setf (gethash name *optimization-quality-switches*) - (gethash alias *optimization-quality-switches*)) - (return `(defun ,function-name (&optional (env *cmp-env*)) - ,@(and doc (list doc)) - (,(policy-function-name alias) env))))) - (:anti-alias - (let* ((alias (first conditions)) - (bits (gethash alias *optimization-quality-switches*))) - - (setf bits (list (second bits) - (first bits))) - (rplacd (cdr bits) (cdr bits)) - (setf (gethash name *optimization-quality-switches*) bits) - (return `(defun ,function-name (&optional (env *cmp-env*)) - ,@(and doc (list doc)) - (not (,(policy-function-name alias) env)))))) - ((:only-on :on) - (augment-policy (pop conditions) (pop conditions) case test)) - ((:only-off :off) - (augment-policy (pop conditions) (pop conditions) case test)) + for case in conditions + do (case (car case) + ((:on :off) + (destructuring-bind (op quality level) case + (augment-policy quality level op test))) + ((:only-on :only-off) + (destructuring-bind (op quality) case + (augment-policy quality 1 op test))) (:requires - (push (pop conditions) extra)) + (destructuring-bind (op form) case + (declare (ignore op)) + (push form extra))) (otherwise - (error "Syntax error in macro~% ~A" - `(define-policy ,@whole)))) + (error "Syntax error in macro~% ~A" `(define-policy ,@whole)))) finally (return - (and emit-function - `(defun ,function-name (&optional (env *cmp-env*)) - ,@(and doc (list doc)) - (let ((bits (cmp-env-policy env))) - (and (logtest bits ,test) - ,@extra)))))))) + `(defun ,function-name (&optional (env *cmp-env*)) + ,@(and doc (list doc)) + (let ((bits (cmp-env-policy env))) + (and (logtest bits ,test) + ,@extra))))))) + +(defmacro define-policy-alias (name doc (op alias)) + (let ((bits (gethash alias *optimization-quality-switches*))) + (ecase op + (:alias + (setf (gethash name *optimization-quality-switches*) bits) + `(defun ,(policy-function-name name) (&optional (env *cmp-env*)) + ,doc + (,(policy-function-name alias) env))) + (:anti-alias + (rotatef (first bits) (second bits)) + (rplacd (cdr bits) (cdr bits)) + (setf (gethash name *optimization-quality-switches*) bits) + `(defun ,(policy-function-name name) (&optional (env *cmp-env*)) + ,doc + (not (,(policy-function-name alias) env))))))) (macrolet ((define-function (fun-name offset) `(defun ,fun-name (policy) -- GitLab From dae023d2af50d3fdc18864003d18d3236413f242 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Feb 2023 12:08:30 +0100 Subject: [PATCH 31/33] cmp: refactor cmppolicy (part 3) - get rid of circular lists - add a comment that shows the ropes - definetely separate standard quality and extended quality dependencies: on/off works only with standard qualities only-on/only-off works only with extended qualities --- src/cmp/cmpenv-optimize.lsp | 13 ++-- src/cmp/cmppolicy.lsp | 127 +++++++++++++++++++++++++++--------- src/cmp/load.lsp.in | 2 +- 3 files changed, 106 insertions(+), 36 deletions(-) diff --git a/src/cmp/cmpenv-optimize.lsp b/src/cmp/cmpenv-optimize.lsp index a586e8186..7ac1af9d7 100644 --- a/src/cmp/cmpenv-optimize.lsp +++ b/src/cmp/cmpenv-optimize.lsp @@ -34,10 +34,15 @@ (when (and (consp decl) (<= (list-length decl) 2) (gethash (first decl) *optimization-quality-switches*)) - (let* ((old (cmp-env-policy env)) - (flag (if (or (endp (rest decl)) (second decl)) 3 0)) - (new (compute-policy (list (list (first decl) flag)) old))) - (cmp-env-add-declaration 'optimization (list new) env)))) + (let* ((name (first decl)) + (value (if (or (endp (rest decl)) (second decl)) + (if (standard-optimization-quality-p name) + 3 + 1) + 0)) + (old-policy (cmp-env-policy env)) + (new-policy (compute-policy (list (list name value)) old-policy))) + (cmp-env-add-declaration 'optimization (list new-policy) env)))) (defun cmp-env-all-optimizations (&optional (env *cmp-env*)) (let ((o (cmp-env-policy env))) diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index e0d0a438a..4670186b4 100644 --- a/src/cmp/cmppolicy.lsp +++ b/src/cmp/cmppolicy.lsp @@ -14,9 +14,73 @@ (in-package "COMPILER") +;;; +;;; ECL encodes the compiler policy an integer. Each bit represents a single +;;; optimization choice. Lowest twenty bits encode the standard optimization +;;; qualities DEBUG, SAFETY, SPEED, SPACE and COMPILATION-SPEED - four bits for +;;; each level. Levels are mutually exclusive for a single quality. Then each +;;; defined policy occupies one bit. For example: +;;; +;;; X Y Z COMPILATION-SPEED SPACE SPEED SAFETY DEBUG +;;; 0 1 0 0010 0010 1000 0001 0010 +;;; +;;; Represents the following optimization settings: +;;; +;;; (OPTIMIZE (DEBUG 1) (SAFETY 0) (SPEED 3) (COMPILATION-SPEED 2) Y) +;;; +;;; New optimization qualities are defined with DEFINE-POLICY. Such definition +;;; adds one more bit tot he compilation policy and defines a function to test +;;; whether the quality is applicable under the compilation policy of the env. +;;; This functions first checks whether the quality bit is "1" and then may +;;; perform additional tests defined with clauses :REQUIRES. +;;; +;;; Each optimization quality (level) has associated two numbers. When it is +;;; declared in the environment the first number added to the compilation policy +;;; with LOGIOR and the second number is removed from the compilation policy +;;; with LOGANDC2. Thanks to that it is possible for declaration of one policy +;;; to enable other policies associated with it. For example (DEBUG 1) may be: +;;; +;;; X Y Z COMPILATION-SPEED SPACE SPEED SAFETY DEBUG +;;; 1 1 0 0000 0000 0000 0000 0010 "on" +;;; 0 0 1 0000 0000 0000 0000 1101 "off" +;;; +;;; When (DEBUG 1) is declared then bits representing X, Y and (DEBUG 1) are set +;;; to 1 and bits representing Z and other DEBUG levels are set to 0. Everything +;;; else remains unchanged. These pairs are "optimization quality switches". +;;; +;;; When a new policy is defined it may contain multiple :ON and :OFF clauses +;;; with an optional parameter representing the "cut off" level. For example: +;;; +;;; (define-policy W +;;; ; (SAFETY 0) and (SAFETY 1) "off" flags for W = 1 +;;; ; (SAFETY 2) and (SAFETY 3) "on" flags for W = 1 +;;; (:on safety 2) +;;; ; (DEBUG 0) and (DEBUG 1) "on" flags for W = 1 +;;; ; (DEBUG 2) and (DEBUG 3) "off" flags for W = 1 +;;; (:off debug 2)) +;;; +;;; With this example declaring (SAFETY 2) will enable the policy W and +;;; declaring (SAFETY 1) will disable it. Consider the following example: +;;; +;;; (locally (declare (safety 2) (debug 2)) +;;; (do-something)) +;;; +;;; The optimization (SAFETY 2) enables the policy W while the optimization +;;; (DEBUG 2) disables it. It is apparent from this example that the order in +;;; which we apply quality switches to the compilation policy is important. +;;; COMPUTE-POLICY prioritizes "off" flags over "on" flags so in this case the +;;; policy W will be disabled. +;;; +;;; Only standard optimization qualities have levels. User defined policies may +;;; be also references but the level must not be specified, i.e (:ON CHECK-FOO). +;;; -(defconstant *standard-optimization-quality-names* - '(debug safety speed space compilation-speed)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant *standard-optimization-quality-names* + '(debug safety speed space compilation-speed))) + +(defun standard-optimization-quality-p (name) + (member name *standard-optimization-quality-names* :test #'eq)) (eval-when (:compile-toplevel :execute) (defvar *last-optimization-bit* 20) @@ -54,7 +118,9 @@ (defun compute-policy (arguments old-bits &aux (on 0) (off 0)) (flet ((get-flags (x) (if (atom x) - (optimization-quality-switches x 3) + (if (standard-optimization-quality-p x) + (optimization-quality-switches x 3) + (optimization-quality-switches x 1)) (destructuring-bind (name value) x (when (typep value '(integer 0 3)) (optimization-quality-switches name value)))))) @@ -65,25 +131,27 @@ (cmpwarn "Illegal or unknown OPTIMIZE proclamation ~s." x)))) (logandc2 (logior old-bits on) off)) -;;; for example debug 2 :on #x10 -(defun augment-policy (quality level on-off flag) - (flet ((flip (on-off switches flag) - (ecase on-off - (:on (rplaca switches (logior (car switches) flag))) - (:off (rplacd switches (logior (cdr switches) flag)))))) - (loop for i from 0 to 3 - for bits = (optimization-quality-switches quality i) - do (if (< i level) - (ecase on-off - (:on (flip :off bits flag)) - (:off (flip :on bits flag)) - (:only-on nil) - (:only-off nil)) - (ecase on-off - (:on (flip :on bits flag)) - (:off (flip :off bits flag)) - (:only-on (flip :on bits flag)) - (:only-off (flip :off bits flag))))))) +(defun augment-policy-switch (on-off switches flag) + (ecase on-off + (:on (rplaca switches (logior (car switches) flag))) + (:off (rplacd switches (logior (cdr switches) flag))))) + +(defun augment-standard-policy (quality level on-off flag) + (loop for i from 0 to 3 + for bits = (optimization-quality-switches quality i) + do (if (< i level) + (ecase on-off + (:on (augment-policy-switch :off bits flag)) + (:off (augment-policy-switch :on bits flag))) + (ecase on-off + (:on (augment-policy-switch :on bits flag)) + (:off (augment-policy-switch :off bits flag)))))) + +(defun augment-extended-policy (quality on-off flag) + (let ((bits (optimization-quality-switches quality 1))) + (ecase on-off + (:only-on (augment-policy-switch :on bits flag)) + (:only-off (augment-policy-switch :off bits flag))))) (defun policy-function-name (base) (intern (concatenate 'string "POLICY-" (symbol-name base)) @@ -94,20 +162,19 @@ (test (ash 1 (take-optimization-bit name))) (function-name (policy-function-name name))) ;; Register as an optimization quality with its own flags. - (let* ((circular-list (list (cons test 0))) - (flags-list (list* (cons 0 test) circular-list))) - (rplacd circular-list circular-list) - (setf (gethash name *optimization-quality-switches*) flags-list)) + (setf (gethash name *optimization-quality-switches*) + ;; switched off switched on | two levels + (list (cons 0 test) (cons test 0))) ;; Scan the definition and propagate flags of dependent policies. (loop with extra = '() for case in conditions do (case (car case) ((:on :off) (destructuring-bind (op quality level) case - (augment-policy quality level op test))) + (augment-standard-policy quality level op test))) ((:only-on :only-off) (destructuring-bind (op quality) case - (augment-policy quality 1 op test))) + (augment-extended-policy quality op test))) (:requires (destructuring-bind (op form) case (declare (ignore op)) @@ -131,9 +198,7 @@ ,doc (,(policy-function-name alias) env))) (:anti-alias - (rotatef (first bits) (second bits)) - (rplacd (cdr bits) (cdr bits)) - (setf (gethash name *optimization-quality-switches*) bits) + (setf (gethash name *optimization-quality-switches*) (reverse bits)) `(defun ,(policy-function-name name) (&optional (env *cmp-env*)) ,doc (not (,(policy-function-name alias) env))))))) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 60d58aec4..1c5283627 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -8,11 +8,11 @@ "src:cmp;cmputil.lsp" "src:cmp;cmpcond.lsp" "src:cmp;cmptype-arith.lsp" + "src:cmp;cmppolicy.lsp" ;; Internal representation "src:cmp;cmpmach.lsp" "src:cmp;cmprefs.lsp" "src:cmp;cmplocs.lsp" - "src:cmp;cmppolicy.lsp" ;; Environment "src:cmp;cmpenv-api.lsp" "src:cmp;cmpenv-var.lsp" -- GitLab From 7f5eb56055fb199f994e883714d87d1dd187776b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Feb 2023 14:38:50 +0100 Subject: [PATCH 32/33] cmp: treat compilation-speed as a separate optimization option Policy api works now with compilation speed (although we have no policies for compilation-speed currently). Supersedes !241. --- src/cmp/cmpenv-proclaim.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cmp/cmpenv-proclaim.lsp b/src/cmp/cmpenv-proclaim.lsp index 546335a48..de0bcc6f4 100644 --- a/src/cmp/cmpenv-proclaim.lsp +++ b/src/cmp/cmpenv-proclaim.lsp @@ -47,7 +47,7 @@ (SAFETY (setq *safety* (second x))) (SPACE (setq *space* (second x))) (SPEED (setq *speed* (second x))) - (COMPILATION-SPEED (setq *speed* (- 3 (second x)))) + (COMPILATION-SPEED (setq *compilation-speed* (second x))) (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) (cl:TYPE (if (consp (cdr decl)) -- GitLab From 4d3285892aab8db03eeb9a0261295e61490d4041 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Feb 2023 16:15:38 +0100 Subject: [PATCH 33/33] cmp: load cmptables before cmpforms --- src/cmp/load.lsp.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 1c5283627..357b4183c 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -23,10 +23,10 @@ "src:cmp;cmpenv-declaim.lsp" ;; Internal representation "src:cmp;cmptypes.lsp" + "src:cmp;cmptables.lsp" "src:cmp;cmpform.lsp" "src:cmp;cmpvar.lsp" "src:cmp;cmpfun.lsp" - "src:cmp;cmptables.lsp" "src:cmp;cmpinline.lsp" ;; Types "src:cmp;cmptype-prop.lsp" -- GitLab