diff --git a/src/c/compiler.d b/src/c/compiler.d index 097a93bc50c182d01aaccc3a28211abdc6d3a7d1..9be698e234a83c97334338bbdeadbdca647e044d 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/c/symbols_list.h b/src/c/symbols_list.h index e6334e529ae8abcdf99faf75d85992151b22e3d8..5379959ac34e92f27f7f3ad326b50b669310097a 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/clos/method.lsp b/src/clos/method.lsp index 852b061daee05546209c03eb1131e119c1d6d4e1..7d242f31b9033b63da92c19b4f4c2af59a0bf28f 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 d22337a833aae70c89493db0bac3825a1e1c786f..97429c850ba5fed87d14fb22af021ab4bfa896d1 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")) diff --git a/src/cmp/cmparray.lsp b/src/cmp/cmparray.lsp index e1e6e77136bb5dd6fa1a3c0bf9d6d3ee3a2dfa47..1a6540da8876e8a9abddd49a2660d5dcfabb70ab 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,32 +221,32 @@ 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) (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/cmpc-inliner.lsp b/src/cmp/cmpc-inliner.lsp index ed0540d419b03b9adc2536f400444bdfde737d85..a507a4d232eb41d99ae6982215bb43d178667b4e 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 1a681455c5e3888fffdc59637900a0123e339758..4514a4640642ba9fb96c0244506cd519de96bbc5 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 @@ -178,12 +180,13 @@ :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)) (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/cmpcond.lsp b/src/cmp/cmpcond.lsp new file mode 100644 index 0000000000000000000000000000000000000000..c16cae49ee0297b0d32809a8cf6c8aeec1aed008 --- /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/cmpct.lsp b/src/cmp/cmpct.lsp index 5d37608b677ea2c6305fd76264bfc1102b159173..09a4265ec073cbfe9742239292d6b7a8918978d2 100644 --- a/src/cmp/cmpct.lsp +++ b/src/cmp/cmpct.lsp @@ -24,15 +24,15 @@ (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)) (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))) @@ -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. @@ -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/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp index 8967c1d64a868e7357a37251d66a74a738919664..8f4aed3fef5e09103a75c6375b66b8976a086477 100644 --- a/src/cmp/cmpenv-api.lsp +++ b/src/cmp/cmpenv-api.lsp @@ -19,86 +19,18 @@ (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*)) (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 ((,(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)) (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)) @@ -109,13 +41,6 @@ the closure in let/flet forms for variables/functions it closes over." (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)) @@ -137,7 +62,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 +79,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) @@ -168,10 +93,6 @@ the closure in let/flet forms for variables/functions it closes over." (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) @@ -211,12 +132,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,14 +149,22 @@ 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)) (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/cmpenv-declaim.lsp b/src/cmp/cmpenv-declaim.lsp index c93efbe0016b235d852459e22d7f16cae6da9b49..4b189b79d241d71737ce0775264de7bd5b2e81ac 100644 --- a/src/cmp/cmpenv-declaim.lsp +++ b/src/cmp/cmpenv-declaim.lsp @@ -20,18 +20,18 @@ ;;;; 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) (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 (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) + 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-declare.lsp b/src/cmp/cmpenv-declare.lsp index a7b6c75bb7f7954e22b50414143ba0321cbedc5b..9e709970f93300ccfec2209ff8d63bdd8dd2da26 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)))) @@ -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) @@ -80,16 +83,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,14 +103,14 @@ 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) (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) @@ -123,7 +126,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 +137,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 +148,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 @@ -168,7 +171,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/cmpenv-fun.lsp b/src/cmp/cmpenv-fun.lsp index 479d31ab999434df49ee40e5d5d15f1ee6e7b35c..0c55a5165f3248bb22cdead8b8af3da105d89451 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))) - (sys: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))) - (sys: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) @@ -131,30 +127,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))) @@ -177,3 +173,50 @@ `(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))) diff --git a/src/cmp/cmpenv-optimize.lsp b/src/cmp/cmpenv-optimize.lsp new file mode 100644 index 0000000000000000000000000000000000000000..7ac1af9d7f3d97be13ee3d2c2cd898d2e84e374a --- /dev/null +++ b/src/cmp/cmpenv-optimize.lsp @@ -0,0 +1,170 @@ + +;;;; 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 the file 'LICENSE' for the copyright details. + +(in-package #:compiler) + +(defun default-policy () + (compute-policy `((space ,*space*) + (safety ,*safety*) + (debug ,*debug*) + (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 + (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* ((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))) + (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)) + + + +;; +;; ERROR CHECKING POLICY +;; + +(define-policy ext:assume-no-errors + "All bets are off." + (:off safety 1)) + +(define-policy-alias ext:assume-right-type + "Don't insert optional runtime type checks for known types." + (:alias ext:assume-no-errors)) + +(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 + "Add a stack check to every function" + (:on safety 2)) + +(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 + "Check out of bounds access to arrays." + (:on safety 1)) + +(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 + "Read the binding of a global function even if it is discarded." + (:on safety 3)) + +(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 + "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 + "Assume that type and class definitions will not change." + (:off safety 1)) + +(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 + "Inline access to object slots, including conses and arrays." + (:off debug 2) + (:off space 2)) + +(define-policy ext:inline-bit-operations + "Inline LDB and similar functions." + (:off space 2)) + +(define-policy-alias ext:open-code-aref/aset + "Inline access to arrays." + (:alias ext:inline-accessors)) + +(define-policy ext:evaluate-forms + "Pre-evaluate a function that takes constant arguments." + (:off debug 1)) + +(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 + "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP, INTGERP, STRINGP." + (:off space 2)) + +(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 + "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!!! + (:requires (policy-debug-ihs-frame env)) + (:on debug 3)) + +(define-policy ext:debug-ihs-frame + "Let the functions appear in backtraces." + (:on debug 3)) diff --git a/src/cmp/cmpenv-proclaim.lsp b/src/cmp/cmpenv-proclaim.lsp index 2d955b1e7c39fe94823c4d4f71cacc6a53e41d7c..de0bcc6f496506e44d9b4a2e1c631fa31adda2d2 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) + (si:*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)) @@ -48,13 +47,13 @@ (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))))))) - (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/cmpenv-var.lsp b/src/cmp/cmpenv-var.lsp new file mode 100644 index 0000000000000000000000000000000000000000..295a97fc59ae3e495acb0775645d12966045e4e7 --- /dev/null +++ b/src/cmp/cmpenv-var.lsp @@ -0,0 +1,64 @@ + +;;;; 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)) + +;;; 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/cmpform.lsp b/src/cmp/cmpform.lsp index d4800579ec37d68531dcd2c29af9dabed65f4ba8..e5ede9ad016ef87d1430c9381529adead3a0713c 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))) @@ -210,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/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 24c62117909524e7902b1c777020096ea40ea227..a3eb614e994d0f6795523fd5e0fa2fa301b77854 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -45,22 +45,22 @@ (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) (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.") -(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 ") @@ -92,15 +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) - -;;; Emit automatic CHECK-TYPE forms for function arguments in lambda forms. -(defvar *automatic-check-type-in-lambda* t) +(defvar *compilation-speed* 2) ;;; ;;; Compiled code uses the following kinds of variables: @@ -125,7 +123,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 +133,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. @@ -165,12 +160,14 @@ 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 @@ -184,7 +181,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*.") @@ -273,13 +270,9 @@ 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 *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 @@ -313,7 +306,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) @@ -322,7 +315,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)) @@ -345,7 +337,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/cmpinline.lsp b/src/cmp/cmpinline.lsp index b0ff9596420737fe1496530be74e24389e934446..086fa9bce2dbc171dd86d01a1c0e30e1561aa383 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/cmplocs.lsp b/src/cmp/cmplocs.lsp new file mode 100644 index 0000000000000000000000000000000000000000..3071c44deb0c49b8ffa7337dccac499870969e83 --- /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/cmpmac.lsp b/src/cmp/cmpmac.lsp deleted file mode 100644 index 2d8f12567d7630bd6f5e4879974dad1543bdd454..0000000000000000000000000000000000000000 --- a/src/cmp/cmpmac.lsp +++ /dev/null @@ -1,117 +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 (truly-the cons elt)) ,arg))) - (first (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 cmpenv.lsp -(defmacro next-cmacro () '(incf *next-cmacro*)) - -;;; 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/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 eff6d6fb2caae516a520f7c8b012d0adb2af5088..1ccb8c698510833fe9ca7831e979804b6c6c3f77 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/cmpmain.lsp b/src/cmp/cmpmain.lsp index f3080a20f2c6038ad5cd0f1bee57d1e4fa2dd288..9fc19afd780742f5254fa0e289e46b0d0bb7e9b6 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 @@ -745,7 +747,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/cmpmap.lsp b/src/cmp/cmpmap.lsp index 7517d68916b6b18f6229241e7b9a7957cc6038c6..16d40a03f06ba8764f69cec3853831071f5d8c5b 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 62c3938da3c77c46fb3b344421f34b6cda59b701..54a59fe67eaeb2c53b99af4c6b9b247ae37debb0 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 6e622b957743d46b0e2982f35f9ffe8155d9086f..88c7d42b36d5513e81e44adadd1e6347f8b53746 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 fbf43a0853eb71dd558c89387bc5f6592ce9c3b5..dba9e7649291129554385d440c6e8aa17e5452b9 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)) @@ -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 259ff8f3e5447a7f81e0fa9a4506e212f0a064bb..e6f793572cd9ce516ed3c1680bf7737204ebff79 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,20 +61,20 @@ ;; 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 (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)) - (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/cmpopt-type.lsp b/src/cmp/cmpopt-type.lsp index ca2904a6ac26bc96cc98e51fa09707c9c5b744ae..b81744971cbe1be4510ecb84f3a18c39e74639a7 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/cmpopt.lsp b/src/cmp/cmpopt.lsp index b591d0ccc16c1f3a9f20969e10ddf20862767ac2..f49f96fabd2d7fbdfb8a667900739f5ad0733524 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/cmpos-features.lsp b/src/cmp/cmpos-features.lsp index 397fded505fb9f34e3fd1854ad3f1d8e68cf8a6f..fab08074eccb0478aba8ca4a31221aea9a327126 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/cmppackage.lsp b/src/cmp/cmppackage.lsp index 0c4737ff029dd537495c6c6faaeebbcbfadd3946..c04e8f213e8e5e5a034ccf5cb809cad512856f32 100644 --- a/src/cmp/cmppackage.lsp +++ b/src/cmp/cmppackage.lsp @@ -16,7 +16,8 @@ (defpackage #:c (:nicknames #:compiler) - (:use #:ffi #:ext #+threads #:mp #:cl) + (:use #:cl) + (:import-from #:ext #:install-c-compiler) (:export ;; Flags controlling the compiler behavior. #:*compiler-break-enable* @@ -51,10 +52,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-call.lsp b/src/cmp/cmppass1-call.lsp index 859049d55817f87b9ad10c7f67c1b3dfc04d8ea6..c282be923c902d8d753e6735a6b5907b1c776688 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) @@ -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) @@ -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) @@ -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-cont.lsp b/src/cmp/cmppass1-cont.lsp index f86d4644fa20c22aeeff5e39f910ec434f1c1794..31f12532ec9b0729aa25d92f54df189706644528 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/cmppass1-data.lsp b/src/cmp/cmppass1-data.lsp index 8f9be28861f05e67dbf1e9e9496902fa1ce75bb5..01bddb9efa098ef2f2812b010bc33100a7f3ac3c 100644 --- a/src/cmp/cmppass1-data.lsp +++ b/src/cmp/cmppass1-data.lsp @@ -86,18 +86,18 @@ *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)) - (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) @@ -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 @@ -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 02aba9676a14964372ac482b705a5ec899e03d98..3a83e76cc3655f9b4ca110d8b76fb2968b6fb062 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*))) @@ -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)))) @@ -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)) @@ -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 d3c19ae3edea4c71c70d962228006c7c5936e987..bc9ffa75de0fffd4bc87d9c1c7401c715612d768 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 @@ -134,7 +133,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/cmppass1-fun.lsp b/src/cmp/cmppass1-fun.lsp index 5f4c0809d5a4cee572b1dd36f526835d208f7d52..9bad5f48018014875edcbd61ce35dfce5655205f 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)))) @@ -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)) @@ -278,14 +280,16 @@ (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) (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-special.lsp b/src/cmp/cmppass1-special.lsp index 0fbd2f9a6ef6d78927e7c39e54b4424fb93338c0..e40b681ae73c8f0a5e1316c7cb79a41a1e65fe61 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,9 +59,9 @@ (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) +(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 8a924cfd6403d16961dbfd66a5e4148a87bde857..ff091691b71ea38da13fa448f1979ecca87a5530 100644 --- a/src/cmp/cmppass1-stack.lsp +++ b/src/cmp/cmppass1-stack.lsp @@ -30,13 +30,14 @@ :args body))) (defun c1innermost-stack-frame (args) - `(c-inline () () :object "_ecl_inner_frame" - :one-liner t :side-effects nil)) + (declare (ignore args)) + `(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 +46,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/cmppass1-top.lsp b/src/cmp/cmppass1-top.lsp index afa374ad2ea38c96bd3e0636b032307052cfc341..22f6df3caa948831ac14e9a6ae30a298b7268c1b 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) @@ -118,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/cmppass1-var.lsp b/src/cmp/cmppass1-var.lsp index 4a3f0bf4af9aa22465be861e6a2fb4fbc52d9f35..1448935a6269c5039bd196c131a8360cc6fb5cb8 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) @@ -111,16 +111,17 @@ (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)))) (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 +236,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 +258,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 +278,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.") @@ -309,7 +297,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 +344,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) @@ -370,11 +358,11 @@ ,@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)) - (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) @@ -402,7 +390,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/cmppass2-call.lsp b/src/cmp/cmppass2-call.lsp index 12187275b588f59ad72343135f6b7da4a9b12a86..34b4cd8a40332cfa7ff3ed51a300987671f47758 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*)) @@ -255,6 +260,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-data.lsp b/src/cmp/cmppass2-data.lsp index a83a54d08269a4513d567f1e8bc5adea2bc2d446..4d518a1b25f91e96908a8b104db8d2d6f01b3e19 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)) @@ -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) @@ -219,14 +219,14 @@ ;; 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))) (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)))))) @@ -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-eval.lsp b/src/cmp/cmppass2-eval.lsp index 90dc8dfe98764c2273f5234217255ea1b0e94ba1..a65e9d15bbfb4486d4f64a591888128ea03e9e60 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-exit.lsp b/src/cmp/cmppass2-exit.lsp index ebb06ad2968a3c1493dcf4621443b0a241b7bbf5..5217d377bb0180599ce5a17fa20308be970fbc5a 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 09d367cf2ec8eb2ec437121c01774db7cbaaca8a..bc36c71406a5ac4fd8ed1f52a9d24821f5b96ec6 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) - (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) - ((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) - (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) - (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) @@ -326,12 +222,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 @@ -378,9 +275,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. @@ -445,6 +342,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 +393,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 a1fa9fd8704e1eaba0561e1df23bba254451c30b..14525bc6337610590abf3d133d6b4f628c39dfab 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 -;;; ( 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) 'C-INLINE) - (eq (sixth loc) '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,19 +36,16 @@ (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))) (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) @@ -217,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 'C-INLINE) - t) ; We do not know, so guess yes - (t nil))) - -(defun values-loc (n) - (list 'VALUE n)) - ;;; ;;; SET-LOC ;;; @@ -290,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 'THE) - (loc-with-side-effects-p (third loc))) - ((eq name 'FDEFINITION) - (policy-global-function-checking)) - ((eq name 'C-INLINE) - (or (eq (sixth loc) '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-special.lsp b/src/cmp/cmppass2-special.lsp index ec6809a7096396e589a948e2e4538d75f8d66a24..35f36437518d14e533f6a58e2ae92aa475c7529f 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 8ba0c8c4c20325f385326289ea34a34ca41a14bc..9af4d6535d6efb009f44e296d272afeb415ca787 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)) @@ -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) @@ -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)) @@ -473,9 +475,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 90ea49af4380ad86b00550ae548b4d782b70dbc0..ae1ec2e095c1c189d39b7268d0781d587e2f175f 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)) @@ -281,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 @@ -300,6 +303,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)) diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index 981b3251e97f406dcce58c2bf62272528fd1844d..4670186b4f5317272dd66460a52d7ebc0edf504d 100644 --- a/src/cmp/cmppolicy.lsp +++ b/src/cmp/cmppolicy.lsp @@ -3,323 +3,214 @@ ;;;; ;;;; 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") -(eval-when (:compile-toplevel :execute) - (defconstant +optimization-quality-orders+ '(debug safety speed space))) +;;; +;;; 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). +;;; + +(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) - (defparameter *optimization-quality-switches* + (defvar *last-optimization-bit* 20) + (defvar *optimization-quality-switches* + (loop with hash = (make-hash-table :size 64 :test #'eq) + 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 + for bits = (ash 1 (+ level i)) + collect (cons bits (logxor bits mask))) + do (setf (gethash name hash) list) + finally (return hash))) + ;; 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 +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#))) + for name in *standard-optimization-quality-names* + for i from 0 by 4 + do (setf (gethash name hash) i) + finally (return hash)))) -#.`(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 (declaration ext:assume-right-type)) - (loop for level from 0 to 3 - when (logbitp (+ level ,i) policy) - return level)))) +(eval-when (:load-toplevel :execute) + (defvar *last-optimization-bit* #.*last-optimization-bit*) + (defvar *optimization-quality-switches* #.*optimization-quality-switches*) + (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*))) -(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) + (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)))))) (dolist (x arguments) - (let (flags name value) - (cond ((symbolp x) - (setq flags (optimization-quality-switches x 3) - value 3 - name x)) - ((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 (second x))))) - (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))) - -(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))) - -(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))) - (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 - (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) - (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)) - (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+) + (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)) + +(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)) + (find-package "C"))) + +(defmacro define-policy (&whole whole name &rest conditions) + (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. + (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-standard-policy quality level op test))) + ((:only-on :only-off) + (destructuring-bind (op quality) case + (augment-extended-policy quality op test))) + (:requires + (destructuring-bind (op form) case + (declare (ignore op)) + (push form 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)))))))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - -;; -;; ERROR CHECKING POLICY -;; - -(define-policy assume-no-errors :off safety 1) - -(define-policy assume-right-type :alias assume-no-errors) - -(define-policy type-assertions :anti-alias assume-no-errors - "Generate type assertions when inlining accessors and other functions.") - -(define-policy check-stack-overflow :on safety 2 - "Add a stack check to every function") - -(define-policy check-arguments-type :on safety 1 - "Generate CHECK-TYPE forms for function arguments with type declarations") - -(define-policy array-bounds-check :on safety 1 - "Check out of bounds access to arrays") - -(define-policy 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 - "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 - "Check that the number of arguments a function receives is within bounds") - -(define-policy 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 - "Assume that type and class definitions will not change") - -(define-policy 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 - "Inline access to object slots, including conses and arrays") - -(define-policy inline-bit-operations :off space 2 - "Inline LDB and similar functions") - -(define-policy open-code-aref/aset :alias inline-accessors - "Inline access to arrays") - -(define-policy evaluate-forms :off debug 1 - "Pre-evaluate a function that takes constant arguments") - -(define-policy 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 - "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP, -INTGERP, STRINGP.") - -(define-policy inline-sequence-functions :off space 2 - "Inline functions such as MAP, MEMBER, FIND, etc") - -;; -;; DEBUG POLICY -;; - -(define-policy 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 - "Let the functions appear in backtraces") - -); eval-when - -(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*)) + ,@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 + (setf (gethash name *optimization-quality-switches*) (reverse 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) + (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-function policy-to-compilation-speed-level 16)) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 1ff327d6a21fe4f11c8ab80744c70924488640d5..8cbce8b8b2abce6eeab958f8b494e88d3914f6c1 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) @@ -37,7 +39,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)) @@ -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/cmprefs.lsp b/src/cmp/cmprefs.lsp new file mode 100644 index 0000000000000000000000000000000000000000..008261956a8a5906bf0fdd538c3de1051b93f044 --- /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/cmpstructures.lsp b/src/cmp/cmpstructures.lsp index 68755afa82cedcbc0520bc560a2b281ef1ab3432..78d6e7b8430fee8ace6cd93e1182b81e2a6f2d58 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)) @@ -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 e649bf8834fb355b188de4123c38d3b0a4b7ae5b..bcbd32e0d0b6fc54485cf64d86e5bacaa42cc403 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) - (compiler-let . c1compiler-let) - (eval-when . c1eval-when) - (progn . c1progn) - (macrolet . c1macrolet) - (locally . c1locally) - (symbol-macrolet . c1symbol-macrolet) + (cl:defmacro . t1defmacro) + (ext:compiler-let . c1compiler-let) + (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) (ext: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+ - '((compiler-let . t2compiler-let) - (progn . t2progn) + '((ext:compiler-let . t2compiler-let) + (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/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp index 6c725892665c595155e68231e2dbd0833efe09fe..22c5e0cfb2d59376bfb0975311c2afa6c1f76f66 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 diff --git a/src/cmp/cmptype-assert.lsp b/src/cmp/cmptype-assert.lsp index be8fc7cd68aede00c5d41e47ecf37a3b59075adb..a449d9d3f4301ec4526c39f79fa2972306043b6c 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))))))) @@ -143,15 +143,15 @@ 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) (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) +(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 8289213724e9cb5f39d6907dbc3dd943578ebfe7..55132af6bf3111fe5b078cc4716602ccc1685e18 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 @@ -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) @@ -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 @@ -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))) diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp index 369ac8ef1729c788f6e94f3c6c395f2de373c162..053bc99c7df7a37a04e8325f8b887f1fa9b022d8 100644 --- a/src/cmp/cmptypes.lsp +++ b/src/cmp/cmptypes.lsp @@ -16,168 +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. - (index -1) ;;; position in *vars*. Used by similar. - (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. @@ -186,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)) @@ -212,26 +37,28 @@ (file nil) (file-position 0)) -(defstruct vv - (location nil) - (used-p nil) - (permanent-p t) - (value nil)) +(defun print-c1form (form stream) + (format stream "#" (c1form-name form) (si:pointer form))) -(defstruct machine - (c-types '()) - rep-type-hash - sorted-types - inline-information) +(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 (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)) +(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 614e99700e37555ad13f4b145fad2228f5d9e649..02d3fc2bd6152e104931b35cc74431d81368d9bd 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. @@ -40,9 +27,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 @@ -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)) @@ -211,51 +73,13 @@ (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)))) (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 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. @@ -270,17 +94,16 @@ (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)) - (let ((l (safe-list-length args))) (when (null l) (let ((*print-circle* t)) @@ -290,39 +113,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) @@ -331,32 +121,9 @@ (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 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) @@ -367,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))) @@ -511,13 +272,13 @@ 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)))) ;; 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 @@ -680,3 +441,116 @@ 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 + (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)) + (cache ,cache-name) + (elt (aref cache hash))) + (declare (type (integer 0 1023) hash) + (type (array t (*)) cache)) + (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))) + +(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 + (unless (eq ,label *exit*) + (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*)))) + +(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 e7c204948b9e070e5c490fd4ff6bd4a3db176350..40ca8d8de79e08087ff4e9d7c7b441498a5a891a 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -14,23 +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. - (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) @@ -99,6 +82,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)))) @@ -108,7 +104,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 @@ -200,46 +196,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) @@ -257,10 +213,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))) @@ -276,7 +228,3 @@ (defun useful-var-p (var) (or (plusp (var-ref var)) (global-var-p var))) - -(defun si::register-global (name) - (pushnew name *global-vars*) - (values)) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 9ae9f59b9ab3a476d87b837396af5df70c81b5cb..357b4183cc5999b7b4af85808711885d17ed8808 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -5,29 +5,34 @@ '("src:cmp;cmppackage.lsp" "src:cmp;cmpglobals.lsp" "build:cmp;cmpdefs.lsp" - "src:cmp;cmpmac.lsp" "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" ;; 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;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-arith.lsp" "src:cmp;cmptype-prop.lsp" "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 diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 97d663b0ff008021f6ece94d5c067d05974b612e..849258d6cd84f84ea350424f6664f0a8240bee21 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))))) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 8ff029cc414b08367396f288196400c82dd8a989..7204932c5b0e283bd7f3bfff4d41cf69c305642c 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.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)") + +(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.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)") + +(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") diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index d66315c31b821b6b229b4c6aa3436e21e9cf44de..a9228631e060a379e966c0a56eed7505b6919975 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*