mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-15 01:10:53 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'cmpwerk' into 'develop'

Browse source 
Separate COMPILER and EXT,FFI,MP packages

See merge request embeddable-common-lisp/ecl!285
This commit is contained in:
Marius Gerbershagen 2023-03-12 15:31:36 +00:00
commit ae19006cb8
66 changed files with 2408 additions and 2310 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/c/compiler.d
View file

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

26
src/c/symbols_list.h
View file

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

2
src/clos/method.lsp
View file

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

2
src/clos/stdmethod.lsp
View file

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

32
src/cmp/cmparray.lsp
View file

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

4
src/cmp/cmpc-inliner.lsp
View file

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

11
src/cmp/cmpc-wt.lsp
View file

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

212
src/cmp/cmpcond.lsp Normal file
View file

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

88
src/cmp/cmpct.lsp
View file

@ -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")
`((cl:most-positive-short-float "FLT_MAX")
(cl:most-positive-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")
(cl:most-negative-short-float "-FLT_MAX")
(cl:most-negative-single-float "-FLT_MAX")
(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")
(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")
(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: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")
,@'((ext:short-float-positive-infinity "INFINITY")
(ext:single-float-positive-infinity "INFINITY")
(ext:double-float-positive-infinity "INFINITY")
(SHORT-FLOAT-NEGATIVE-INFINITY "-INFINITY")
(SINGLE-FLOAT-NEGATIVE-INFINITY "-INFINITY")
(DOUBLE-FLOAT-NEGATIVE-INFINITY "-INFINITY"))
(ext:short-float-negative-infinity "-INFINITY")
(ext:single-float-negative-infinity "-INFINITY")
(ext: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")
,@'((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"))))))

103
src/cmp/cmpenv-api.lsp
View file

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

8
src/cmp/cmpenv-declaim.lsp
View file

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

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

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

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

@ -64,37 +64,33 @@
env)
(defun get-arg-types (fname &optional (env *cmp-env*) (may-be-global t))
(let ((x (cmp-env-search-ftype fname env)))
(if x
(let ((arg-types (first x)))
(unless (eq arg-types '*)
(values arg-types t)))
(when may-be-global
(let ((fun (cmp-env-search-function fname env)))
(when (or (null fun) (and (fun-p fun) (fun-global fun)))
(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)))

170
src/cmp/cmpenv-optimize.lsp Normal file
View file

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

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

@ -25,17 +25,16 @@
(in-package #-ecl-new "COMPILER" #+ecl-new "C-ENV")
#-:CCL
(defun proclaim (decl &aux decl-name)
(unless (listp decl)
(error "The proclamation specification ~s is not a list" decl))
(case (setf decl-name (car decl))
(SPECIAL
(cl:SPECIAL
(dolist (var (cdr decl))
(if (symbolp var)
(sys:*make-special var)
(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*))

64
src/cmp/cmpenv-var.lsp Normal file
View file

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

9
src/cmp/cmpform.lsp
View file

@ -26,9 +26,6 @@
;;; lambda-list = (requireds optionals rest key-flag keywords allow-other-keys)
;;;
(defun print-c1form (form stream)
(format stream "#<form ~A ~X>" (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

40
src/cmp/cmpglobals.lsp
View file

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

8
src/cmp/cmpinline.lsp
View file

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

249
src/cmp/cmplocs.lsp Normal file
View file

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

117
src/cmp/cmpmac.lsp
View file

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

73
src/cmp/cmpc-machine.lsp → src/cmp/cmpmach.lsp
View file

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

8
src/cmp/cmpmain.lsp
View file

@ -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 <ecl/ecl.h>
@ -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.

2
src/cmp/cmpmap.lsp
View file

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

12
src/cmp/cmpnum.lsp
View file

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

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

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

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

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

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

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

3
src/cmp/cmpopt-type.lsp
View file

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

6
src/cmp/cmpopt.lsp
View file

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

1
src/cmp/cmpos-features.lsp
View file

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

9
src/cmp/cmppackage.lsp
View file

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

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

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

30
src/cmp/cmppass1-cont.lsp
View file

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

12
src/cmp/cmppass1-data.lsp
View file

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

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

@ -30,7 +30,7 @@
(c1var form)))
(t (c1var form))))
((consp form)
(cmpck (not (si::proper-list-p form))
(cmpck (not (si:proper-list-p form))
"Improper list found in lisp form~%~A" form)
(let ((fun (car form)))
(cond ((let ((fd (gethash fun *c1-dispatch-table*)))
@ -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 <float.h>" *clines-string-list*)
(pushnew "#include <complex.h>" *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)

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

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

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

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

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

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

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

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

3
src/cmp/cmppass1-top.lsp
View file

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

38
src/cmp/cmppass1-var.lsp
View file

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

6
src/cmp/cmppass2-call.lsp
View file

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

23
src/cmp/cmppass2-data.lsp
View file

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

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

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

4
src/cmp/cmppass2-exit.lsp
View file

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

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

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

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

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

13
src/cmp/cmppass2-special.lsp
View file

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

10
src/cmp/cmppass2-top.lsp
View file

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

6
src/cmp/cmppass2-var.lsp
View file

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

473
src/cmp/cmppolicy.lsp
View file

@ -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 +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
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 *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)))
(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 default-policy ()
(compute-policy `((space ,*space*)
(safety ,*safety*)
(debug ,*debug*)
(speed ,*speed*))
0))
(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 cmp-env-policy (env)
(or (first (cmp-env-search-declaration 'optimization env))
(default-policy)))
(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 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 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-declaration-name-p (name)
(and (gethash name *optimization-quality-switches*) t))
(defun policy-function-name (base)
(intern (concatenate 'string "POLICY-" (symbol-name base))
(find-package "C")))
(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+)
(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))))))))))
,@extra)))))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(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)))))))
;;
;; 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*))
(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))

176
src/cmp/cmpprop.lsp
View file

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

180
src/cmp/cmprefs.lsp Normal file
View file

@ -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 "#<a ~A: ~A>" (type-of ref-object) name)
(format stream "#<a ~A>" (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 "#<a VAR: ~A KIND: ~A>" (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.
)

6
src/cmp/cmpstructures.lsp
View file

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

250
src/cmp/cmptables.lsp
View file

@ -19,55 +19,55 @@
(defconstant +all-c1-forms+
'((LOCATION loc :pure :single-valued)
(VAR var :single-valued)
(SETQ var value-c1form :side-effects)
(PSETQ var-list value-c1form-list :side-effects)
(BLOCK blk-var progn-c1form :pure)
(PROGN body :pure)
(PROGV symbols values form :side-effects)
(TAGBODY tag-var tag-body :pure)
(RETURN-FROM blk-var return-type value :side-effects)
(FUNCALL fun-value (arg-value*) :side-effects)
(cl:SETQ var value-c1form :side-effects)
(cl:PSETQ var-list value-c1form-list :side-effects)
(cl:BLOCK blk-var progn-c1form :pure)
(cl:PROGN body :pure)
(cl:PROGV symbols values form :side-effects)
(cl:TAGBODY tag-var tag-body :pure)
(cl:RETURN-FROM blk-var return-type value :side-effects)
(cl:FUNCALL fun-value (arg-value*) :side-effects)
(CALL-LOCAL obj-fun (arg-value*) :side-effects)
(CALL-GLOBAL fun-name (arg-value*))
(CATCH catch-value body :side-effects)
(UNWIND-PROTECT protected-c1form body :side-effects)
(THROW catch-value output-value :side-effects)
(GO tag-var return-type :side-effects)
(C-INLINE (arg-c1form*)
(cl:CATCH catch-value body :side-effects)
(cl:UNWIND-PROTECT protected-c1form body :side-effects)
(cl:THROW catch-value output-value :side-effects)
(cl:GO tag-var return-type :side-effects)
(ffi:C-INLINE (arg-c1form*)
(arg-type-symbol*)
output-rep-type
c-expression-string
side-effects-p
one-liner-p)
(C-PROGN variables forms)
(ffi:C-PROGN variables forms)
(LOCALS local-fun-list body labels-p :pure)
(IF fmla-c1form true-c1form false-c1form :pure)
(cl:IF fmla-c1form true-c1form false-c1form :pure)
(FMLA-NOT fmla-c1form :pure)
(FMLA-AND * :pure)
(FMLA-OR * :pure)
(LAMBDA lambda-list doc body-c1form)
(LET* vars-list var-init-c1form-list decl-body-c1form :pure)
(VALUES values-c1form-list :pure)
(MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects)
(MULTIPLE-VALUE-BIND vars-list init-c1form body :pure)
(COMPILER-LET symbols values body)
(FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued)
(RPLACD (dest-c1form value-c1form) :side-effects)
(cl:LAMBDA lambda-list doc body-c1form)
(cl:LET* vars-list var-init-c1form-list decl-body-c1form :pure)
(cl:VALUES values-c1form-list :pure)
(cl:MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects)
(cl:MULTIPLE-VALUE-BIND vars-list init-c1form body :pure)
(ext:COMPILER-LET symbols values body)
(cl:FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued)
(cl:RPLACD (dest-c1form value-c1form) :side-effects)
(SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure)
(SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects)
(WITH-STACK body :side-effects)
(STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects)
(STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects)
(ORDINARY c1form :pure)
(LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued)
(cl:LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued)
(SI:FSET function-object vv-loc macro-p pprint-p lambda-form
:side-effects)
(MAKE-FORM vv-loc value-c1form :side-effects)
(INIT-FORM vv-loc value-c1form :side-effects)
(EXT:COMPILER-TYPECASE var expressions)
(CHECKED-VALUE type value-c1form let-form))))
(ext:COMPILER-TYPECASE var expressions)
(ext:CHECKED-VALUE type value-c1form let-form))))
(defconstant +c1-form-hash+
#.(loop with hash = (make-hash-table :size 128 :test #'eq)
@ -86,47 +86,47 @@
finally (return hash)))
(defconstant +c1-dispatch-alist+
'((block . c1block) ; c1special
(return-from . c1return-from) ; c1special
(funcall . c1funcall) ; c1
(catch . c1catch) ; c1special
(unwind-protect . c1unwind-protect) ; c1special
(throw . c1throw) ; c1special
'((cl:block . c1block) ; c1special
(cl:return-from . c1return-from) ; c1special
(cl:funcall . c1funcall) ; c1
(cl:catch . c1catch) ; c1special
(cl:unwind-protect . c1unwind-protect) ; c1special
(cl:throw . c1throw) ; c1special
(ffi:defcallback . c1-defcallback) ; c1
(progn . c1progn) ; c1special
(cl:progn . c1progn) ; c1special
(ext:with-backend . c1with-backend) ; c1special
(ffi:clines . c1clines) ; c1special
(ffi:c-inline . c1c-inline) ; c1special
(ffi:c-progn . c1c-progn) ; c1special
(flet . c1flet) ; c1special
(labels . c1labels) ; c1special
(locally . c1locally) ; c1special
(macrolet . c1macrolet) ; c1special
(symbol-macrolet . c1symbol-macrolet) ; c1special
(cl:flet . c1flet) ; c1special
(cl:labels . c1labels) ; c1special
(cl:locally . c1locally) ; c1special
(cl:macrolet . c1macrolet) ; c1special
(cl:symbol-macrolet . c1symbol-macrolet) ; c1special
(if . c1if) ; c1special
(not . c1not) ; c1special
(and . c1and) ; c1special
(or . c1or) ; c1special
(cl:if . c1if) ; c1special
(cl:not . c1not) ; c1special
(cl:and . c1and) ; c1special
(cl:or . c1or) ; c1special
(let . c1let) ; c1special
(let* . c1let*) ; c1special
(cl:let . c1let) ; c1special
(cl:let* . c1let*) ; c1special
(multiple-value-call . c1multiple-value-call) ; c1special
(multiple-value-prog1 . c1multiple-value-prog1) ; c1special
(values . c1values) ; c1
(multiple-value-setq . c1multiple-value-setq) ; c1
(multiple-value-bind . c1multiple-value-bind) ; c1
(cl:multiple-value-call . c1multiple-value-call) ; c1special
(cl:multiple-value-prog1 . c1multiple-value-prog1) ; c1special
(cl:values . c1values) ; c1
(cl:multiple-value-setq . c1multiple-value-setq) ; c1
(cl:multiple-value-bind . c1multiple-value-bind) ; c1
(ext:compiler-typecase . c1compiler-typecase) ; c1special
(checked-value . c1checked-value) ; c1special
(ext:checked-value . c1checked-value) ; c1special
(quote . c1quote) ; c1special
(function . c1function) ; c1special
(the . c1the) ; c1special
(cl:quote . c1quote) ; c1special
(cl:function . c1function) ; c1special
(cl:the . c1the) ; c1special
(ext:truly-the . c1truly-the) ; c1special
(eval-when . c1eval-when) ; c1special
(declare . c1declare) ; c1special
(cl:eval-when . c1eval-when) ; c1special
(cl:declare . c1declare) ; c1special
(ext:compiler-let . c1compiler-let) ; c1special
(with-stack . c1with-stack) ; c1
@ -134,30 +134,30 @@
(stack-push . c1stack-push) ; c1
(stack-push-values . c1stack-push-values) ; c1
(stack-pop . c1stack-pop) ; c1
(si::apply-from-stack-frame . c1apply-from-stack-frame) ; c1
(si:apply-from-stack-frame . c1apply-from-stack-frame) ; c1
(tagbody . c1tagbody) ; c1special
(go . c1go) ; c1special
(cl:tagbody . c1tagbody) ; c1special
(cl:go . c1go) ; c1special
(setq . c1setq) ; c1special
(progv . c1progv) ; c1special
(psetq . c1psetq) ; c1special
(cl:setq . c1setq) ; c1special
(cl:progv . c1progv) ; c1special
(cl:psetq . c1psetq) ; c1special
(load-time-value . c1load-time-value) ; c1
(cl:load-time-value . c1load-time-value) ; c1
(apply . c1apply) ; c1
(cl:apply . c1apply) ; c1
))
(defconstant +t1-dispatch-alist+
'((ext:with-backend . c1with-backend) ; t1
(defmacro . t1defmacro)
(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)

13
src/cmp/cmptype-arith.lsp
View file

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

14
src/cmp/cmptype-assert.lsp
View file

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

11
src/cmp/cmptype.lsp
View file

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

219
src/cmp/cmptypes.lsp
View file

@ -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 "#<form ~A ~X>" (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
)

374
src/cmp/cmputil.lsp
View file

@ -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 "#<a ~A: ~A>" (type-of ref-object) name)
(format stream "#<a ~A>" (type-of ref-object)))))
(defun print-var (var-object stream)
(format stream "#<a VAR: ~A KIND: ~A>" (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))))))

80
src/cmp/cmpvar.lsp
View file

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

15
src/cmp/load.lsp.in
View file

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

10
src/cmp/proclamations.lsp
View file

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

850
src/cmp/sysfun.lsp
View file

File diff suppressed because it is too large Load diff

2
src/lsp/evalmacros.lsp
View file

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