mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-30 04:10:44 -08:00
Code Issues Projects Releases Packages Wiki Activity

Refactored code so that it is shared by cmp and new-cmp:

Browse source 
* Use the new proclamations/sysfun.lsp files from the new compiler.
* We split src/cmp/cmpdefs.lsp into cmpdefs, cmppackage, cmptypes and cmpglobals
* Split cmpform.lsp out of cmpmac.lsp
* Merged in {cmp,new-cmp}/cmpc-wt.lsp some of the cmpmac wt routines
* Use functions instead of macros for the WT-* operations
* Split out from *cmp/cmpenv.lsp a file cmppolicy.lsp
* A single file, cmpenv-api.lsp for the manipulation of environments.
* The type comparison functions go into cmptype-arith.lsp and are cached.
* The code that propagates types in function calls goes into cmptype-prop.lsp.
* The remainings of cmpenv go into cmpenv-{declare,proclaim,declaim}.

Associated fixes:
* Fixed typo and wrong proclamation for SI:GET-SYSPROP.
* Fixed typo in SIMPLIFY-ARITHMETIC.
* Explicitely set the debug level when building ECL
* All declarations are stored in the compiler environment.
* Each function and form stores the compilation environment.
* Declaration POLICY-DEBUG-IHS-FRAME is acts only on the function environment.
* Make the definition if ihs_env only happen when it is used.
* Eliminated *notinline*, *inline-functions*  and *function-declarations*
* Slightly more efficient creation of accessors in kernel.lsp
* Remove the proxy C2DECL-BODY
* Fix the order of declarations in SI:PROCESS-DECLARATIONS
* Reimplemented C1BODY using SI:PROCESS-DECLARATIONS
* DECLAIM's proclamation do not propagate beyond the compiled file.
This commit is contained in:
Juan Jose Garcia Ripoll 2010-05-01 11:07:34 +02:00
parent 77afbfd6da
commit 6a91d3b45a
47 changed files with 1825 additions and 5668 deletions
Download patch file Download diff file Expand all files Collapse all files

1
src/CHANGELOG
View file

@ -41,6 +41,7 @@ ECL 10.4.2:
- The compiler is now shipped as a single FASL file, cmp.fas, without
extra files such as sysfun.lsp
- DECLAIM's proclamation do not propagate beyond the compiled file.
ECL 10.4.1:
===========

2
src/bare.lsp.in
View file

@ -145,7 +145,7 @@
(defun build-module (name sources &key additional-files
(builtin nil) (dir "build:")
((:prefix si::*init-function-prefix*) "EXT"))
(proclaim '(optimize (safety 2) (speed 1)))
(proclaim '(optimize (safety 2) (speed 1) (debug 1)))
(let* ((name (string-downcase name)))
(when additional-files
(setf *module-files* (append additional-files *module-files*)))

1
src/c/compiler.d
View file

@ -2418,6 +2418,7 @@ c_listA(cl_env_ptr env, cl_object args, int flags)
}
/* END: SEARCH DECLARE */
declarations = cl_nreverse(declarations);
@(return declarations body documentation specials)
@)

11
src/clos/kernel.lsp
View file

@ -31,9 +31,11 @@
(defun create-accessors (slotds type)
(let ((i 0)
(output '())
(names '())
name)
(dolist (s slotds `(progn ,@output))
(dolist (s slotds)
(when (setf name (getf (cdr s) :accessor))
(push name names)
(setf output
(append output
`((defun ,name (obj)
@ -44,7 +46,12 @@
(define-compiler-macro ,name (obj)
`(si:instance-ref ,obj ,,i))
))))
(incf i))))
(incf i))
`(progn
#+nil
(eval-when (:compile-toplevel :execute)
(proclaim '(notinline ,@names)))
,@output)))
(defun remove-accessors (slotds)
(loop for i in slotds
for j = (copy-list i)

140
src/new-cmp/cmpc-wt.lsp → src/cmp/cmpc-wt.lsp
View file

@ -1,7 +1,6 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; 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
@ -9,43 +8,76 @@
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
;;;;
;;;; CMPC-WT -- Routines for writing code to C files.
;;;;
;;;; CMPWT -- Routines for writing code to C files.
(in-package #-new-cmp "COMPILER" #+new-cmp "C-BACKEND")
(in-package "C-BACKEND")
(defun wt1 (form)
(typecase form
((or STRING INTEGER CHARACTER)
(princ form *compiler-output1*))
((or DOUBLE-FLOAT SINGLE-FLOAT)
(format *compiler-output1* "~10,,,,,,'eG" form))
(LONG-FLOAT
(format *compiler-output1* "~,,,,,,'eEl" form))
(VAR (wt-var form))
(t (wt-loc form)))
nil)
(defvar *wt-string-size* 0)
(defun wt-h1 (form)
(if (consp form)
(let ((fun (get-sysprop (car form) 'wt-loc)))
(if fun
(let ((*compiler-output1* *compiler-output2*))
(apply fun (cdr form)))
(cmperr "The location ~s is undefined." form)))
(princ form *compiler-output2*))
nil)
;;; from cmpwt.lsp
(defmacro wt (&rest forms &aux (fl nil))
(dolist (form forms `(progn ,@(nreverse (cons nil fl))))
(if (stringp form)
(push `(princ ,form *compiler-output1*) fl)
(push `(wt1 ,form) fl))))
(defun wt (&rest forms)
(mapc #'wt1 forms))
(defmacro wt-h (&rest forms &aux (fl nil))
(dolist (form forms `(progn ,@(nreverse (cons nil fl))))
(if (stringp form)
(push `(princ ,form *compiler-output2*) fl)
(push `(wt-h1 ,form) fl))))
(defun wt-h (&rest forms)
(mapc #'wt-h1 forms))
(defmacro wt-nl-h (&rest forms)
`(progn (terpri *compiler-output2*) (wt-h ,@forms)))
(defun wt-nl-h (&rest forms)
(terpri *compiler-output2*)
(mapc #'wt-h1 forms))
(defmacro princ-h (form) `(princ ,form *compiler-output2*))
(defun princ-h (form)
(princ form *compiler-output2*))
(defmacro wt-nl (&rest forms)
`(wt #\Newline #\Tab ,@forms))
(defun wt-nl (&rest forms)
(wt1 #\Newline)
(wt1 #\Tab)
(mapc #'wt1 forms))
(defmacro wt-nl1 (&rest forms)
`(wt #\Newline ,@forms))
(defun wt-nl1 (&rest forms)
(wt1 #\Newline)
(mapc #'wt1 forms))
(defmacro wt-go (label)
`(wt "goto L" ,label ";"))
;;;
;;; LABELS AND JUMPS
;;;
(defun wt-go (label)
#-new-cmp
(setf (cdr label) t
label (car label))
(wt "goto L" label ";"))
(defun wt-label (label)
#-new-cmp
(when (cdr label) (wt-nl1 "L" (car label) ":;"))
#+new-cmp
(wt-nl1 "L" label ":;"))
;;;
;;; C/C++ COMMENTS
;;;
(defun wt-filtered-comment (text stream single-line)
(declare (string text))
(if single-line
@ -80,24 +112,42 @@
(defun wt-comment-nl (message &rest extra)
(do-wt-comment message extra t))
(defun wt1 (form)
(typecase form
((or STRING INTEGER CHARACTER)
(princ form *compiler-output1*))
((or DOUBLE-FLOAT SINGLE-FLOAT)
(format *compiler-output1* "~10,,,,,,'eG" form))
(LONG-FLOAT
(format *compiler-output1* "~,,,,,,'eEl" form))
(VAR (wt-var form))
(t (wt-loc form)))
nil)
;;;
;;; STRINGS
;;;
;;; This routine converts lisp data into C-strings. We have to take
;;; care of escaping special characteres with backslashes. We also have
;;; to split long lines using the fact that multiple strings are joined
;;; together by the compiler.
;;;
(defvar *wt-string-size* 0)
(defun wt-filtered-data (string stream &optional one-liner)
(let ((N (length string))
(wt-data-column 80))
(incf *wt-string-size* (1+ N)) ; 1+ accounts for a blank space
(format stream (if one-liner "\"" "~%\""))
(dotimes (i N)
(decf wt-data-column)
(when (< wt-data-column 0)
(format stream "\"~% \"")
(setq wt-data-column 79))
(let ((x (aref string i)))
(cond
((or (< (char-code x) 32)
(> (char-code x) 127))
(case x
; We avoid a trailing backslash+newline because some preprocessors
; remove them.
(#\Newline (princ "\\n" stream))
(#\Tab (princ "\\t" stream))
(t (format stream "\\~3,'0o" (char-code x)))))
((char= x #\\)
(princ "\\\\" stream))
((char= x #\")
(princ "\\\"" stream))
(t (princ x stream)))))
(princ (if one-liner "\"" " \"") stream)
string))
(defun wt-h1 (form)
(if (consp form)
(let ((fun (get-sysprop (car form) 'wt-loc)))
(if fun
(let ((*compiler-output1* *compiler-output2*))
(apply fun (cdr form)))
(cmperr "The location ~s is undefined." form)))
(princ form *compiler-output2*))
nil)

4
src/cmp/cmpcall.lsp
View file

@ -125,7 +125,7 @@
;; Call to a function defined in the same file. Direct calls are
;; only emitted for low or neutral values of DEBUG is >= 2.
(when (and (<= (cmp-env-optimization 'debug) 1)
(when (and (policy-use-direct-C-call)
(or (fun-p fun)
(and (null fun)
(setf fun (find fname *global-funs* :test #'same-fname-p
@ -139,7 +139,7 @@
;; Call to a function whose C language function name is known,
;; either because it has been proclaimed so, or because it belongs
;; to the runtime.
(when (and (<= (cmp-env-optimization 'debug) 1)
(when (and (policy-use-direct-C-call)
(setf fd (get-sysprop fname 'Lfun)))
(multiple-value-bind (minarg maxarg) (get-proclaimed-narg fname)
(return-from call-global-loc

5
src/cmp/cmpcatch.lsp
View file

@ -49,9 +49,8 @@
(defun c1unwind-protect (args)
(check-args-number 'UNWIND-PROTECT args 1)
(incf *setjmps*)
(let (form)
(let ((*cmp-env* (cmp-env-mark 'UNWIND-PROTECT)))
(setq form (c1expr (first args))))
(let ((form (let ((*cmp-env* (cmp-env-mark 'UNWIND-PROTECT)))
(c1expr (first args)))))
(make-c1form* 'UNWIND-PROTECT :type (c1form-type form) :sp-change t
:args form (c1progn (rest args)))))

521
src/cmp/cmpdefs.lsp
View file

@ -1,7 +1,6 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; 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
@ -10,434 +9,10 @@
;;;;
;;;; See file '../Copyright' for full details.
;;;; CMPDEF Definitions
(si::package-lock "CL" nil)
(defpackage "C"
(:nicknames "COMPILER")
(:use "FFI" "CL" #+threads "MP")
(:export "*COMPILER-BREAK-ENABLE*"
"*COMPILE-PRINT*"
"*COMPILE-TO-LINKING-CALL*"
"*COMPILE-VERBOSE*"
"*CC*"
"*CC-OPTIMIZE*"
"*USER-CC-FLAGS*"
"*USER-LD-FLAGS*"
"*SUPPRESS-COMPILER-NOTES*"
"*SUPPRESS-COMPILER-WARNINGS*"
"*SUPPRESS-COMPILER-MESSAGES*"
"BUILD-ECL"
"BUILD-PROGRAM"
"BUILD-FASL"
"BUILD-STATIC-LIBRARY"
"BUILD-SHARED-LIBRARY"
"COMPILER-WARNING"
"COMPILER-NOTE"
"COMPILER-MESSAGE"
"COMPILER-ERROR"
"COMPILER-FATAL-ERROR"
"COMPILER-INTERNAL-ERROR"
"COMPILER-UNDEFINED-VARIABLE"
"COMPILER-MESSAGE-FILE"
"COMPILER-MESSAGE-FILE-POSITION"
"COMPILER-MESSAGE-FORM"
"*SUPPRESS-COMPILER-WARNINGS*"
"*SUPPRESS-COMPILER-NOTES*"
"*SUPPRESS-COMPILER-MESSAGES*")
(:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO"
"*COMPILER-CONSTANTS*" "REGISTER-GLOBAL" "CMP-ENV-REGISTER-MACROLET"
"COMPILER-LET"))
;;;; CMPDEF -- Definitions created at compile / configuration time
(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.
;;; During Pass1, T or NIL.
;;; During Pass2, the index into the closure env
ref-clb ;;; Cross local function reference.
;;; During Pass1, T or NIL.
;;; During Pass2, the lex-address for the
;;; block id, 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, :FIXNUM,
;;; :CHAR, :DOUBLE, :FLOAT, or REPLACED (used for
;;; LET variables).
(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 REPLACED: the actual location of the variable.
;;; 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 referred 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 referred 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 referred
;;; 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-referred-vars and info-local-referred of its body.
;;; A LISP_CFUN or LISP_CLOSURE must be created when the function is returned.
;;; The LISP funob may then be referred locally or across LB or CB:
;;; (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.
;;; During Pass1, T or NIL, depending on whether a
;;; function object will be built.
;;; During Pass2, the vs-address for the function
;;; closure, 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.
(minarg 0) ;;; Min. number arguments that the function receives.
(maxarg call-arguments-limit)
;;; Max. number arguments that the function receives.
(parent *current-function*)
;;; Parent function, NIL if global.
(local-vars nil) ;;; List of local variables created here.
(referred-vars nil) ;;; List of external variables referenced here.
(referred-funs nil) ;;; List of external functions called in this one.
;;; We only register direct calls, not calls via object.
(child-funs nil) ;;; List of local functions defined here.
(debug 0) ;;; Debug quality
(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
)
(defstruct (blk (:include ref))
; name ;;; Block name.
; (ref 0 :type fixnum) ;;; Number of references.
; ref-ccb ;;; Cross closure reference.
;;; During Pass1, T or NIL.
;;; During Pass2, the ccb-lex for the
;;; block id, or NIL.
; ref-clb ;;; Cross local function reference.
;;; During Pass1, T or NIL.
;;; During Pass2, the lex-address for the
;;; block id, or NIL.
; read-nodes ;;; Nodes (c1forms) in which the reference occurs
exit ;;; Where to return. A label.
destination ;;; Where the value of the block to go.
var ;;; Variable containing the block ID.
(type 'NIL) ;;; Estimated type.
)
(defstruct (tag (:include ref))
; name ;;; Tag name.
; (ref 0 :type fixnum) ;;; Number of references.
; ref-ccb ;;; Cross closure reference.
;;; During Pass1, T or NIL.
; ref-clb ;;; Cross local function reference.
;;; During Pass1, T or NIL.
; read-nodes ;;; Nodes (c1forms) in which the reference occurs
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 t) ;;; Type of the form.
(sp-change nil) ;;; Whether execution of the form may change
;;; the value of a special variable.
(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
expansion ;;; C template containing the expansion
one-liner ;;; Whether the expansion spans more than one line
)
;;;
;;; VARIABLES
;;;
;;; --cmpinline.lsp--
;;;
;;; Empty info struct
;;;
(defvar *info* (make-info))
(defvar *inline-functions* nil)
(defvar *inline-blocks* 0)
;;; *inline-functions* holds:
;;; (...( function-name . inline-info )...)
;;;
;;; *inline-blocks* holds the number of C blocks opened for declaring
;;; temporaries for intermediate results of the evaluation of inlined
;;; function calls.
;;; --cmputil.lsp--
;;;
;;; Variables and constants for error handling
;;;
(defvar *current-form* '|compiler preprocess|)
(defvar *current-toplevel-form* '|compiler preprocess|)
(defvar *current-c2form* nil)
(defvar *compile-file-position* -1)
(defvar *first-error* t)
(defconstant *cmperr-tag* (cons nil nil))
(defvar *active-handlers* nil)
(defvar *active-protection* nil)
(defvar *pending-actions* nil)
(defvar *compiler-conditions* '()
"This variable determines whether conditions are printed or just accumulated.")
(defvar *compile-print* nil
"This variable controls whether the compiler displays messages about
each form it processes. The default value is NIL.")
(defvar *compile-verbose* nil
"This variable controls whether the compiler should display messages about its
progress. The default value is T.")
(defvar *suppress-compiler-messages* 'compiler-debug-note
"A type denoting which compiler messages and conditions are _not_ displayed.")
(defvar *suppress-compiler-notes* nil) ; Deprecated
(defvar *suppress-compiler-warnings* nil) ; Deprecated
(defvar *compiler-break-enable* nil)
(defvar *compiler-in-use* nil)
(defvar *compiler-input*)
(defvar *compiler-output1*)
(defvar *compiler-output2*)
;;; --cmpcbk.lsp--
;;;
;;; List of callbacks to be generated
;;;
(defvar *callbacks* nil)
;;; --cmpcall.lsp--
;;;
;;; Whether to use linking calls.
;;;
(defvar *compile-to-linking-call* t)
(defvar *compiler-declared-globals*)
;;; --cmpenv.lsp--
;;;
;;; These default settings are equivalent to (optimize (speed 3) (space 0) (safety 2))
;;;
(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)
;;;
;;; Compiled code uses the following kinds of variables:
;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl)
;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp)
;;; 4. lexi[j], for lexical variables in local functions
;;; 5. CLVi, for lexical variables in closures
(defvar *lcl* 0) ; number of local variables
(defvar *temp* 0) ; number of temporary variables
(defvar *max-temp* 0) ; maximum *temp* reached
(defvar *level* 0) ; nesting level for local functions
(defvar *lex* 0) ; number of lexical variables in local functions
(defvar *max-lex* 0) ; maximum *lex* reached
(defvar *env* 0) ; number of variables in current form
(defvar *max-env* 0) ; maximum *env* in whole function
(defvar *env-lvl* 0) ; number of levels of environments
(defvar *aux-closure* nil) ; stack allocated closure needed for indirect calls
(defvar *next-cmacro* 0) ; holds the last cmacro number used.
(defvar *next-cfun* 0) ; holds the last cfun used.
(defvar *debug-fun* 0) ; Level of debugging of functions
;;;
;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
;;; If possible, *tail-recursion-info* holds
;; ( c1-lambda-form required-arg .... required-arg ),
;;; where each required-arg is a var-object.
;;;
(defvar *tail-recursion-info* nil)
;;;
;;; *function-declarations* holds :
;; (... ( { function-name | fun-object } arg-types return-type ) ...)
;;; Function declarations for global functions are ASSOCed by function names,
;;; whereas those for local functions are ASSOCed by function objects.
;;;
;;; The valid argment type declaration is:
;; ( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] )
;;; though &optional, &rest, and &key return types are simply ignored.
;;;
(defvar *function-declarations* nil)
(defvar *allow-c-local-declaration* t)
(defvar *notinline* nil)
;;; --cmpexit.lsp--
;;;
;;; *last-label* holds the label# of the last used label.
;;; *exit* holds an 'exit', which is
;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
;; RETURN-CHARACTER, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, or
;; RETURN-OBJECT).
;;; *unwind-exit* holds a list consisting of:
;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
;; JUMP, BDS-BIND (each pushed for a single special binding), or a
;; LCL (which holds the bind stack pointer used to unbind).
;;;
(defvar *last-label* 0)
(defvar *exit*)
(defvar *unwind-exit*)
(defvar *current-function* nil)
(defvar *cmp-env* (cons nil nil)
"The compiler environment consists of a pair or cons of two
lists, one containing variable records, the other one macro and
function recors:
variable-record = (:block block-name) |
(:tag ({tag-name}*)) |
(:function function-name) |
(var-name {:special | nil} bound-p) |
(symbol si::symbol-macro macro-function) |
CB | LB | UNWIND-PROTECT
macro-record = (function-name function) |
(macro-name si::macro macro-function)
CB | LB | UNWIND-PROTECT
A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A
MACRO-FUNCTION is a function that provides us with the expansion
for that local macro or symbol macro. BOUND-P is true when the
variable has been bound by an enclosing form, while it is NIL if
the variable-record corresponds just to a special declaration.
CB, LB and UNWIND-PROTECT are only used by the C compiler and
they denote closure, lexical environment and unwind-protect
boundaries. Note that compared with the bytecodes compiler, these
records contain an additional variable, block, tag or function
object at the end.")
;;; --cmplog.lsp--
;;;
;;; Destination of output of different forms. See cmploc.lsp for types
;;; of destinations.
;;;
(defvar *destination*)
;;; --cmpmain.lsp--
;;;
;;; Do we debug the compiler? Then we need files not to be deleted.
(defvar *debug-compiler* nil)
(defvar *delete-files* t)
(defvar *files-to-be-deleted* '())
;;; This is copied into each .h file generated, EXCEPT for system-p calls.
;;; The constant string *include-string* is the content of file "ecl.h".
;;; Here we use just a placeholder: it will be replaced with sed.
@ -477,16 +52,6 @@ coprocessor).")
(defvar *ld-bundle-flags* #-msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@"
#+msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ ecl.lib @CLIBS@")
(defvar *user-ld-flags* '()
"Flags and options to be passed to the linker when building FASL, shared libraries
and standalone programs. It is not required to surround values with quotes or use
slashes before special characters.")
(defvar *user-cc-flags* '()
"Flags and options to be passed to the C compiler when building FASL, shared libraries
and standalone programs. It is not required to surround values with quotes or use
slashes before special characters.")
(defvar +shared-library-prefix+ "@SHAREDPREFIX@")
(defvar +shared-library-extension+ "@SHAREDEXT@")
(defvar +shared-library-format+ "@SHAREDPREFIX@~a.@SHAREDEXT@")
@ -503,85 +68,3 @@ slashes before special characters.")
(let ((x "@ECL_LDRPATH@"))
(and (plusp (length x))
(format nil x *ecl-library-directory*))))
;;;
;;; Compiler program and flags.
;;;
;;; --cmptop.lsp--
;;;
(defvar *do-type-propagation* nil
"Flag for switching on the type propagation phase. Use with care, experimental.")
(defvar *compiler-phase* nil)
(defvar *volatile*)
(defvar *setjmps* 0)
(defvar *compile-toplevel* T
"Holds NIL or T depending on whether we are compiling a toplevel form.")
(defvar *clines-string-list* '()
"List of strings containing C/C++ statements which are directly inserted
in the translated C/C++ file. Notice that it is unspecified where these
lines are inserted, but the order is preserved")
(defvar *compile-time-too* nil)
(defvar *not-compile-time* nil)
(defvar *permanent-data* nil) ; detemines whether we use *permanent-objects*
; or *temporary-objects*
(defvar *permanent-objects* nil) ; holds { ( object (VV vv-index) ) }*
(defvar *temporary-objects* nil) ; holds { ( object (VV vv-index) ) }*
(defvar *load-objects* nil) ; hash with association object -> vv-location
(defvar *load-time-values* nil) ; holds { ( vv-index form ) }*,
;;; where each vv-index should be given an object before
;;; defining the current function during loading process.
(defvar *use-static-constants-p* nil) ; T/NIL flag to determine whether one may
; generate lisp constant values as C structs
(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
; only used in COMPILE
(defvar *proclaim-fixed-args* nil) ; proclaim automatically functions
; with fixed number of arguments.
; watch out for multiple values.
(defvar *global-var-objects* nil) ; var objects for global/special vars
(defvar *global-vars* nil) ; variables declared special
(defvar *global-funs* nil) ; holds { fun }*
(defvar *global-cfuns-array* nil) ; holds { fun }*
(defvar *linking-calls* nil) ; holds { ( global-fun-name fun symbol c-fun-name var-name ) }*
(defvar *local-funs* nil) ; holds { fun }*
(defvar *top-level-forms* nil) ; holds { top-level-form }*
(defvar *make-forms* nil) ; holds { top-level-form }*
;;;
;;; top-level-form:
;;; ( 'DEFUN' fun-name cfun lambda-expr doc-vv sp )
;;; | ( 'DEFMACRO' macro-name cfun lambda-expr doc-vv sp )
;;; | ( 'ORDINARY' expr )
;;; | ( 'DECLARE' var-name-vv )
;;; | ( 'DEFVAR' var-name-vv expr doc-vv )
;;; | ( 'CLINES' string* )
;;; | ( 'LOAD-TIME-VALUE' vv )
(defvar *reservations* nil)
(defvar *reservation-cmacro* nil)
;;; *reservations* holds (... ( cmacro . value ) ...).
;;; *reservation-cmacro* holds the cmacro current used as vs reservation.
;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...).
(defvar *global-entries* nil)
(defvar *self-destructing-fasl* '()
"A value T means that, when a FASL module is being unloaded (for
instance during garbage collection), the associated file will be
deleted. We need this for #'COMPILE because windows DLLs cannot
be deleted if they have been opened with LoadLibrary.")
(defvar *undefined-vars* nil)

200
src/cmp/cmpenv-api.lsp Normal file
View file

@ -0,0 +1,200 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 2009, 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.
;;;;
;;;; CMPENVAPI -- API for creating and manipulating environments
;;;;
(in-package #-new-cmp "COMPILER" #+new-cmp "C-ENV")
(defmacro cmp-env-new ()
'(cons nil nil))
(defun cmp-env-copy (&optional (env *cmp-env*))
(cons (car env) (cdr env)))
(defmacro cmp-env-variables (&optional (env '*cmp-env*))
`(car ,env))
(defmacro cmp-env-functions (&optional (env '*cmp-env*))
`(cdr ,env))
#-new-cmp
(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))
:special
t)
boundp
var)
(cmp-env-variables env))
env)
(defun cmp-env-declare-special (name &optional (env *cmp-env*))
(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))
env)
(defun cmp-env-extend-declaration (type arguments &optional (env *cmp-env*))
(let ((x (cmp-env-search-declaration type)))
(cmp-env-add-declaration type (append arguments x) env)
env))
(defun cmp-env-register-function (fun &optional (env *cmp-env*))
(push (list (fun-name fun) 'function fun)
(cmp-env-functions env))
env)
(defun cmp-env-register-macro (name function &optional (env *cmp-env*))
(push (list name 'si::macro function)
(cmp-env-functions env))
env)
(defun cmp-env-register-ftype (name declaration &optional (env *cmp-env*))
(push (list* :declare name declaration)
(cmp-env-functions env))
env)
(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*))
(push (list name 'si::symbol-macro #'(lambda (whole env) form))
(cmp-env-variables env))
env)
(defun cmp-env-register-block (blk &optional (env *cmp-env*))
(push (list :block (blk-name blk) blk)
(cmp-env-variables env))
env)
(defun cmp-env-register-tag (name tag &optional (env *cmp-env*))
(push (list :tag (list name) tag)
(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 ((ccb nil)
(clb nil)
(unw nil)
(found nil))
(dolist (record (cmp-env-functions env))
(cond ((eq record 'CB)
(setf ccbb t))
((eq record 'LB)
(setf clb t))
((eq record 'UNWIND-PROTECT)
(setf unw t))
((atom record)
(baboon))
;; We have to use EQUAL because the name can be a list (SETF whatever)
((equal (first record) name)
(setf found (first (last record)))
(return))))
(values found ccb clb unw)))
(defun cmp-env-search-variables (type name env)
(let ((ccb nil)
(clb nil)
(unw nil)
(found nil))
(dolist (record (cmp-env-variables env))
(cond ((eq record 'CB)
(setf ccb t))
((eq record 'LB)
(setf clb t))
((eq record 'UNWIND-PROTECT)
(setf unw t))
((atom record)
(baboon))
((not (eq (first record) type)))
((eq type :block)
(when (eq name (second record))
(setf found record)
(return)))
((eq type :tag)
(when (member name (second record) :test #'eql)
(setf found record)
(return)))
((eq (second record) 'si::symbol-macro)
(when (eq name 'si::symbol-macro)
(setf found record))
(return))
(t
(setf found record)
(return))))
(values (first (last found)) ccb clb unw)))
(defun cmp-env-search-block (name &optional (env *cmp-env*))
(cmp-env-search-variables :block name env))
(defun cmp-env-search-tag (name &optional (env *cmp-env*))
(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))
(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)))
(defun cmp-env-search-ftype (name &optional (env *cmp-env*))
(dolist (i env nil)
(when (and (consp i)
(eq (pop i) :declare)
(same-fname-p (pop i) name))
(return i))))
(defun cmp-env-mark (mark &optional (env *cmp-env*))
(cons (cons mark (car env))
(cons mark (cdr env))))
(defun cmp-env-new-variables (new-env old-env)
(loop for i in (ldiff (cmp-env-variables *cmp-env*)
(cmp-env-variables old-env))
when (and (consp i) (var-p (fourth i)))
collect (fourth i)))
(defun cmp-env-search-declaration (kind &optional (env *cmp-env*))
(loop for i in (car env)
when (and (consp i)
(eq (first i) :declare)
(eq (second i) kind))
return (cddr i)))

52
src/cmp/cmpenv-declaim.lsp Normal file
View file

@ -0,0 +1,52 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; 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.
;;;;
;;;; CMPENV-DECLAIM -- Proclamations local to the current file
;;;;
;;;; One implementation of DECLAIM that uses the compiler environment
;;;; providing a "base" set of entries that all other environments
;;;; stem from.
;;;;
(in-package #-ecl-new "COMPILER" #+ecl-new "C-ENV")
(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)))
(setf env (cmp-env-register-var v env))))
(loop for (name . type) in types
for specialp = (or (sys:specialp name) (member name specials))
for kind = (if specialp 'SPECIAL 'GLOBAL)
for v = (c1make-global-variable name :type type :kind kind)
do (setf env (cmp-env-register-var v env)))
env))
(multiple-value-bind (body specials types ignored others doc all)
(c1body `((DECLARE ,@args)) nil)
(when ignored
(cmpwarn "IGNORE/IGNORABLE declarations in DECLAIM are ignored"))
(reduce #'add-one-declaration others
:initial-value (add-variables *cmp-env* types specials))
(reduce #'add-one-declaration others
:initial-value (add-variables *cmp-env-root* types specials)))))
(defmacro declaim (&rest declarations)
`(progn
(ext:with-backend
:c/c++ (eval-when (:compile-toplevel)
(c::process-declaim-args ',declarations))
:bytecodes (eval-when (:compile-toplevel)
(proclaim ',declarations)))
(eval-when (:load-toplevel :execute)
(mapc 'proclaim ',declarations))))

217
src/cmp/cmpenv-declare.lsp Normal file
View file

@ -0,0 +1,217 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; 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.
;;;;
;;;; CMPENV-DECLARE -- Declarations for the compiler
;;;;
;;;; Extract, process and incorporate declarations into the compiler
;;;; environment. Unlike proclamations, these are local to the current
;;;; compiled file and do not propagate beyond it.
;;;;
(in-package #-ecl-new "COMPILER" #+ecl-new "C-ENV")
(defun proper-list-p (x &optional test)
(and (listp x)
(handler-case (list-length x) (type-error (c) nil))
(or (null test) (every test x))))
(defun type-name-p (name)
(or (get-sysprop name 'SI::DEFTYPE-DEFINITION)
(find-class name nil)
(get-sysprop name 'SI::STRUCTURE-TYPE)))
(defun validate-alien-declaration (names-list error)
(dolist (new-declaration names-list)
(unless (symbolp new-declaration)
(cmperr "The declaration ~s is not a symbol" new-declaration))
(when (type-name-p new-declaration)
(cmperr "Symbol name ~S cannot be both the name of a type and of a declaration"
new-declaration))))
(defun alien-declaration-p (name &optional (env *cmp-env*))
(or (member name si::*alien-declarations*)
(member name (cmp-env-search-declaration 'alien env))))
(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)))
tail)
(defun collect-declared (type var-list tail)
(declare (si::c-local))
(cmpassert (proper-list-p var-list #'symbolp)
"Syntax error in declaration ~s" decl)
(loop for var-name in var-list
do (push (cons var-name type) tail))
tail)
(defun c1body (body doc-p)
"Split a function body into a list of forms, a set of declarations,
and a possible documentation string (only accepted when DOC-P is true)."
(multiple-value-bind (all-declarations body doc specials)
(si:process-declarations body doc-p)
(loop with others = '()
with types = '()
with ignored = '()
for decl in all-declarations
for decl-name = (first decl)
for decl-args = (rest decl)
do (cmpassert (and (proper-list-p decl-args) (symbolp decl-name))
"Syntax error in declaration ~s" decl)
do (case decl-name
(SPECIAL)
(IGNORE
(cmpassert (proper-list-p decl-args #'symbolp)
"Syntax error in declaration ~s" decl)
(setf ignored (parse-ignore-declaration decl-args -1 ignored)))
(IGNORABLE
(cmpassert (proper-list-p decl-args #'symbolp)
"Syntax error in declaration ~s" decl)
(setf ignored (parse-ignore-declaration decl-args 0 ignored)))
(TYPE
(cmpassert (and (consp decl-args)
(proper-list-p (rest decl-args) #'symbolp))
"Syntax error in declaration ~s" decl)
(setf types (collect-declared (first decl-args)
(rest decl-args)
types)))
(OBJECT
(cmpassert (proper-list-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
SI::NO-CHECK-TYPE POLICY-DEBUG-IHS-FRAME :READ-ONLY)
(push decl others))
(otherwise
(if (alien-declaration-p decl-name)
(push decl others)
(multiple-value-bind (ok type)
(valid-type-specifier decl-name)
(cmpassert ok "Unknown declaration specifier ~s"
decl-name)
(setf types (collect-declared type decl-args types))))))
finally (return (values body specials types ignored
(nreverse others) doc all-declarations)))))
(defun default-optimization (optimization)
(ecase optimization
(speed *speed*)
(safety *safety*)
(space *space*)
(debug *debug*)))
(defun search-optimization-quality (declarations what)
(dolist (i (reverse declarations)
(default-optimization what))
(when (and (consp i) (eq (first i) 'policy-debug-ihs-frame)
(eq what 'debug))
(return 2))
(when (and (consp i) (eq (first i) 'optimize))
(dolist (j (rest i))
(cond ((consp j)
(when (eq (first j) what)
(return-from search-optimization-quality (second j))))
((eq j what)
(return-from search-optimization-quality 3)))))))
(defun compute-optimizations (arguments env)
(let ((optimizations (cmp-env-all-optimizations env)))
(dolist (x arguments)
(when (symbolp x) (setq x (list x 3)))
(unless optimizations
(setq optimizations (cmp-env-all-optimizations)))
(if (or (not (consp x))
(not (consp (cdr x)))
(not (numberp (second x)))
(not (<= 0 (second x) 3)))
(cmpwarn "Illegal OPTIMIZE proclamation ~s" x)
(let ((value (second x)))
(case (car x)
(DEBUG (setf (first optimizations) value))
(SAFETY (setf (second optimizations) value))
(SPACE (setf (third optimizations) value))
(SPEED (setf (fourth optimizations) value))
(COMPILATION-SPEED)
(t (cmpwarn "Unknown OPTIMIZE quality ~s" (car x)))))))
optimizations))
(defun add-one-declaration (env decl)
"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
(let ((optimizations (compute-optimizations (rest decl) env)))
(cmp-env-add-declaration 'optimize optimizations env)))
(POLICY-DEBUG-IHS-FRAME
(let ((flag (or (rest decl) '(t))))
(if *current-function*
(progn
(cmp-env-add-declaration 'policy-debug-ihs-frame flag
(fun-cmp-env *current-function*))
env)
(cmp-env-add-declaration 'policy-debug-ihs-frame
flag env))))
(FTYPE
(if (atom (rest decl))
(cmpwarn "Syntax error in declaration ~a" decl)
(multiple-value-bind (type-name args)
(si::normalize-type (second decl))
(if (eq type-name 'FUNCTION)
(dolist (v (cddr decl))
(setf env (add-function-declaration v (first args)
(rest args) env)))
(cmpwarn "In an FTYPE declaration, found ~A which is not a function type."
(second decl)))))
env)
(INLINE
(declare-inline (rest decl) env))
(NOTINLINE
(setf env (declare-notinline (rest decl) env)))
(DECLARATION
(validate-alien-declaration (rest decl) #'cmperr)
(setf env (cmp-env-extend-declaration 'alien (rest decl) env)))
((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE :READ-ONLY)
env)
((DYNAMIC-EXTENT IGNORABLE)
;; FIXME! SOME ARE IGNORED!
env)
(otherwise
(unless (alien-declaration-p (first decl) env)
(cmpwarn "Unknown declaration specifier ~s" (first decl)))
env)))
(defun symbol-macro-declaration-p (name type)
(let* ((record (cmp-env-search-variables name 'si::symbol-macro *cmp-env*)))
(when (and record (functionp record))
(let* ((expression (funcall record name nil)))
(cmp-env-register-symbol-macro name `(the ,type ,expression)))
t)))
(defun check-vdecl (vnames ts is)
(loop for (var . type) in ts
unless (or (member var vnames :test #'eq)
(symbol-macro-declaration-p var type))
do (cmpwarn "Declaration of type~&~4T~A~&was found for not bound variable ~s."
type var))
(loop for (var . expected-uses) in is
unless (member var vnames :test #'eq)
do (cmpwarn (if (minusp expected-uses)
"IGNORE declaration was found for not bound variable ~s."
"IGNORABLE declaration was found for not bound variable ~s.")
var)))

147
src/cmp/cmpenv-fun.lsp Normal file
View file

@ -0,0 +1,147 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 2009, 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.
;;;;
;;;; CMPTYPE-PROP -- Type propagation basic routines and database
;;;;
(in-package #-new-cmp "COMPILER" #+new-cmp "C-ENV")
(defun function-arg-types (arg-types &aux (types nil))
(do ((al arg-types (cdr al)))
((or (endp al)
(member (car al) '(&optional &rest &key)))
(nreverse types))
(declare (object al))
(push (type-filter (car al)) types)))
;;; The valid return type declaration is:
;;; (( VALUES {type}* )) or ( {type}* ).
(defun function-return-type (return-types)
(cond ((endp return-types) t)
((and (consp (car return-types))
(eq (caar return-types) 'VALUES))
(cond ((not (endp (cdr return-types)))
(warn "The function return types ~s is illegal." return-types)
t)
((or (endp (cdar return-types))
(member (cadar return-types) '(&optional &rest &key)))
t)
(t (type-filter (car return-types) t))))
(t (#-new-cmp type-filter #+new-cmp c-types:type-filter
(car return-types)))))
(defun proclaim-function (fname decl)
(if (si:valid-function-name-p fname)
(let* ((arg-types '*)
(return-types '*)
(l decl))
(cond ((null l))
((consp l)
(setf arg-types (pop l)))
(t (warn "The function proclamation ~s ~s is not valid."
fname decl)))
(cond ((null l))
((and (consp l) (null (rest l)))
(setf return-types (function-return-type l)))
(t (warn "The function proclamation ~s ~s is not valid."
fname decl)))
(when (eq arg-types '())
(setf arg-types '(&optional)))
(if (eq arg-types '*)
(rem-sysprop fname 'PROCLAIMED-ARG-TYPES)
(put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types))
(if (member return-types '(* (VALUES &rest t))
:test #'equalp)
(rem-sysprop fname 'PROCLAIMED-RETURN-TYPE)
(put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)))
(warn "The function proclamation ~s ~s is not valid." fname decl)))
(defun add-function-declaration (fname arg-types return-types &optional (env *cmp-env*))
(if (si::valid-function-name-p fname)
(let ((fun (cmp-env-search-function fname)))
(if (functionp fun)
(warn "Found function declaration for local macro ~A" fname)
(cmp-env-register-ftype fname (list arg-types return-types) env)))
(warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname))
env)
(defun get-arg-types (fname &optional (env *cmp-env*))
(let ((x (cmp-env-search-ftype fname env)))
(if x
(values (first x) t)
(sys: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
(values (second x) t)
(sys: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))))
(if x
(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))))
(if x
(values (second x) t)
(values nil nil))))
(defun get-proclaimed-narg (fun &optional (env *cmp-env*))
(multiple-value-bind (arg-list found)
(get-arg-types fun env)
(if found
(loop for type in arg-list
with minarg = 0
and maxarg = 0
and in-optionals = nil
do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq)
(return (values minarg call-arguments-limit)))
((eq type '&optional)
(setf in-optionals t maxarg minarg))
(in-optionals
(incf maxarg))
(t
(incf minarg)
(incf maxarg)))
finally (return (values minarg maxarg found)))
(values 0 call-arguments-limit found))))
;;; Proclamation and declaration handling.
(defun declare-inline (fname-list &optional (env *cmp-env*))
(unless (every #'si::valid-function-name-p fname-list)
(cmperr "Not a valid argument to INLINE declaration~%~4I~A"
fname-list))
(cmp-env-extend-declaration 'INLINE
(loop for name in fname-list
collect (cons name t))))
(defun declare-notinline (fname-list &optional (env *cmp-env*))
(unless (every #'symbolp fname-list)
(cmperr "Not a valid argument to NOTINLINE declaration~%~4I~A"
fname-list))
(cmp-env-extend-declaration 'INLINE
(loop for name in fname-list
collect (cons name nil))))
(defun inline-possible (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)
(not (or ;; (compiler-<push-events)
;;(>= *debug* 2) Breaks compilation of STACK-PUSH-VALUES
(sys:get-sysprop fname 'CMP-NOTINLINE))))))

136
src/cmp/cmpenv-proclaim.lsp Normal file
View file

@ -0,0 +1,136 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; 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.
;;;;
;;;; CMPENV-PROCLAIM -- Proclamations for the compiler
;;;;
;;;; One implementation of PROCLAIM that uses symbol properties to
;;;; store the proclamations. This has the disadvantage that
;;;; proclamations can not be easily cleaned up.
;;;;
;;;; The following code is to be coordinated with that in sysfun.lsp
;;;; and proclamations.lsp
;;;;
(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
(dolist (var (cdr decl))
(if (symbolp var)
(sys:*make-special var)
(error "Syntax error in proclamation ~s" decl))))
(OPTIMIZE
(dolist (x (cdr decl))
(when (symbolp x) (setq x (list x 3)))
(if (or (not (consp x))
(not (consp (cdr x)))
(not (numberp (second x)))
(not (<= 0 (second x) 3)))
(warn "The OPTIMIZE proclamation ~s is illegal." x)
(case (car x)
(DEBUG (setq *debug* (second x)))
(SAFETY (setq *safety* (second x)))
(SPACE (setq *space* (second x)))
(SPEED (setq *speed* (second x)))
(COMPILATION-SPEED (setq *speed* (- 3 (second x))))
(t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
(TYPE
(if (consp (cdr decl))
(proclaim-var (second decl) (cddr decl))
(error "Syntax error in proclamation ~s" decl)))
(FTYPE
(if (atom (rest decl))
(error "Syntax error in proclamation ~a" decl)
(multiple-value-bind (type-name args)
(si::normalize-type (second decl))
(if (eq type-name 'FUNCTION)
(dolist (v (cddr decl))
(proclaim-function v args))
(error "In an FTYPE proclamation, found ~A which is not a function type."
(second decl))))))
(INLINE
(dolist (fun (cdr decl))
(if (si::valid-function-name-p fun)
(rem-sysprop fun 'CMP-NOTINLINE)
(error "Not a valid function name ~s in proclamation ~s" fun decl))))
(NOTINLINE
(dolist (fun (cdr decl))
(if (si::valid-function-name-p fun)
(put-sysprop fun 'CMP-NOTINLINE t)
(error "Not a valid function name ~s in proclamation ~s" fun decl))))
((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE)
;; FIXME! IGNORED!
(dolist (var (cdr decl))
(unless (si::valid-function-name-p var)
(error "Not a valid function name ~s in ~s proclamation" fun decl-name))))
(DECLARATION
(validate-alien-declaration (rest decl) #'error)
(setf si::*alien-declarations*
(append (rest decl) si:*alien-declarations*)))
(SI::C-EXPORT-FNAME
(dolist (x (cdr decl))
(cond ((symbolp x)
(multiple-value-bind (found c-name)
(si::mangle-name x t)
(if found
(warn "The function ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." x)
(put-sysprop x 'Lfun c-name))))
((consp x)
(destructuring-bind (c-name lisp-name) x
(if (si::mangle-name lisp-name)
(warn "The funciton ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." lisp-name)
(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)
(proclaim-var decl-name (cdr decl)))
(otherwise
(cond ((member (car decl) si:*alien-declarations*))
((multiple-value-bind (ok type)
(valid-type-specifier decl-name)
(when ok
(proclaim-var type (rest decl))
t)))
((let ((proclaimer (get-sysprop (car decl) :proclaim)))
(when (functionp proclaimer)
(mapc proclaimer (rest decl))
t)))
(t
(warn "Unknown declaration specifier ~s" decl-name))))))
(defun proclaim-var (type vl)
(setq type (type-filter type))
(dolist (var vl)
(if (symbolp var)
(let ((type1 (get-sysprop var 'CMP-TYPE))
(v (sch-global var)))
(setq type1 (if type1 (type-and type1 type) type))
(when v (setq type1 (type-and type1 (var-type v))))
(unless type1
(warn
"Inconsistent type declaration was found for the variable ~s."
var)
(setq type1 T))
(put-sysprop var 'CMP-TYPE type1)
(when v (setf (var-type v) type1)))
(warn "The variable name ~s is not a symbol." var))))

688
src/cmp/cmpenv.lsp
View file

@ -1,688 +0,0 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;;
;;;; 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.
;;;; CMPENV Environments of the Compiler.
(in-package "COMPILER")
;;; Only these flags are set by the user.
;;; 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+
'((*gensym-counter* 0)
(*compiler-in-use* t)
(*compiler-phase* 't1)
(*callbacks* nil)
(*max-temp* 0)
(*temp* 0)
(*next-cmacro* 0)
(*next-cfun* 0)
(*last-label* 0)
(*load-objects* (make-hash-table :size 128 :test #'equal))
(*make-forms* nil)
(*static-constants* nil)
(*permanent-objects* nil)
(*temporary-objects* nil)
(*local-funs* nil)
(*global-var-objects* nil)
(*global-vars* nil)
(*global-funs* nil)
(*global-cfuns-array* nil)
(*linking-calls* nil)
(*global-entries* nil)
(*undefined-vars* nil)
(*reservations* nil)
(*top-level-forms* nil)
(*compile-time-too* nil)
(*clines-string-list* '())
(*inline-functions* nil)
(*inline-blocks* 0)
(*notinline* nil)
(*debugger-hook* 'compiler-debugger)))
(defun next-lcl () (list 'LCL (incf *lcl*)))
(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 function-arg-types (arg-types &aux (types nil))
(do ((al arg-types (cdr al)))
((or (endp al)
(member (car al) '(&optional &rest &key)))
(nreverse types))
(declare (object al))
(push (type-filter (car al)) types)))
;;; The valid return type declaration is:
;;; (( VALUES {type}* )) or ( {type}* ).
(defun function-return-type (return-types)
(cond ((endp return-types) t)
((and (consp (car return-types))
(eq (caar return-types) 'VALUES))
(cond ((not (endp (cdr return-types)))
(warn "The function return types ~s is illegal." return-types)
t)
((or (endp (cdar return-types))
(member (cadar return-types) '(&optional &rest &key)))
t)
(t (type-filter (car return-types) t))))
(t (type-filter (car return-types)))))
(defun add-function-proclamation (fname decl)
(if (si:valid-function-name-p fname)
(let* ((arg-types '*)
(return-types '*)
(l decl))
(cond ((null l))
((consp l)
(setf arg-types (pop l)))
(t (warn "The function proclamation ~s ~s is not valid."
fname decl)))
(cond ((null l))
((and (consp l) (null (rest l)))
(setf return-types (function-return-type l)))
(t (warn "The function proclamation ~s ~s is not valid."
fname decl)))
(if (eq arg-types '*)
(rem-sysprop fname 'PROCLAIMED-ARG-TYPES)
(put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types))
(if (eq return-types '*)
(rem-sysprop fname 'PROCLAIMED-RETURN-TYPE)
(put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)))
(warn "The function proclamation ~s ~s is not valid." fname decl)))
(defun add-function-declaration (fname arg-types return-types)
(if (si::valid-function-name-p fname)
(let ((fun (cmp-env-search-function fname)))
(if (functionp fun)
(warn "Found function declaration for local macro ~A" fname)
(push (list fun
(function-arg-types arg-types)
(function-return-type return-types))
*function-declarations*)))
(warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname)))
(defun get-arg-types (fname)
(let ((x (assoc fname *function-declarations*)))
(if x
(values (second x) t)
(get-sysprop fname 'PROCLAIMED-ARG-TYPES))))
(defun get-return-type (fname)
(let ((x (assoc fname *function-declarations*)))
(if x
(values (third x) t)
(get-sysprop fname 'PROCLAIMED-RETURN-TYPE))))
(defun get-local-arg-types (fun &aux x)
(if (setq x (assoc fun *function-declarations*))
(values (second x) t)
(values nil nil)))
(defun get-local-return-type (fun &aux x)
(if (setq x (assoc fun *function-declarations*))
(values (caddr x) t)
(values nil nil)))
(defun get-proclaimed-narg (fun)
(multiple-value-bind (arg-list found)
(get-arg-types fun)
(if found
(loop for type in arg-list
with minarg = 0
and maxarg = 0
and in-optionals = nil
do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq)
(return (values minarg call-arguments-limit)))
((eq type '&optional)
(setf in-optionals t maxarg minarg))
(in-optionals
(incf maxarg))
(t
(incf minarg)
(incf maxarg)))
finally (return (values minarg maxarg)))
(values 0 call-arguments-limit))))
;;; Proclamation and declaration handling.
(defun inline-possible (fname)
(not (or ; (compiler-<push-events)
;(>= *debug* 2) Breaks compilation of STACK-PUSH-VALUES
(member fname *notinline* :test #'same-fname-p)
(get-sysprop fname 'CMP-NOTINLINE))))
#-: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
(dolist (var (cdr decl))
(if (symbolp var)
(sys:*make-special var)
(error "Syntax error in proclamation ~s" decl))))
(OPTIMIZE
(dolist (x (cdr decl))
(when (symbolp x) (setq x (list x 3)))
(if (or (not (consp x))
(not (consp (cdr x)))
(not (numberp (second x)))
(not (<= 0 (second x) 3)))
(warn "The OPTIMIZE proclamation ~s is illegal." x)
(case (car x)
(DEBUG (setq *debug* (second x)))
(SAFETY (setq *safety* (second x)))
(SPACE (setq *space* (second x)))
(SPEED (setq *speed* (second x)))
(COMPILATION-SPEED (setq *speed* (- 3 (second x))))
(t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
(TYPE
(if (consp (cdr decl))
(proclaim-var (second decl) (cddr decl))
(error "Syntax error in proclamation ~s" decl)))
(FTYPE
(if (atom (rest decl))
(error "Syntax error in proclamation ~a" decl)
(multiple-value-bind (type-name args)
(si::normalize-type (second decl))
(if (eq type-name 'FUNCTION)
(dolist (v (cddr decl))
(add-function-proclamation v args))
(error "In an FTYPE proclamation, found ~A which is not a function type."
(second decl))))))
(INLINE
(dolist (fun (cdr decl))
(if (si::valid-function-name-p fun)
(rem-sysprop fun 'CMP-NOTINLINE)
(error "Not a valid function name ~s in proclamation ~s" fun decl))))
(NOTINLINE
(dolist (fun (cdr decl))
(if (si::valid-function-name-p fun)
(put-sysprop fun 'CMP-NOTINLINE t)
(error "Not a valid function name ~s in proclamation ~s" fun decl))))
((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE)
;; FIXME! IGNORED!
(dolist (var (cdr decl))
(unless (si::valid-function-name-p var)
(error "Not a valid function name ~s in ~s proclamation" fun decl-name))))
(DECLARATION
(do-declaration (rest decl) #'error))
(SI::C-EXPORT-FNAME
(dolist (x (cdr decl))
(cond ((symbolp x)
(multiple-value-bind (found c-name)
(si::mangle-name x t)
(if found
(warn "The function ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." x)
(put-sysprop x 'Lfun c-name))))
((consp x)
(destructuring-bind (c-name lisp-name) x
(if (si::mangle-name lisp-name)
(warn "The funciton ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." lisp-name)
(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)
(proclaim-var decl-name (cdr decl)))
(otherwise
(cond ((member (car decl) si:*alien-declarations*))
((multiple-value-bind (ok type)
(valid-type-specifier decl-name)
(when ok
(proclaim-var type (rest decl))
t)))
((let ((proclaimer (get-sysprop (car decl) :proclaim)))
(when (functionp proclaimer)
(mapc proclaimer (rest decl))
t)))
(t
(warn "The declaration specifier ~s is unknown." decl-name))))))
(defun type-name-p (name)
(or (get-sysprop name 'SI::DEFTYPE-DEFINITION)
(find-class name nil)
(get-sysprop name 'SI::STRUCTURE-TYPE)))
(defun do-declaration (names-list error)
(declare (si::c-local))
(dolist (new-declaration names-list)
(unless (symbolp new-declaration)
(cmperr "The declaration ~s is not a symbol" new-declaration))
(when (type-name-p new-declaration)
(cmperr "Symbol name ~S cannot be both the name of a type and of a declaration"
new-declaration))
(pushnew new-declaration si:*alien-declarations*)))
(defun proclaim-var (type vl)
(setq type (type-filter type))
(dolist (var vl)
(if (symbolp var)
(let ((type1 (get-sysprop var 'CMP-TYPE))
(v (sch-global var)))
(setq type1 (if type1 (type-and type1 type) type))
(when v (setq type1 (type-and type1 (var-type v))))
(unless type1
(warn
"Inconsistent type declaration was found for the variable ~s."
var)
(setq type1 T))
(put-sysprop var 'CMP-TYPE type1)
(when v (setf (var-type v) type1)))
(warn "The variable name ~s is not a symbol." var))))
(defun parse-ignore-declaration (decl-args expected-ref-number)
(loop with output = '()
for name in decl-args
do (cond ((symbolp name)
(push (cons name expected-ref-number) output))
(t
(cmpassert (and (consp name)
(= (length name) 2)
(eq (first name) 'function))
"Invalid argument to IGNORE/IGNORABLE declaration:~&~A"
name)))
finally (return output)))
(defun c1body (body doc-p &aux
(all-declarations nil)
(ss nil) ; special vars
(is nil) ; ignored vars
(ts nil) ; typed vars (var . type)
(others nil) ; all other vars
doc form)
(loop
(when (endp body) (return))
(setq form (cmp-macroexpand (car body)))
(cond
((stringp form)
(when (or (null doc-p) (endp (cdr body)) doc) (return))
(setq doc form))
((and (consp form) (eq (car form) 'DECLARE))
(push form all-declarations)
(dolist (decl (cdr form))
(cmpassert (and (proper-list-p decl) (symbolp (first decl)))
"Syntax error in declaration ~s" form)
(let* ((decl-name (first decl))
(decl-args (rest decl)))
(flet ((declare-variables (type var-list)
(cmpassert (proper-list-p var-list #'symbolp)
"Syntax error in declaration ~s" decl)
(when type
(dolist (var var-list)
(push (cons var type) ts)))))
(case decl-name
(SPECIAL
(cmpassert (proper-list-p decl-args #'symbolp)
"Syntax error in declaration ~s" decl)
(setf ss (append decl-args ss)))
(IGNORE
(setf is (nconc (parse-ignore-declaration decl-args -1)
is)))
(IGNORABLE
(setf is (nconc (parse-ignore-declaration decl-args 0)
is)))
(TYPE
(cmpassert decl-args "Syntax error in declaration ~s" decl)
(declare-variables (first decl-args) (rest decl-args)))
(OBJECT
(declare-variables 'OBJECT decl-args))
;; read-only variable treatment. obsolete!
(:READ-ONLY
(push decl others))
((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL
DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE
POLICY-DEBUG-IHS-FRAME)
(push decl others))
(otherwise
(if (member decl-name si::*alien-declarations*)
(push decl others)
(multiple-value-bind (ok type)
(valid-type-specifier decl-name)
(cmpassert ok "The declaration specifier ~s is unknown." decl-name)
(declare-variables type decl-args))))
)))))
(t (return)))
(pop body)
)
(values body ss ts is others doc all-declarations)
)
(defun default-optimization (optimization)
(ecase optimization
(speed *speed*)
(safety *safety*)
(space *space*)
(debug *debug*)))
(defun search-optimization-quality (declarations what)
(dolist (i (reverse declarations)
(default-optimization what))
(when (and (consp i) (eq (first i) 'policy-debug-ihs-frame)
(eq what 'debug))
(return 2))
(when (and (consp i) (eq (first i) 'optimize))
(dolist (j (rest i))
(cond ((consp j)
(when (eq (first j) what)
(return-from search-optimization-quality (second j))))
((eq j what)
(return-from search-optimization-quality 3)))))))
(defun c1add-declarations (decls &aux (dl nil) (optimizations))
(dolist (decl decls)
(case (car decl)
(OPTIMIZE
(push decl dl)
(dolist (x (cdr decl))
(when (symbolp x) (setq x (list x 3)))
(unless optimizations
(setq optimizations (cmp-env-all-optimizations)))
(if (or (not (consp x))
(not (consp (cdr x)))
(not (numberp (second x)))
(not (<= 0 (second x) 3)))
(cmpwarn "The OPTIMIZE proclamation ~s is illegal." x)
(let ((value (second x)))
(case (car x)
(DEBUG (setf (first optimizations) value))
(SAFETY (setf (second optimizations) value))
(SPACE (setf (third optimizations) value))
(SPEED (setf (fourth optimizations) value))
(COMPILATION-SPEED)
(t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x))))))))
(POLICY-DEBUG-IHS-FRAME
(unless optimizations
(setq optimizations (cmp-env-all-optimizations)))
(setf (first optimizations) (max 2 (first optimizations))))
(FTYPE
(if (atom (rest decl))
(cmpwarn "Syntax error in declaration ~a" decl)
(multiple-value-bind (type-name args)
(si::normalize-type (second decl))
(if (eq type-name 'FUNCTION)
(dolist (v (cddr decl))
(add-function-declaration v (first args) (rest args)))
(cmpwarn "In an FTYPE declaration, found ~A which is not a function type."
(second decl))))))
(INLINE
(push decl dl)
(dolist (fun (cdr decl))
(if (si::valid-function-name-p fun)
(setq *notinline* (remove fun *notinline*))
(cmperr "Not a valid function name ~s in declaration ~s" fun decl))))
(NOTINLINE
(push decl dl)
(dolist (fun (cdr decl))
(if (si::valid-function-name-p fun)
(push fun *notinline*)
(cmperr "Not a valid function name ~s in declaration ~s" fun decl))))
(DECLARATION
(do-declaration (rest decl) #'cmperr))
((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE))
((DYNAMIC-EXTENT IGNORABLE)
;; FIXME! SOME ARE IGNORED!
)
(:READ-ONLY)
(otherwise
(unless (member (car decl) si:*alien-declarations*)
(cmpwarn "The declaration specifier ~s is unknown." (car decl))))))
(when optimizations
(setf *cmp-env*
(cons (cons `(:declare optimize ,@optimizations)
(car *cmp-env*))
(cdr *cmp-env*))))
dl)
(defun c1decl-body (decls body)
(if (null decls)
(c1progn body)
(let* ((*function-declarations* *function-declarations*)
(si:*alien-declarations* si:*alien-declarations*)
(*notinline* *notinline*)
(*cmp-env* *cmp-env*)
(dl (c1add-declarations decls)))
(setq body (c1progn body))
(make-c1form 'DECL-BODY body dl body))))
(put-sysprop 'decl-body 'c2 'c2decl-body)
(defun c2decl-body (decls body)
(let ((*cmp-env* *cmp-env*)
(*notinline* *notinline*))
(c1add-declarations decls)
(c2expr body)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; COMPILER ENVIRONMENT
;;;
(defmacro cmp-env-new ()
'(cons nil nil))
(defun cmp-env-copy (&optional (env *cmp-env*))
(cons (car env) (cdr env)))
(defmacro cmp-env-variables (&optional (env '*cmp-env*))
`(car ,env))
(defmacro cmp-env-functions (&optional (env '*cmp-env*))
`(cdr ,env))
(defun cmp-env-register-var (var &optional (env *cmp-env*) (boundp t))
(push (list (var-name var)
(if (member (var-kind var) '(special global))
:special
t)
boundp
var)
(cmp-env-variables)))
(defun cmp-env-declare-special (name &optional (env *cmp-env*))
(cmp-env-register-var (c1make-global-variable name :warn nil :kind 'SPECIAL)
env nil))
(defun cmp-env-register-function (fun &optional (env *cmp-env*))
(push (list (fun-name fun) 'function fun)
(cmp-env-functions env)))
(defun cmp-env-register-macro (name function &optional (env *cmp-env*))
(push (list name 'si::macro function)
(cmp-env-functions env)))
(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*))
(push (list name 'si::symbol-macro #'(lambda (whole env) form))
(cmp-env-variables env)))
(defun cmp-env-register-block (blk &optional (env *cmp-env*))
(push (list :block (blk-name blk) blk)
(cmp-env-variables env)))
(defun cmp-env-register-tag (tag &optional (env *cmp-env*))
(push (list :tag (list (tag-name tag)) tag)
(cmp-env-variables env)))
(defun cmp-env-search-function (name &optional (env *cmp-env*))
(let ((ccb nil)
(clb nil)
(unw nil)
(found nil))
(dolist (record (cmp-env-functions env))
(cond ((eq record 'CB)
(setf ccb t))
((eq record 'LB)
(setf clb t))
((eq record 'UNWIND-PROTECT)
(setf unw t))
((atom record)
(baboon))
;; We have to use EQUAL because the name can be a list (SETF whatever)
((equal (first record) name)
(setf found (first (last record)))
(return))))
(values found ccb clb unw)))
(defun cmp-env-search-variables (type name env)
(let ((ccb nil)
(clb nil)
(unw nil)
(found nil))
(dolist (record (cmp-env-variables env))
(cond ((eq record 'CB)
(setf ccb t))
((eq record 'LB)
(setf clb t))
((eq record 'UNWIND-PROTECT)
(setf unw t))
((atom record)
(baboon))
((not (eq (first record) type)))
((eq type :block)
(when (eq name (second record))
(setf found record)
(return)))
((eq type :tag)
(when (member name (second record) :test #'eql)
(setf found record)
(return)))
((eq name 'si::symbol-macro)
(when (eq (second record) 'si::symbol-macro)
(setf found record))
(return))
(t
(setf found record)
(return))))
(values (first (last found)) ccb clb unw)))
(defun cmp-env-search-block (name &optional (env *cmp-env*))
(cmp-env-search-variables :block name env))
(defun cmp-env-search-tag (name &optional (env *cmp-env*))
(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))
(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)))
(defun cmp-env-mark (mark &optional (env *cmp-env*))
(cons (cons mark (car env))
(cons mark (cdr env))))
(defun cmp-env-new-variables (new-env old-env)
(loop for i in (ldiff (cmp-env-variables *cmp-env*)
(cmp-env-variables old-env))
when (and (consp i) (var-p (fourth i)))
collect (fourth i)))
(defun symbol-macro-declaration-p (name type)
(let* ((record (cmp-env-search-variables name 'si::symbol-macro *cmp-env*)))
(when (and record (functionp record))
(let* ((expression (funcall record name nil)))
(cmp-env-register-symbol-macro name `(the ,type ,expression)))
t)))
(defun check-vdecl (vnames ts is)
(loop for (var . type) in ts
unless (or (member var vnames :test #'eq)
(symbol-macro-declaration-p var type))
do (cmpwarn "Declaration of type~&~4T~A~&was found for not bound variable ~s."
type var))
(loop for (var . expected-uses) in is
unless (member var vnames :test #'eq)
do (cmpwarn (if (minusp expected-uses)
"IGNORE declaration was found for not bound variable ~s."
"IGNORABLE declaration was found for not bound variable ~s.")
var)))
(defun cmp-env-all-optimizations (&optional (env *cmp-env*))
(loop for i in (car env)
when (and (consp i)
(eq (first i) :declare)
(eq (second i) 'optimize))
do (return (cddr i))
finally (return (list *debug* *safety* *space* *speed*))))
(defun cmp-env-optimization (property &optional (env *cmp-env*))
(let ((x (cmp-env-all-optimizations env)))
(case property
(debug (first x))
(safety (second x))
(space (third x))
(speed (fourth x)))))
(defun policy-assume-right-type (&optional (env *cmp-env*))
(< (cmp-env-optimization 'safety env) 2))
(defun policy-check-stack-overflow (&optional (env *cmp-env*))
"Do we add a stack check to every function?"
(>= (cmp-env-optimization 'safety env) 2))
(defun policy-inline-slot-access-p (&optional (env *cmp-env*))
"Do we inline access to structures and sealed classes?"
(or (< (cmp-env-optimization 'safety env) 2)
(<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env))))
(defun policy-check-all-arguments-p (&optional (env *cmp-env*))
"Do we assume that arguments are the right type?"
(> (cmp-env-optimization 'safety env) 1))
(defun policy-automatic-check-type-p (&optional (env *cmp-env*))
"Do we generate CHECK-TYPE forms for function arguments with type declarations?"
(and *automatic-check-type-in-lambda*
(>= (cmp-env-optimization 'safety env) 1)))
(defun policy-assume-types-dont-change-p (&optional (env *cmp-env*))
"Do we assume that type and class definitions will not change?"
(<= (cmp-env-optimization 'safety env) 1))
(defun policy-open-code-aref/aset-p (&optional (env *cmp-env*))
"Do we inline access to arrays?"
(< (cmp-env-optimization 'safety env) 2))
(defun policy-array-bounds-check-p (&optional (env *cmp-env*))
"Check access to array bounds?"
(>= (cmp-env-optimization 'safety env) 1))
(defun policy-debug-ihs-frame (&optional (env *cmp-env*))
"Shall we create an IHS frame so that this function shows up in backtraces?"
;; Note that this is a prerequisite for registering variable bindings. Hence,
;; it has to be recorded in a special variable.
(>= (fun-debug *current-function*) 2))

6
src/cmp/cmpeval.lsp
View file

@ -103,7 +103,7 @@
|#
(t
(let* ((forms (c1args* args))
(return-type (propagate-types fname forms args)))
(return-type (propagate-types fname forms)))
(make-c1form* 'CALL-GLOBAL
:sp-change (function-may-change-sp fname)
:type return-type
@ -117,6 +117,7 @@
(*current-toplevel-form* (c1form-toplevel-form form))
(*current-form* (c1form-form form))
(*current-c2form* form)
(*cmp-env* (c1form-env form))
(name (c1form-name form))
(args (c1form-args form))
(dispatch (get-sysprop name 'C2)))
@ -197,4 +198,5 @@
(put-sysprop 'PROGN 'C1SPECIAL 'c1progn)
(put-sysprop 'PROGN 'C2 'c2progn)
(put-sysprop 'EXT:WITH-BACKEND 'C1SPECIAL 'c1with-backend)
(put-sysprop 'EXT:WITH-BACKEND 'C1SPECIAL 'c1with-backend)
(put-sysprop 'EXT:WITH-BACKEND 'T1 'c1with-backend)

19
src/cmp/cmpflet.lsp
View file

@ -200,17 +200,26 @@
(c2expr body)
(when block-p (wt-nl "}")))
(defun c1decl-body (decls body)
(if (null decls)
(c1progn body)
(let* ((*cmp-env* (reduce #'add-one-declaration decls
:initial-value (cmp-env-copy *cmp-env*))))
(c1progn body))))
(defun c1locally (args)
(multiple-value-bind (body ss ts is other-decl)
(c1body args t)
(c1declare-specials ss)
(check-vdecl nil ts is)
(c1decl-body other-decl body)))
(if (or ss ts is other-decl)
(let ((*cmp-env* (cmp-env-copy)))
(c1declare-specials ss)
(check-vdecl nil ts is)
(c1decl-body other-decl body))
(c1progn body))))
(defun c1macrolet (args)
(check-args-number 'MACROLET args 1)
(let ((*cmp-env* (cmp-env-copy)))
(cmp-env-register-macrolet (first args) *cmp-env*)
(let ((*cmp-env* (cmp-env-register-macrolet (first args) (cmp-env-copy))))
(c1locally (cdr args))))
(defun c1symbol-macrolet (args)

89
src/cmp/cmpform.lsp Normal file
View file

@ -0,0 +1,89 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 2009, 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.
;;;;
;;;; CMPFORM -- Internal representation of Lisp forms
;;;;
(in-package "COMPILER")
(defun print-c1form (form stream)
(format stream "#<form ~A ~X>" (c1form-name form) (ext::pointer form)))
(defun make-c1form (name subform &rest args)
(let ((form (do-make-c1form :name name :args args
:type (info-type subform)
:sp-change (info-sp-change subform)
:volatile (info-volatile subform)
:form *current-form*
:toplevel-form *current-toplevel-form*
:file *compile-file-truename*
:file-position *compile-file-position*)))
(c1form-add-info form args)
form))
(defun make-c1form* (name &rest args)
(let ((info-args '())
(form-args '()))
(do ((l args (cdr l)))
((endp l))
(let ((key (first l)))
(cond ((not (keywordp key))
(baboon))
((eq key ':args)
(setf form-args (rest l))
(return))
(t
(setf info-args (list* key (second l) info-args)
l (cdr l))))))
(let ((form (apply #'do-make-c1form :name name :args form-args
:form *current-form*
:toplevel-form *current-toplevel-form*
:file *compile-file-truename*
:file-position *compile-file-position*
info-args)))
(c1form-add-info form form-args)
form)))
(defun c1form-add-info (form dependents)
(dolist (subform dependents form)
(cond ((c1form-p subform)
(when (info-sp-change subform)
(setf (info-sp-change form) t))
(setf (c1form-parent subform) form))
((consp subform)
(c1form-add-info form subform)))))
(defun copy-c1form (form)
(copy-structure form))
(defmacro c1form-arg (nth form)
(case nth
(0 `(first (c1form-args ,form)))
(1 `(second (c1form-args ,form)))
(otherwise `(nth ,nth (c1form-args ,form)))))
(defun c1form-volatile* (form)
(if (c1form-volatile form) "volatile " ""))
(defun c1form-primary-type (form)
(values-type-primary-type (c1form-type form)))
#-new-cmp
(defun location-primary-type (form)
(c1form-primary-type form))
(defun find-node-in-list (home-node list)
(flet ((parent-node-p (node presumed-child)
(loop
(cond ((null presumed-child) (return nil))
((eq node presumed-child) (return t))
(t (setf presumed-child (c1form-parent presumed-child)))))))
(member home-node list :test #'parent-node-p)))

87
src/new-cmp/cmpglobals.lsp → src/cmp/cmpglobals.lsp
View file

@ -1,7 +1,6 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; 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
@ -10,10 +9,10 @@
;;;;
;;;; See file '../Copyright' for full details.
;;;;
;;;; CMPVARS -- Global variables and flag definitions
;;;; CMPGLOBALS -- Global variables and flag definitions
;;;;
(in-package "C-DATA")
(in-package #-new-cmp "COMPILER" #+new-cmp "C-DATA")
;;;
;;; VARIABLES
@ -23,11 +22,9 @@
;;;
;;; Empty info struct
;;;
(defvar *inline-functions* nil)
#-new-cmp
(defvar *info* (make-info))
(defvar *inline-blocks* 0)
;;; *inline-functions* holds:
;;; (...( function-name . inline-info )...)
;;;
;;; *inline-blocks* holds the number of C blocks opened for declaring
;;; temporaries for intermediate results of the evaluation of inlined
;;; function calls.
@ -36,8 +33,8 @@
;;;
;;; Variables and constants for error handling
;;;
(defvar *current-toplevel-form* '|compiler preprocess|)
(defvar *current-form* '|compiler preprocess|)
(defvar *current-toplevel-form* '|compiler preprocess|)
(defvar *current-c2form* nil)
(defvar *compile-file-position* -1)
(defvar *first-error* t)
@ -58,7 +55,7 @@ each form it processes. The default value is NIL.")
"This variable controls whether the compiler should display messages about its
progress. The default value is T.")
(defvar *suppress-compiler-messages* nil
(defvar *suppress-compiler-messages* 'compiler-debug-note
"A type denoting which compiler messages and conditions are _not_ displayed.")
(defvar *suppress-compiler-notes* nil) ; Deprecated
@ -70,7 +67,6 @@ progress. The default value is T.")
(defvar *compiler-input*)
(defvar *compiler-output1*)
(defvar *compiler-output2*)
(defvar *dump-output*)
;;; --cmpcbk.lsp--
;;;
@ -106,6 +102,11 @@ progress. The default value is T.")
(defvar *lcl* 0) ; number of local variables
#-new-cmp
(defvar *temp* 0) ; number of temporary variables
#-new-cmp
(defvar *max-temp* 0) ; maximum *temp* reached
(defvar *level* 0) ; nesting level for local functions
(defvar *lex* 0) ; number of lexical variables in local functions
@ -114,7 +115,13 @@ progress. The default value is T.")
(defvar *env* 0) ; number of variables in current form
(defvar *max-env* 0) ; maximum *env* in whole function
(defvar *env-lvl* 0) ; number of levels of environments
#-new-cmp
(defvar *aux-closure* nil) ; stack allocated closure needed for indirect calls
#-new-cmp
(defvar *ihs-used-p* nil) ; function must be registered in IHS?
#-new-cmp
(defvar *next-cmacro* 0) ; holds the last cmacro number used.
(defvar *next-cfun* 0) ; holds the last cfun used.
;;;
@ -126,7 +133,6 @@ progress. The default value is T.")
(defvar *tail-recursion-info* nil)
(defvar *allow-c-local-declaration* t)
(defvar *notinline* nil)
;;; --cmpexit.lsp--
;;;
@ -146,7 +152,7 @@ progress. The default value is T.")
(defvar *current-function* nil)
(defvar *cmp-env* (cons nil nil)
(defvar *cmp-env* nil
"The compiler environment consists of a pair or cons of two
lists, one containing variable records, the other one macro and
function recors:
@ -172,6 +178,11 @@ boundaries. Note 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 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*.")
;;; --cmplog.lsp--
;;;
;;; Destination of output of different forms. See cmploc.lsp for types
@ -187,6 +198,20 @@ object at the end.")
(defvar *delete-files* t)
(defvar *files-to-be-deleted* '())
(defvar *user-ld-flags* '()
"Flags and options to be passed to the linker when building FASL, shared libraries
and standalone programs. It is not required to surround values with quotes or use
slashes before special characters.")
(defvar *user-cc-flags* '()
"Flags and options to be passed to the C compiler when building FASL, shared libraries
and standalone programs. It is not required to surround values with quotes or use
slashes before special characters.")
;;;
;;; Compiler program and flags.
;;;
;;; --cmptop.lsp--
;;;
(defvar *do-type-propagation* nil
@ -195,16 +220,21 @@ object at the end.")
(defvar *compiler-phase* nil)
(defvar *volatile*)
#-new-cmp
(defvar *setjmps* 0)
(defvar *compile-toplevel* T
"Holds NIL or T depending on whether we are compiling a toplevel form.")
(defvar *compile-time-too* nil)
(defvar *clines-string-list* '()
"List of strings containing C/C++ statements which are directly inserted
in the translated C/C++ file. Notice that it is unspecified where these
lines are inserted, but the order is preserved")
(defvar *compile-time-too* nil)
#-new-cmp
(defvar *not-compile-time* nil)
(defvar *permanent-data* nil) ; detemines whether we use *permanent-objects*
; or *temporary-objects*
(defvar *permanent-objects* nil) ; holds { ( object (VV vv-index) ) }*
@ -214,8 +244,10 @@ lines are inserted, but the order is preserved")
;;; where each vv-index should be given an object before
;;; defining the current function during loading process.
(defvar *use-static-constants-p* t) ; T/NIL flag to determine whether one may
(defvar *use-static-constants-p* nil) ; T/NIL flag to determine whether one may
; generate lisp constant values as C structs
(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
; only used in COMPILE
@ -232,7 +264,6 @@ lines are inserted, but the order is preserved")
(defvar *local-funs* nil) ; holds { fun }*
(defvar *top-level-forms* nil) ; holds { top-level-form }*
(defvar *make-forms* nil) ; holds { top-level-form }*
(defvar +init-function-name+ (gensym "ENTRY-POINT"))
;;;
;;; top-level-form:
@ -244,11 +275,16 @@ lines are inserted, but the order is preserved")
;;; | ( 'CLINES' string* )
;;; | ( 'LOAD-TIME-VALUE' vv )
#-new-cmp
(defvar *reservations* nil)
(defvar *reservation-cmacro* nil)
;;; *reservations* holds (... ( cmacro . value ) ...).
;;; *reservation-cmacro* holds the cmacro current used as vs reservation.
;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...).
(defvar *global-entries* nil)
(defvar *self-destructing-fasl* '()
"A value T means that, when a FASL module is being unloaded (for
instance during garbage collection), the associated file will be
@ -266,8 +302,15 @@ be deleted if they have been opened with LoadLibrary.")
(*compiler-in-use* t)
(*compiler-phase* 't1)
(*callbacks* nil)
(*cmp-env-root* (cmp-env-copy *cmp-env-root*))
(*cmp-env* nil)
#-new-cmp
(*max-temp* 0)
#-new-cmp
(*temp* 0)
#-new-cmp
(*next-cmacro* 0)
(*next-cfun* 0)
(*lcl* 0)
(*last-label* 0)
(*load-objects* (make-hash-table :size 128 :test #'equal))
(*make-forms* nil)
@ -282,16 +325,24 @@ be deleted if they have been opened with LoadLibrary.")
(*linking-calls* nil)
(*global-entries* nil)
(*undefined-vars* nil)
#-new-cmp
(*reservations* nil)
(*top-level-forms* nil)
(*compile-time-too* nil)
(*clines-string-list* '())
(*inline-functions* nil)
(*inline-blocks* 0)
(*debugger-hook* 'compiler-debugger)
#+new-cmp
(*type-and-cache* (type-and-empty-cache))
#+new-cmp
(*type-or-cache* (type-or-empty-cache))
#+new-cmp
(*values-type-or-cache* (values-type-or-empty-cache))
#+new-cmp
(*values-type-and-cache* (values-type-and-empty-cache))
#+new-cmp
(*values-type-primary-type-cache* (values-type-primary-type-empty-cache))
#+new-cmp
(*values-type-to-n-types-cache* (values-type-to-n-types-empty-cache))
))

4
src/cmp/cmpinline.lsp
View file

@ -195,10 +195,6 @@
(defun get-inline-info (fname types return-type return-rep-type)
(declare (si::c-local))
(let ((output nil))
(dolist (x *inline-functions*)
(when (eq (car x) fname)
(let ((other (inline-type-matches (cdr x) types return-type)))
(setf output (choose-inline-info output other return-type return-rep-type)))))
(unless (safe-compile)
(dolist (x (get-sysprop fname ':INLINE-UNSAFE))
(let ((other (inline-type-matches x types return-type)))

26
src/cmp/cmplam.lsp
View file

@ -82,7 +82,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(when *current-function*
(push fun (fun-child-funs *current-function*)))
(let* ((*current-function* fun)
(*cmp-env* (cmp-env-mark CB/LB))
(*cmp-env* (setf (fun-cmp-env fun) (cmp-env-mark CB/LB)))
(setjmps *setjmps*)
(decl (si::process-declarations (rest lambda-list-and-body)))
(lambda-expr (c1lambda-expr lambda-list-and-body
@ -92,9 +92,9 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(debug (search-optimization-quality decl 'debug))
(no-entry (assoc 'SI::C-LOCAL decl))
cfun exported minarg maxarg)
(when (and no-entry (>= debug 2))
(when (and no-entry (policy-debug-ihs-frame))
(setf no-entry nil)
(cmpnote "Ignoring SI::C-LOCAL declaration for ~A when DEBUG is ~D" name debug))
(cmpnote "Ignoring SI::C-LOCAL declaration for~%~4I~A~%because the debug level is large" name))
(unless (eql setjmps *setjmps*)
(setf (c1form-volatile lambda-expr) t))
(setf (fun-lambda fun) lambda-expr)
@ -122,8 +122,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(fun-minarg fun) minarg
(fun-maxarg fun) maxarg
(fun-description fun) name
(fun-no-entry fun) no-entry
(fun-debug fun) debug)
(fun-no-entry fun) no-entry)
(reduce #'add-referred-variables-to-function
(mapcar #'fun-referred-vars children)
:initial-value fun)
@ -316,7 +315,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
|#
(defun c2lambda-expr
(lambda-list body cfun fname use-narg fname-in-ihs-p
(lambda-list body cfun fname use-narg
&optional closure-type local-entry-p
&aux (requireds (first lambda-list))
(optionals (second lambda-list))
@ -327,6 +326,9 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(nopt (/ (length optionals) 3))
(nkey (/ (length keywords) 4))
(varargs (or optionals rest keywords allow-other-keys))
(fname-in-ihs-p (or (policy-debug-variable-bindings)
(and (policy-debug-ihs-frame)
fname)))
simple-varargs
(*permanent-data* t)
(*unwind-exit* *unwind-exit*)
@ -433,14 +435,12 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(when fname-in-ihs-p
(wt-nl "{")
(setf *ihs-used-p* t)
(push 'IHS *unwind-exit*)
(cond ((>= *debug-fun* 3)
(build-debug-lexical-env (reverse requireds) t)
(wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname)
",_ecl_debug_env);"))
(t
(wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname)
",Cnil);"))))
(when (policy-debug-variable-bindings)
(build-debug-lexical-env (reverse requireds) t))
(wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname)
",_ecl_debug_env);"))
(setq *lcl* lcl))

36
src/cmp/cmplet.lsp
View file

@ -232,15 +232,15 @@
(dolist (binding (nreverse bindings))
(bind (cdr binding) (car binding)))
(if (and *debug-fun* (>= *debug-fun* 3))
(let ((*unwind-exit* *unwind-exit*))
(wt-nl "{")
(let* ((env (build-debug-lexical-env vars)))
(when env (push 'IHS-ENV *unwind-exit*))
(c2expr body)
(wt-nl "}")
(when env (pop-debug-lexical-env))))
(c2expr body))
(if (policy-debug-variable-bindings)
(let ((*unwind-exit* *unwind-exit*))
(wt-nl "{")
(let* ((env (build-debug-lexical-env vars)))
(when env (push 'IHS-ENV *unwind-exit*))
(c2expr body)
(wt-nl "}")
(when env (pop-debug-lexical-env))))
(c2expr body))
(when block-p (wt-nl "}"))
)
@ -452,15 +452,15 @@
(c2expr* form)))
)
)
(if (and *debug-fun* (>= *debug-fun* 3))
(let ((*unwind-exit* *unwind-exit*))
(wt-nl "{")
(let* ((env (build-debug-lexical-env vars)))
(when env (push 'IHS-ENV *unwind-exit*))
(c2expr body)
(wt-nl "}")
(when env (pop-debug-lexical-env))))
(c2expr body))
(if (policy-debug-variable-bindings)
(let ((*unwind-exit* *unwind-exit*))
(wt-nl "{")
(let* ((env (build-debug-lexical-env vars)))
(when env (push 'IHS-ENV *unwind-exit*))
(c2expr body)
(wt-nl "}")
(when env (pop-debug-lexical-env))))
(c2expr body))
(when block-p (wt-nl "}"))
)

195
src/cmp/cmpmac.lsp
View file

@ -3,8 +3,56 @@
;;; ----------------------------------------------------------------------
;;; Macros only used in the code of the compiler itself:
#-new-cmp
(in-package "COMPILER")
#-new-cmp
(import 'sys::arglist "COMPILER")
#+new-cmp
(in-package "C-DATA")
;; ----------------------------------------------------------------------
;; 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 'SI::HASH-EQUAL)
(t (setf test 'EQUALP) 'SI::HASH-EQUALP)))
(hash (gensym "HASH")))
`(progn
(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 (the cons elt)) ,arg)))
(first (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 ,@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))
@ -16,139 +64,22 @@
(defmacro next-label* () `(cons (incf *last-label*) t))
(defmacro wt-go (label)
`(progn (rplacd ,label t) (wt "goto L" (car ,label) ";")))
(defun next-lcl () (list 'LCL (incf *lcl*)))
;;; from cmplam.lsp
(defmacro ck-spec (condition)
`(unless ,condition
(cmperr "The parameter specification ~s is illegal." spec)))
(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))))
(defmacro ck-vl (condition)
`(unless ,condition
(cmperr "The lambda list ~s is illegal." vl)))
(defun next-temp ()
(prog1 *temp*
(incf *temp*)
(setq *max-temp* (max *temp* *max-temp*))))
;;; fromcmputil.sp
(defmacro cmpck (condition string &rest args)
`(if ,condition (cmperr ,string ,@args)))
(defun next-lex ()
(prog1 (cons *level* *lex*)
(incf *lex*)
(setq *max-lex* (max *lex* *max-lex*))))
(defmacro cmpassert (condition string &rest args)
`(unless ,condition (cmperr ,string ,@args)))
;;; from cmpwt.lsp
(defmacro wt (&rest forms &aux (fl nil))
(dolist (form forms `(progn ,@(nreverse (cons nil fl))))
(if (stringp form)
(push `(princ ,form *compiler-output1*) fl)
(push `(wt1 ,form) fl))))
(defmacro wt-h (&rest forms &aux (fl nil))
(dolist (form forms `(progn ,@(nreverse (cons nil fl))))
(if (stringp form)
(push `(princ ,form *compiler-output2*) fl)
(push `(wt-h1 ,form) fl))))
(defmacro wt-nl-h (&rest forms)
`(progn (terpri *compiler-output2*) (wt-h ,@forms)))
(defmacro princ-h (form) `(princ ,form *compiler-output2*))
(defmacro wt-nl (&rest forms)
`(wt #\Newline #\Tab ,@forms))
(defmacro wt-nl1 (&rest forms)
`(wt #\Newline ,@forms))
(defmacro safe-compile ()
`(>= (cmp-env-optimization 'safety) 2))
(defmacro compiler-check-args ()
`(>= (cmp-env-optimization 'safety) 1))
(defmacro compiler-push-events ()
`(>= (cmp-env-optimization 'safety) 3))
;; ----------------------------------------------------------------------
;; C1-FORMS
;;
(defstruct (c1form (:include info)
(:print-object print-c1form)
(:constructor do-make-c1form))
(name nil)
(parent nil)
(args '())
(form nil)
(toplevel-form nil)
(file nil)
(file-position 0))
(defun print-c1form (form stream)
(format stream "#<form ~A ~X>" (c1form-name form) (ext::pointer form)))
(defun make-c1form (name subform &rest args)
(let ((form (do-make-c1form :name name :args args
:type (info-type subform)
:sp-change (info-sp-change subform)
:volatile (info-volatile subform)
:form *current-form*
:toplevel-form *current-toplevel-form*
:file *compile-file-truename*
:file-position *compile-file-position*)))
(c1form-add-info form args)
form))
(defun make-c1form* (name &rest args)
(let ((info-args '())
(form-args '()))
(do ((l args (cdr l)))
((endp l))
(let ((key (first l)))
(cond ((not (keywordp key))
(baboon))
((eq key ':args)
(setf form-args (rest l))
(return))
(t
(setf info-args (list* key (second l) info-args)
l (cdr l))))))
(let ((form (apply #'do-make-c1form :name name :args form-args
:form *current-form*
:toplevel-form *current-toplevel-form*
:file *compile-file-truename*
:file-position *compile-file-position*
info-args)))
(c1form-add-info form form-args)
form)))
(defun c1form-add-info (form dependents)
(dolist (subform dependents form)
(cond ((c1form-p subform)
(when (info-sp-change subform)
(setf (info-sp-change form) t))
(setf (c1form-parent subform) form))
((consp subform)
(c1form-add-info form subform)))))
(defun copy-c1form (form)
(copy-structure form))
(defmacro c1form-arg (nth form)
(case nth
(0 `(first (c1form-args ,form)))
(1 `(second (c1form-args ,form)))
(otherwise `(nth ,nth (c1form-args ,form)))))
(defun c1form-volatile* (form)
(if (c1form-volatile form) "volatile " ""))
(defun c1form-primary-type (form)
(values-type-primary-type (c1form-type form)))
(defun find-node-in-list (home-node list)
(flet ((parent-node-p (node presumed-child)
(loop
(cond ((null presumed-child) (return nil))
((eq node presumed-child) (return t))
(t (setf presumed-child (c1form-parent presumed-child)))))))
(member home-node list :test #'parent-node-p)))
(defun next-env () (prog1 *env*
(incf *env*)
(setq *max-env* (max *env* *max-env*))))

5
src/cmp/cmpmulti.lsp
View file

@ -238,9 +238,10 @@
(c2expr* form)
(do-m-v-setq-any min-values max-values vars nil))))))
(defun c1multiple-value-bind (args &aux (*cmp-env* (cmp-env-copy)))
(defun c1multiple-value-bind (args)
(check-args-number 'MULTIPLE-VALUE-BIND args 2)
(let* ((variables (pop args))
(let* ((*cmp-env* (cmp-env-copy))
(variables (pop args))
(init-form (pop args)))
(when (= (length variables) 1)
(return-from c1multiple-value-bind

4
src/cmp/cmpnum.lsp
View file

@ -38,8 +38,8 @@
(t
(error 'simple-program-error
:format-error "Wrong number of arguments for operator ~a in ~a"
:format-arguments (list operators (or whole
(list* operator args)))))))))
:format-arguments (list operator (or whole
(list* operator args)))))))))
(define-compiler-macro * (&whole all &rest args)
(simplify-arithmetic '* args all))

51
src/cmp/cmppackage.lsp Normal file
View file

@ -0,0 +1,51 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 2009, 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.
;;;;
;;;; CMPPACKAGE -- Package definitions and exported symbols
;;;;
(si::package-lock "CL" nil)
(defpackage "C"
(:nicknames "COMPILER")
(:use "FFI" "CL" #+threads "MP")
(:export "*COMPILER-BREAK-ENABLE*"
"*COMPILE-PRINT*"
"*COMPILE-TO-LINKING-CALL*"
"*COMPILE-VERBOSE*"
"*CC*"
"*CC-OPTIMIZE*"
"*USER-CC-FLAGS*"
"*USER-LD-FLAGS*"
"*SUPPRESS-COMPILER-NOTES*"
"*SUPPRESS-COMPILER-WARNINGS*"
"*SUPPRESS-COMPILER-MESSAGES*"
"BUILD-ECL"
"BUILD-PROGRAM"
"BUILD-FASL"
"BUILD-STATIC-LIBRARY"
"BUILD-SHARED-LIBRARY"
"COMPILER-WARNING"
"COMPILER-NOTE"
"COMPILER-MESSAGE"
"COMPILER-ERROR"
"COMPILER-FATAL-ERROR"
"COMPILER-INTERNAL-ERROR"
"COMPILER-UNDEFINED-VARIABLE"
"COMPILER-MESSAGE-FILE"
"COMPILER-MESSAGE-FILE-POSITION"
"COMPILER-MESSAGE-FORM"
"*SUPPRESS-COMPILER-WARNINGS*"
"*SUPPRESS-COMPILER-NOTES*"
"*SUPPRESS-COMPILER-MESSAGES*")
(:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO"
"*COMPILER-CONSTANTS*" "REGISTER-GLOBAL" "CMP-ENV-REGISTER-MACROLET"
"COMPILER-LET"))

105
src/cmp/cmppolicy.lsp Normal file
View file

@ -0,0 +1,105 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; 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.
;;;;
;;;; CMPPOLICY -- Code generation choices
;;;;
(in-package #-new-cmp "COMPILER" #+new-cmp "C-ENV")
(defun cmp-env-all-optimizations (&optional (env *cmp-env*))
(or (cmp-env-search-declaration 'optimize)
(list *debug* *safety* *space* *speed*)))
(defun cmp-env-optimization (property &optional (env *cmp-env*))
(let ((x (cmp-env-all-optimizations env)))
(case property
(debug (first x))
(safety (second x))
(space (third x))
(speed (fourth x)))))
(defun policy-assume-right-type (&optional (env *cmp-env*))
(< (cmp-env-optimization 'safety env) 2))
(defun policy-check-stack-overflow (&optional (env *cmp-env*))
"Do we add a stack check to every function?"
(>= (cmp-env-optimization 'safety env) 2))
(defun policy-inline-slot-access-p (&optional (env *cmp-env*))
"Do we inline access to structures and sealed classes?"
(or (< (cmp-env-optimization 'safety env) 2)
(<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env))))
(defun policy-check-all-arguments-p (&optional (env *cmp-env*))
"Do we assume that arguments are the right type?"
(> (cmp-env-optimization 'safety env) 1))
(defun policy-automatic-check-type-p (&optional (env *cmp-env*))
"Do we generate CHECK-TYPE forms for function arguments with type declarations?"
(and *automatic-check-type-in-lambda*
(>= (cmp-env-optimization 'safety env) 1)))
(defun policy-assume-types-dont-change-p (&optional (env *cmp-env*))
"Do we assume that type and class definitions will not change?"
(<= (cmp-env-optimization 'safety env) 1))
(defun policy-open-code-aref/aset-p (&optional (env *cmp-env*))
"Do we inline access to arrays?"
(< (cmp-env-optimization 'debug env) 2))
(defun policy-open-code-accessors (&optional (env *cmp-env*))
"Do we inline access to object slots, including conses and arrays?"
(< (cmp-env-optimization 'debug env) 2))
(defun policy-array-bounds-check-p (&optional (env *cmp-env*))
"Check access to array bounds?"
(>= (cmp-env-optimization 'safety env) 1))
(defun policy-evaluate-forms (&optional (env *cmp-env*))
"Pre-evaluate a function that takes constant arguments?"
(<= (cmp-env-optimization 'debug env) 1))
(defun policy-use-direct-C-call (&optional (env *cmp-env*))
"Emit direct calls to a function whose C name is known"
(<= (cmp-env-optimization 'debug env) 1))
(defun policy-global-var-checking (&optional (env *cmp-env*))
"Do we have to read the value of a global variable even if it is discarded?
Also, when reading the value of a global variable, should we ensure it is bound?"
(>= (cmp-env-optimization 'safety env) 1))
(defun policy-global-function-checking (&optional (env *cmp-env*))
"Do we have to read the binding of a global function even if it is discarded?"
(>= (cmp-env-optimization 'safety env) 1))
(defun policy-debug-variable-bindings (&optional (env *cmp-env*))
"Shall we create a vector with the bindings of each LET/LET*/LAMBDA form?"
;; We can only create variable bindings when the function has an IHS frame!!!
(and (policy-debug-ihs-frame env)
(>= (cmp-env-optimization 'debug env) 3)))
(defun policy-debug-ihs-frame (&optional (env *cmp-env*))
"Shall we create an IHS frame so that this function shows up in backtraces?"
;; Note that this is a prerequisite for registering variable bindings.
(or (>= (cmp-env-optimization 'debug env) 2)
(first (cmp-env-search-declaration 'policy-debug-ihs-frame))))
(defun policy-check-nargs (&optional (env *cmp-env*))
(>= (cmp-env-optimization 'safety) 1))
(defun safe-compile ()
(>= (cmp-env-optimization 'safety) 2))
(defun compiler-check-args ()
(>= (cmp-env-optimization 'safety) 1))
(defun compiler-push-events ()
(>= (cmp-env-optimization 'safety) 3))

2
src/cmp/cmpprop.lsp
View file

@ -215,7 +215,7 @@ of the occurrences in those lists."
do (multiple-value-bind (arg-type local-ass)
(p1propagate v assumptions)
(setf assumptions local-ass))
finally (let ((type (propagate-types fname args nil)))
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-type args) type (c1form-type c1form))
(return (values type assumptions)))))

2
src/cmp/cmptag.lsp
View file

@ -78,7 +78,7 @@
collect (if (consp x)
x
(let ((tag (make-tag :name x :var tag-var :index tag-index)))
(cmp-env-register-tag tag)
(cmp-env-register-tag (tag-name tag) tag)
(incf tag-index)
tag))))
;; Split forms according to the tag they are preceded by and compile

60
src/cmp/cmptop.lsp
View file

@ -16,7 +16,7 @@
(defun t1expr (form)
(let* ((*current-toplevel-form* nil)
(*cmp-env* (cmp-env-new)))
(*cmp-env* (cmp-env-copy (or *cmp-env* *cmp-env-root*))))
(push (t1expr* form) *top-level-forms*)))
(defvar *toplevel-forms-to-print*
@ -67,8 +67,17 @@
(defun t2expr (form)
(when form
(let ((def (get-sysprop (c1form-name form) 'T2)))
(when def (apply def (c1form-args form))))))
(let* ((def (get-sysprop (c1form-name form) 'T2)))
(if def
(let ((*compile-file-truename* (c1form-file form))
(*compile-file-position* (c1form-file-position form))
(*current-toplevel-form* (c1form-form form))
(*current-form* (c1form-form form))
(*current-c2form* form)
(*cmp-env* (c1form-env form)))
(apply def (c1form-args form)))
(cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A"
form)))))
(defvar *emitted-local-funs* nil)
@ -280,7 +289,7 @@
(progv symbols values (c2expr body)))
(defun t2progn (args)
(mapcar #'t2expr args))
(mapc #'t2expr args))
(defun exported-fname (name)
(let (cname)
@ -376,7 +385,10 @@
(wt-h "T" i)
(unless (= (1+ i) *max-temp*) (wt-h ",")))
(wt-h ";"))
; (wt-nl-h "#define VU" *reservation-cmacro*)
(when *ihs-used-p*
(wt-h " \\")
(wt-nl-h "struct ihs_frame ihs; \\")
(wt-nl-h "const cl_object _ecl_debug_env = Cnil;"))
(wt-nl-h "#define VLEX" *reservation-cmacro*)
;; There should be no need to mark lex as volatile, since we
;; are going to pass pointers of this array around and the compiler
@ -509,12 +521,6 @@
(c2expr form)
(wt-label *exit*)))
(defun t2decl-body (decls body)
(let ((*cmp-env* *cmp-env*)
(*notinline* *notinline*))
(c1add-declarations decls)
(t2expr body)))
(defun parse-cvspecs (x &aux (cvspecs nil))
(dolist (cvs x (nreverse cvspecs))
(cond ((symbolp cvs)
@ -533,8 +539,6 @@
(t (cmperr "The C variable specification ~s is illegal." cvs))))
)
(defvar *debug-fun* nil)
(defun locative-type-from-var-kind (kind)
(cdr (assoc kind
'((:object . "_ecl_object_loc")
@ -545,11 +549,6 @@
((special global closure replaced lexical) . NIL)))))
(defun build-debug-lexical-env (var-locations &optional first)
#+:msvc
(if first
(wt-nl "cl_object _ecl_debug_env = Cnil;")
(wt-nl "ihs.lex_env = _ecl_debug_env = Cnil;"))
#-:msvc ;; FIXME! Problem with initialization of statically defined vectors
(let* ((filtered-locations '())
(filtered-codes '()))
@ -569,6 +568,7 @@
;; variables, including name and type, and dynamic one, which is
;; a vector of pointer to the variables.
(when filtered-codes
(setf *ihs-used-p* t)
(wt-nl "static const struct ecl_var_debug_info _ecl_descriptors[]={")
(loop for (name . code) in filtered-codes
for i from 0
@ -582,12 +582,9 @@
(wt "};")
(wt-nl "ecl_def_ct_vector(_ecl_debug_env,aet_index,_ecl_debug_info_raw,"
(+ 2 (length filtered-locations))
",,);"))
(if first
(if (not filtered-codes)
(wt-nl "cl_object _ecl_debug_env = Cnil;"))
(if filtered-codes
(wt-nl "ihs.lex_env=_ecl_debug_env;")))
",,);")
(unless first
(wt-nl "ihs.lex_env=_ecl_debug_env;")))
filtered-codes))
(defun pop-debug-lexical-env ()
@ -605,8 +602,7 @@
(*volatile* (c1form-volatile* lambda-expr))
(*tail-recursion-info* fun)
(lambda-list (c1form-arg 0 lambda-expr))
(requireds (car lambda-list))
(*debug-fun* *debug-fun*))
(requireds (car lambda-list)))
(declare (fixnum level nenvs))
(print-emitting fun)
(wt-comment-nl (cond ((fun-global fun) "function definition for ~a")
@ -652,8 +648,10 @@
(*level* level)
(*exit* 'RETURN) (*unwind-exit* '(RETURN))
(*destination* 'RETURN)
(*ihs-used-p* nil)
(*reservation-cmacro* (next-cmacro))
(*inline-blocks* 1))
(*inline-blocks* 1)
(*cmp-env* (cmp-env-copy (fun-cmp-env fun))))
(wt-nl1 "{")
(wt " VT" *reservation-cmacro*
" VLEX" *reservation-cmacro*
@ -663,9 +661,6 @@
(when (eq (fun-closure fun) 'CLOSURE)
(wt "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;"))
(wt-nl *volatile* "cl_object value0;")
(when (>= (fun-debug fun) 2)
(setq *debug-fun* (fun-debug fun))
(wt-nl "struct ihs_frame ihs;"))
(when (policy-check-stack-overflow)
(wt-nl "ecl_cs_check(cl_env_copy,value0);"))
(when (eq (fun-closure fun) 'CLOSURE)
@ -706,11 +701,11 @@
(c1form-arg 2 lambda-expr)
(fun-cfun fun) (fun-name fun)
narg
(>= (fun-debug fun) 2)
(fun-closure fun))
(wt-nl1)
(close-inline-blocks)
(wt-function-epilogue (fun-closure fun))) ; we should declare in CLSR only those used
;; we should declare in CLSR only those used
(wt-function-epilogue (fun-closure fun)))
)
;;; ----------------------------------------------------------------------
@ -819,7 +814,6 @@
;;; Pass 2 initializers.
(put-sysprop 'COMPILER-LET 'T2 't2compiler-let)
(put-sysprop 'DECL-BODY 't2 't2decl-body)
(put-sysprop 'PROGN 'T2 't2progn)
(put-sysprop 'ORDINARY 'T2 't2ordinary)
(put-sysprop 'LOAD-TIME-VALUE 'T2 't2load-time-value)

329
src/cmp/cmptype-arith.lsp Normal file
View file

@ -0,0 +1,329 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;;
;;;; 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.
;;;; CMPTYPE-ARITH -- Operations upon and among types
(in-package #-new-cmp "COMPILER" #+new-cmp "C-TYPES")
;;; CL-TYPE is any valid type specification of Common Lisp.
;;;
;;; TYPE is a representation type used by ECL. TYPE is one of:
;;;
;;; T(BOOLEAN)
;;;
;;; FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT
;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM)
;;; (VECTOR SINGLE-FLOAT) (VECTOR DOUBLE-FLOAT)
;;; (ARRAY T) (ARRAY BASE-CHAR) (ARRAY BIT)
;;; (ARRAY FIXNUM)
;;; (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT)
;;; STANDARD-OBJECT STRUCTURE-OBJECT
;;; SYMBOL
;;; UNKNOWN
;;;
;;; NIL
;;;
;;;
;;; immediate-type:
;;; FIXNUM int
;;; CHARACTER char
;;; SINGLE-FLOAT float
;;; DOUBLE-FLOAT double
(deftype any () 't)
(defun member-type (type disjoint-supertypes)
(member type disjoint-supertypes :test #'subtypep))
;;; Check if THING is an object of the type TYPE.
;;; Depends on the implementation of TYPE-OF.
;;; (only used for saving constants?)
#-new-cmp
(defun object-type (thing)
(let ((type (if thing (type-of thing) 'SYMBOL)))
(case type
((FIXNUM SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SYMBOL NULL) type)
((BASE-CHAR STANDARD-CHAR CHARACTER EXTENDED-CHAR) 'CHARACTER)
((STRING BASE-STRING BIT-VECTOR) type)
(VECTOR (list 'VECTOR (array-element-type thing)))
(ARRAY (list 'ARRAY (array-element-type thing)))
#+clos
(STANDARD-OBJECT 'STANDARD-OBJECT)
#+clos
(STRUCTURE-OBJECT 'STRUCTURE-OBJECT)
(t t))))
(defun type-filter (type &optional values-allowed)
(multiple-value-bind (type-name type-args) (sys::normalize-type type)
(case type-name
((FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT SYMBOL) type-name)
(SHORT-FLOAT #-short-float 'SINGLE-FLOAT #+short-float 'SHORT-FLOAT)
(LONG-FLOAT #-long-float 'DOUBLE-FLOAT #+long-float 'LONG-FLOAT)
((SIMPLE-STRING STRING) 'STRING)
((SIMPLE-BIT-VECTOR BIT-VECTOR) 'BIT-VECTOR)
((NIL T) t)
((SIMPLE-ARRAY ARRAY)
(cond ((endp type-args) '(ARRAY *)) ; Beppe
((eq '* (car type-args)) t)
(t (let ((element-type (upgraded-array-element-type (car type-args)))
(dimensions (if (cdr type-args) (second type-args) '*)))
(if (and (not (eq dimensions '*))
(or (numberp dimensions)
(= (length dimensions) 1)))
(case element-type
(BASE-CHAR 'STRING)
(BIT 'BIT-VECTOR)
(t (list 'VECTOR element-type)))
(list 'ARRAY element-type))))))
(INTEGER (if (subtypep type 'FIXNUM) 'FIXNUM t))
((STREAM CONS) type-name) ; Juanjo
(FUNCTION type-name)
(t (cond ((eq type-name 'VALUES)
(unless values-allowed
(error "VALUES type found in a place where it is not allowed."))
`(VALUES ,@(mapcar #'(lambda (x)
(if (or (eq x '&optional)
(eq x '&rest))
x
(type-filter x)))
type-args)))
#+clos
((subtypep type 'STANDARD-OBJECT) type)
#+clos
((subtypep type 'STRUCTURE-OBJECT) type)
((dolist (v '(FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT
#+short-float SHORT-FLOAT #+long-float LONG-FLOAT
(VECTOR T) STRING BIT-VECTOR
(VECTOR FIXNUM) (VECTOR SINGLE-FLOAT)
(VECTOR DOUBLE-FLOAT) (ARRAY BASE-CHAR)
(ARRAY BIT) (ARRAY FIXNUM)
(ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT)
(ARRAY T))) ; Beppe
(when (subtypep type v) (return v))))
((and (eq type-name 'SATISFIES) ; Beppe
(symbolp (car type-args))
(sys:get-sysprop (car type-args) 'TYPE-FILTER)))
(t t))))))
(defun valid-type-specifier (type)
(handler-case
(if (subtypep type 'T)
(values t (type-filter type))
(values nil nil))
(error (c) (values nil nil))))
(defun known-type-p (type)
(subtypep type 'T))
(defun-equal-cached type-and (t1 t2)
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
(return-from type-and t1))
(when (eq t1 '*)
(return-from type-and t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*)
(si::*save-types-database* t)
(si::*member-types* si::*member-types*)
(si::*elementary-types* si::*elementary-types*)
(tag1 (si::safe-canonical-type t1))
(tag2 (si::safe-canonical-type t2)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1)
tag2 (si::safe-canonical-type t2))
(cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL
NIL)
((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t1)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t2)
(t
`(AND ,t1 ,t2))))
((eq tag1 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
t2)
((eq tag2 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
t1)
((null tag1)
(setf c::*compiler-break-enable* t)
;(error "foo")
(cmpnote "Unknown type ~S. Assuming it is T." t1)
t2)
(t
(setf c::*compiler-break-enable* t)
;(error "foo")
(cmpnote "Unknown type ~S. Assuming it is T." t2)
t1))))
(defun-equal-cached values-type-primary-type (type)
(when (and (consp type) (eq (first type) 'VALUES))
(let ((subtype (second type)))
(when (or (eq subtype '&optional) (eq subtype '&rest))
(setf type (cddr type))
(when (or (null type)
(eq (setf subtype (first type)) '&optional)
(eq subtype '&rest))
(cmperr "Syntax error in type expression ~S" type))
;; An &optional or &rest output value might be missing
;; If this is the case, the the value will be NIL.
(setf subtype (type-or 'null subtype)))
(setf type subtype)))
type)
(defun-equal-cached values-type-to-n-types (type length)
(if (or (atom type) (not (eql (first type) 'values)))
(list* type (make-list (1- length) :initial-element 'NULL))
(do* ((l (rest type))
(output '())
(n length (1- n)))
((or (null l) (zerop n)) (nreverse output))
(let ((type (pop l)))
(case type
(&optional
(when (null l)
(cmperr "Syntax error in type expression ~S" type))
(setf type (pop l)))
(&rest
(when (null l)
(cmperr "Syntax error in type expression ~S" type))
(return-from values-type-to-n-types
(nreconc output (make-list n :initial-element (first l))))))
(push type output)))))
(defun split-values-type (type)
(if (or (atom type) (not (eq (first type) 'VALUES)))
(values (list type) nil nil)
(let ((rest (member '&rest type))
(opt (member '&optional type)))
(values (ldiff (rest type) (or rest opt))
(ldiff (rest (member '&optional type)) rest)
(rest (member '&rest type))))))
(defun-equal-cached values-type-or (t1 t2)
(when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
(return-from values-type-or t2))
(when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
(return-from values-type-or t1))
(unless t1
(return-from values-type-or t2))
(unless t2
(return-from values-type-or t1))
(multiple-value-bind (req1 opt1 rest1)
(split-values-type t1)
(multiple-value-bind (req2 opt2 rest2)
(split-values-type t2)
(let ((req '())
(opt '())
(rest '()))
(loop for t1 in req1
do (cond (req2
(push (type-or t1 (pop req2)) req))
(opt2
(push (type-or t1 (pop opt2)) opt))
(rest2
(push (type-or t1 (first rest2)) opt))
(t
(push t1 opt))))
(loop for t1 in opt1
do (cond (req2
(push (type-or t1 (pop req2)) opt))
(opt2
(push (type-or t1 (pop opt2)) opt))
(rest2
(push (type-or t1 (first rest2)) opt))
(t
(push t1 opt))))
(let ((t1 (if rest1 (first rest1) t)))
(loop for t2 in req2
do (push (type-or t1 t2) opt))
(loop for t2 in opt2
do (push (type-or t1 t2) opt))
(if rest2
(setf rest (list (type-or t1 (first rest2))))
(setf rest rest1)))
`(VALUES ,@(nreverse req)
,@(and opt (cons '&optional (nreverse opt)))
,@(and rest (cons '&optional rest)))))))
(defun-equal-cached values-type-and (t1 t2)
(when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
(return-from values-type-and t1))
(when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
(return-from values-type-and t2))
(when (or (null t1) (null t2))
(return-from values-type-and nil))
(multiple-value-bind (req1 opt1 rest1)
(split-values-type t1)
(multiple-value-bind (req2 opt2 rest2)
(split-values-type t2)
(let ((req '())
(opt '())
(rest '()))
(loop for t1 in req1
do (cond (req2 (push (type-and t1 (pop req2)) req))
(opt2 (push (type-and t1 (pop opt2)) req))
(rest2 (push (type-and t1 (first rest2)) req))
(t (setf opt1 nil rest1 nil) (return))))
(loop for t1 in opt1
do (cond (req2 (push (type-and t1 (pop req2)) req))
(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)))
(loop for t2 in req2
do (push (type-and t1 t2) req))
(loop for t2 in opt2
do (push (type-and t1 t2) opt))
(when rest2
(setf rest (list (type-and t1 (first rest2)))))))
`(VALUES ,@(nreverse req)
,@(and opt (cons '&optional (nreverse opt)))
,@(and rest (cons '&optional rest)))))))
(defun-equal-cached type-or (t1 t2)
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
(return-from type-or t1))
(when (eq t1 '*)
(return-from type-or t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*)
(si::*save-types-database* t)
(si::*member-types* si::*member-types*)
(si::*elementary-types* si::*elementary-types*)
(tag1 (si::safe-canonical-type t1))
(tag2 (si::safe-canonical-type t2)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1)
tag2 (si::safe-canonical-type t2))
(cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t2)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t1)
(t
`(OR ,t1 ,t2))))
((eq tag1 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
T)
((eq tag2 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
T)
((null tag1)
(cmpnote "Unknown type ~S" t1)
T)
(t
(cmpnote "Unknown type ~S" t2)
T))))
(defun type>= (type1 type2)
(subtypep type2 type1))

80
src/cmp/cmptype-prop.lsp Normal file
View file

@ -0,0 +1,80 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 2009, 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.
;;;;
;;;; CMPTYPE-PROP -- Type propagation basic routines and database
;;;;
(in-package #-new-cmp "COMPILER" #+new-cmp "C-TYPES")
(defun infer-arg-and-return-types (fname forms &optional (env *cmp-env*))
(let ((found (sys:get-sysprop fname 'C1TYPE-PROPAGATOR))
arg-types
(return-type '(VALUES &REST T)))
(cond (found
(multiple-value-setq (arg-types return-type)
(apply found fname (mapcar #'location-primary-type forms))))
((multiple-value-setq (arg-types found)
(get-arg-types fname env))
(setf return-type (or (get-return-type fname) return-type))))
(values arg-types return-type found)))
(defun enforce-types (fname arg-types arguments)
(do* ((types arg-types (rest types))
(args arguments (rest args))
(i 1 (1+ i))
(in-optionals nil))
((endp types)
(when types
(cmpwarn "Too many arguments passed to ~A" fname)))
(let ((expected-type (first types)))
(when (member expected-type '(* &rest &key &allow-other-keys) :test #'eq)
(return))
(when (eq expected-type '&optional)
(when (or in-optionals (null (rest types)))
(cmpwarn "Syntax error in type proclamation for function ~A.~&~A"
fname arg-types))
(setf in-optionals t
types (rest types)
expected-type (first types)))
(when (endp args)
(unless in-optionals
(cmpwarn "Too few arguments for proclaimed function ~A" fname))
(return))
(let* ((value (first args))
(actual-type (location-primary-type value))
(intersection (type-and actual-type expected-type)))
(unless intersection
(cmperr "The argument ~d of function ~a has type~&~4T~A~&instead of expected~&~4T~A"
i fname actual-type expected-type))
#-new-cmp
(when (zerop (cmp-env-optimization 'safety))
(setf (c1form-type value) intersection))))))
(defun propagate-types (fname forms)
(multiple-value-bind (arg-types return-type found)
(infer-arg-and-return-types fname forms)
(when found
(enforce-types fname arg-types forms))
return-type))
(defmacro def-type-propagator (fname lambda-list &body body)
(unless (member '&rest lambda-list)
(let ((var (gensym)))
(setf lambda-list (append lambda-list (list '&rest var))
body (list* `(declare (ignorable ,var)) body)))
`(sys:put-sysprop ',fname 'C1TYPE-PROPAGATOR
#'(ext:lambda-block ,fname ,lambda-list ,@body))))
(defun copy-type-propagator (orig dest-list)
(loop with function = (sys:get-sysprop orig 'C1TYPE-PROPAGATOR)
for name in dest-list
do (sys:put-sysprop name 'C1TYPE-PROPAGATOR function)))

536
src/cmp/cmptype.lsp
View file

@ -14,316 +14,6 @@
(in-package "COMPILER")
;;; CL-TYPE is any valid type specification of Common Lisp.
;;;
;;; TYPE is a representation type used by ECL. TYPE is one of:
;;;
;;; T(BOOLEAN)
;;;
;;; FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT
;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM)
;;; (VECTOR SINGLE-FLOAT) (VECTOR DOUBLE-FLOAT)
;;; (ARRAY T) (ARRAY BASE-CHAR) (ARRAY BIT)
;;; (ARRAY FIXNUM)
;;; (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT)
;;; STANDARD-OBJECT STRUCTURE-OBJECT
;;; SYMBOL
;;; UNKNOWN
;;;
;;; NIL
;;;
;;;
;;; immediate-type:
;;; FIXNUM int
;;; CHARACTER char
;;; SINGLE-FLOAT float
;;; DOUBLE-FLOAT double
(defun member-type (type disjoint-supertypes)
(member type disjoint-supertypes :test #'subtypep))
;;; Check if THING is an object of the type TYPE.
;;; Depends on the implementation of TYPE-OF.
;;; (only used for saving constants?)
(defun object-type (thing)
(let ((type (if thing (type-of thing) 'SYMBOL)))
(case type
((FIXNUM SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SYMBOL NULL) type)
((BASE-CHAR STANDARD-CHAR CHARACTER EXTENDED-CHAR) 'CHARACTER)
((STRING BASE-STRING BIT-VECTOR) type)
(VECTOR (list 'VECTOR (array-element-type thing)))
(ARRAY (list 'ARRAY (array-element-type thing)))
#+clos
(STANDARD-OBJECT 'STANDARD-OBJECT)
#+clos
(STRUCTURE-OBJECT 'STRUCTURE-OBJECT)
(t t))))
(defun type-filter (type &optional values-allowed)
(multiple-value-bind (type-name type-args) (sys::normalize-type type)
(case type-name
((FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT SYMBOL) type-name)
(SHORT-FLOAT #-short-float 'SINGLE-FLOAT #+short-float 'SHORT-FLOAT)
(LONG-FLOAT #-long-float 'DOUBLE-FLOAT #+long-float 'LONG-FLOAT)
((SIMPLE-STRING STRING) 'STRING)
((SIMPLE-BIT-VECTOR BIT-VECTOR) 'BIT-VECTOR)
((NIL T) t)
((SIMPLE-ARRAY ARRAY)
(cond ((endp type-args) '(ARRAY *)) ; Beppe
((eq '* (car type-args)) t)
(t (let ((element-type (upgraded-array-element-type (car type-args)))
(dimensions (if (cdr type-args) (second type-args) '*)))
(if (and (not (eq dimensions '*))
(or (numberp dimensions)
(= (length dimensions) 1)))
(case element-type
(BASE-CHAR 'STRING)
(BIT 'BIT-VECTOR)
(t (list 'VECTOR element-type)))
(list 'ARRAY element-type))))))
(INTEGER (if (subtypep type 'FIXNUM) 'FIXNUM t))
((STREAM CONS) type-name) ; Juanjo
(FUNCTION type-name)
(t (cond ((eq type-name 'VALUES)
(unless values-allowed
(error "VALUES type found in a place where it is not allowed."))
`(VALUES ,@(mapcar #'(lambda (x)
(if (or (eq x '&optional)
(eq x '&rest))
x
(type-filter x)))
type-args)))
#+clos
((subtypep type 'STANDARD-OBJECT) type)
#+clos
((subtypep type 'STRUCTURE-OBJECT) type)
((dolist (v '(FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT
#+short-float SHORT-FLOAT #+long-float LONG-FLOAT
(VECTOR T) STRING BIT-VECTOR
(VECTOR FIXNUM) (VECTOR SINGLE-FLOAT)
(VECTOR DOUBLE-FLOAT) (ARRAY BASE-CHAR)
(ARRAY BIT) (ARRAY FIXNUM)
(ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT)
(ARRAY T))) ; Beppe
(when (subtypep type v) (return v))))
((and (eq type-name 'SATISFIES) ; Beppe
(symbolp (car type-args))
(get-sysprop (car type-args) 'TYPE-FILTER)))
(t t))))))
(defun valid-type-specifier (type)
(handler-case
(if (subtypep type 'T)
(values t (type-filter type))
(values nil nil))
(error (c) (values nil nil))))
(defun known-type-p (type)
(subtypep type 'T))
(defun type-and (t1 t2)
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
(return-from type-and t1))
(when (eq t1 '*)
(return-from type-and t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*)
(si::*save-types-database* t)
(si::*member-types* si::*member-types*)
(si::*elementary-types* si::*elementary-types*)
(tag1 (si::safe-canonical-type t1))
(tag2 (si::safe-canonical-type t2)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1)
tag2 (si::safe-canonical-type t2))
(cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL
NIL)
((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t1)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t2)
(t
`(AND ,t1 ,t2))))
((eq tag1 'CONS)
(cmpnote "Unsupported CONS type ~S. Replacing it with T." t1)
t2)
((eq tag2 'CONS)
(cmpnote "Unsupported CONS type ~S. Replacing it with T." t2)
t1)
((null tag1)
(setf c::*compiler-break-enable* t)
;(error "foo")
(cmpnote "Unknown type ~S. Assuming it is T." t1)
t2)
(t
(setf c::*compiler-break-enable* t)
;(error "foo")
(cmpnote "Unknown type ~S. Assuming it is T." t2)
t1))))
(defun values-type-primary-type (type)
(when (and (consp type) (eq (first type) 'VALUES))
(let ((subtype (second type)))
(when (or (eq subtype '&optional) (eq subtype '&rest))
(setf type (cddr type))
(when (or (null type)
(eq (setf subtype (first type)) '&optional)
(eq subtype '&rest))
(cmperr "Syntax error in type expression ~S" type))
;; An &optional or &rest output value might be missing
;; If this is the case, the the value will be NIL.
(setf subtype (type-or 'null subtype)))
(setf type subtype)))
type)
(defun values-type-to-n-types (type length)
(if (or (atom type) (not (eql (first type) 'values)))
(list* type (make-list (1- length) :initial-element 'NULL))
(do* ((l (rest type))
(output '())
(n length (1- n)))
((or (null l) (zerop n)) (nreverse output))
(let ((type (pop l)))
(case type
(&optional
(when (null l)
(cmperr "Syntax error in type expression ~S" type))
(setf type (pop l)))
(&rest
(when (null l)
(cmperr "Syntax error in type expression ~S" type))
(setf type (pop l))
(return-from values-type-to-n-types
(nreconc output (make-list n :initial-element l)))))
(push type output)))))
(defun values-type-and (t1 t2)
(labels ((values-type-p (type)
(and (consp type) (eq (first type) 'VALUES)))
(values-and-ordinary (v type)
(let* ((v (rest v))
(first-type (first v)))
(cond ((or (eq first-type '&optional) (eq first-type '&rest))
(type-and (second v) type))
((null (rest v))
(type-and first-type type))
(t
(return-from values-type-and nil)))))
(type-error (type)
(error "Invalid type ~A" type))
(do-values-type-and (t1-orig t2-orig)
(do* ((t1 (rest t1-orig))
(t2 (rest t2-orig))
(i1 (first t1))
(i2 (first t2))
(phase1 nil)
(phase2 nil)
(phase3 nil)
(output (list 'VALUES)))
((or (null t1) (null t2))
(if (or (eq t1 t2)
(eq i1 '&rest) (eq i1 '&optional)
(eq i2 '&rest) (eq i2 '&optional))
(nreverse output)
nil))
(cond ((eq i1 '&optional)
(when phase1 (type-error t1-orig))
(setf phase1 '&optional)
(setf t1 (rest t1) i1 (first t1))
(unless t1 (type-error t1-orig)))
((eq i1 '&rest)
(when (eq phase1 '&rest) (type-error t1-orig))
(setf phase1 '&rest)
(setf t1 (rest t1) i1 (first t1))
(when (or (null t1) (rest t1)) (type-error t1-orig))))
(cond ((eq i2 '&optional)
(when phase2 (type-error t2-orig))
(setf phase2' &optional)
(setf t2 (rest t2) i2 (first t2))
(unless t2 (type-error t2-orig)))
((eq i2 '&rest)
(when (eq phase2 '&rest) (type-error t2-orig))
(setf phase2 '&rest)
(setf t2 (rest t2) i2 (first t2))
(when (or (null t2) (rest t2)) (type-error t2-orig))))
(cond ((and (null phase1) (null phase2))
(push (type-and i1 i2) output)
(setf t1 (rest t1) i1 (first t1)
t2 (rest t2) i2 (first t2)))
((null phase2)
(push (type-and i1 i2) output)
(unless (eq phase1 '&rest)
(setf t1 (rest t1) i1 (first t1)))
(setf t2 (rest t2) i2 (first t2)))
((null phase1)
(push (type-and i1 i2) output)
(unless (eq phase2 '&rest)
(setf t2 (rest t2) i2 (first t2)))
(setf t1 (rest t1) i1 (first t1)))
((eq phase1 phase2)
(unless (eq phase3 phase2)
(push (setf phase3 phase2) output))
(push (type-and i1 i2) output)
(cond ((eq phase1 '&rest) (setf t1 nil t2 nil))
(t (setf t1 (rest t1) i1 (first t1)
t2 (rest t2) i2 (first t2)))))
((eq phase1 '&optional)
(unless (eq phase3 phase1)
(push (setf phase3 phase1) output))
(push (type-and i1 i2) output)
(setf t1 (rest t1) i1 (first t1)))
((eq phase2 '&optional)
(unless (eq phase3 phase2)
(push (setf phase3 phase2) output))
(push (type-and i1 i2) output)
(setf t2 (rest t2) i2 (first t2)))))))
(if (equal t1 t2)
t1
(if (values-type-p t1)
(if (values-type-p t2)
(do-values-type-and t1 t2)
(values-and-ordinary t1 t2))
(if (values-type-p t2)
(values-and-ordinary t2 t1)
(type-and t1 t2))))))
(defun type-or (t1 t2)
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
(return-from type-or t1))
(when (eq t1 '*)
(return-from type-or t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*)
(si::*save-types-database* t)
(si::*member-types* si::*member-types*)
(si::*elementary-types* si::*elementary-types*)
(tag1 (si::safe-canonical-type t1))
(tag2 (si::safe-canonical-type t2)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1)
tag2 (si::safe-canonical-type t2))
(cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t2)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t1)
(t
`(OR ,t1 ,t2))))
((eq tag1 'CONS)
(cmpnote "Unsupported CONS type ~S. Replacing it with T." t1)
T)
((eq tag2 'CONS)
(cmpnote "Unsupported CONS type ~S. Replacing it with T." t2)
T)
((null tag1)
(cmpnote "Unknown type ~S" t1)
T)
(t
(cmpnote "Unknown type ~S" t2)
T))))
(defun type>= (type1 type2)
(subtypep type2 type1))
;;;
;;; and-form-type
;;; returns a copy of form whose type is the type-and of type and the form's
@ -351,232 +41,6 @@
(c1constant-value new-value :only-small-values t)
(c1nil))))
;;----------------------------------------------------------------------
;; (FUNCTION ...) types. This code is a continuation of predlib.lsp.
;; It implements function types and a SUBTYPEP relationship between them.
;;
(in-package "SI")
(defstruct function-type
required
optional
rest
key-p
keywords
keyword-types
allow-other-keys-p
output)
(defun canonical-function-type (ftype)
(when (function-type-p ftype)
(return-from canonical-function-type ftype))
(flet ((ftype-error ()
(error "Syntax error in FUNCTION type definition ~S" ftype)))
(let (o k k-t values)
(unless (and (= (length ftype) 3) (eql (first ftype) 'FUNCTION))
(ftype-error))
(multiple-value-bind (requireds optionals rest key-flag keywords
allow-other-keys-p auxs)
(si::process-lambda-list (second ftype) 'FTYPE)
(dotimes (i (pop optionals))
(let ((type (first optionals))
(init (second optionals))
(flag (third optionals)))
(setq optionals (cdddr optionals))
(when (or init flag) (ftype-error))
(push type o)))
(dotimes (i (pop keywords))
(let ((keyword (first keywords))
(var (second keywords))
(type (third keywords))
(flag (fourth keywords)))
(setq keywords (cddddr keywords))
(when (or var flag) (ftype-error))
(push keyword k)
(push type k-t)))
(setf values (third ftype))
(cond ((atom values) (setf values (list 'VALUES values)))
((and (listp values) (eql (first values) 'VALUES)))
(t (ftype-error)))
(when (and rest key-flag
(not (subtypep 'keyword rest)))
(ftype-error))
(make-function-type :required (rest requireds)
:optional o
:rest rest
:key-p key-flag
:keywords k
:keyword-types k-t
:allow-other-keys-p allow-other-keys-p
:output (canonical-values-type values))))))
(defconstant +function-type-tag+ (cdr (assoc 'FUNCTION *elementary-types*)))
(defun register-function-type (type)
(or (find-registered-tag type)
(find-registered-tag (setq ftype (canonical-function-type type)))
(let ((tag (register-type ftype #'function-type-p #'function-type-<=)))
(update-types +function-type-tag+ tag)
tag)))
(defun function-type-<= (f1 f2)
(unless (and (every* #'subtypep
(function-type-required f2)
(function-type-required f1))
(do* ((o1 (function-type-optional f1) (cdr o1))
(o2 (function-type-optional f2) (cdr o2))
(r1 (function-type-rest f1))
(r2 (function-type-rest f2))
t1 t2)
((and (endp o1) (endp o2)) t)
(setf t1 (cond ((consp o1) (first o1))
(r1 r1)
(t (return nil)))
t2 (cond ((consp o2) (first o2))
(r2 r2)
(t (return nil))))
(unless (subtypep t1 t2)
(return nil)))
(subtypep (function-type-output f1)
(function-type-output f2))
(eql (function-type-key-p f1) (function-type-key-p f2))
(or (function-type-allow-other-keys-p f2)
(not (function-type-allow-other-keys-p f1))))
(return-from function-type-<= nil))
(do* ((k2 (function-type-keywords f2))
(k-t2 (function-type-keyword-types f2))
(k1 (function-type-keywords f1) (cdr k1))
(k-t1 (function-type-keyword-types f1) (cdr k1)))
((endp k1)
t)
(unless
(let* ((n (position (first k1) k2)))
(when n
(let ((t2 (nth n k-t2)))
(subtypep (first k-t1) t2))))
(return-from function-type-<= nil))))
;;----------------------------------------------------------------------
;; (VALUES ...) type
(defstruct values-type
min-values
max-values
required
optional
rest)
(defun register-values-type (vtype)
(or (find-registered-tag vtype)
(find-registered-tag (setf vtype (canonical-values-type vtype)))
(register-type vtype #'values-type-p #'values-type-<=)))
(defun canonical-values-type (vtype)
(when (values-type-p vtype)
(return-from canonical-values-type vtype))
(flet ((vtype-error ()
(error "Syntax error in VALUES type definition ~S" vtype)))
(unless (and (listp vtype) (eql (pop vtype) 'VALUES))
(vtype-error))
(let ((required '())
(optional '())
(rest nil))
(do ()
((endp vtype)
(make-values-type :min-values (length required)
:max-values (if rest multiple-values-limit
(+ (length required)
(length optional)))
:required (nreverse required)
:optional (nreverse optional)
:rest rest))
(let ((type (pop vtype)))
(if (eql type '&optional)
(do ()
((endp vtype))
(let ((type (pop vtype)))
(if (eql type '&rest)
(if (endp vtype)
(ftype-error)
(setf rest (first vtype)))
(push type optional))))
(push type required)))))))
(defun values-type-<= (v1 v2)
(and (= (values-type-min-values v1) (values-type-min-values v2))
(= (values-type-max-values v1) (values-type-max-values v2))
(every* #'subtypep (values-type-required v1) (values-type-required v2))
(every* #'subtypep (values-type-optional v1) (values-type-optional v2))
(subtypep (values-type-rest v1) (values-type-rest v2))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; TYPE PROPAGATORS
;;;
(in-package "COMPILER")
(defun simple-type-propagator (fname)
(let ((arg-types (get-arg-types fname))
(return-type (or (get-return-type fname) '(VALUES &REST T))))
(values arg-types return-type)))
(defun propagate-types (fname forms lisp-forms)
(multiple-value-bind (arg-types return-type)
(let ((propagator (get-sysprop fname 'C1TYPE-PROPAGATOR)))
(if propagator
(apply propagator fname (mapcar #'c1form-primary-type forms))
(simple-type-propagator fname)))
(when arg-types
(do* ((types arg-types (rest types))
(fl forms (rest fl))
(al lisp-forms (rest al))
(i 1 (1+ i))
(in-optionals nil))
((endp types)
(when types
(cmpwarn "Too many arguments passed to ~A" fname)))
(let ((expected-type (first types)))
(when (member expected-type '(* &rest &key &allow-other-keys) :test #'eq)
(return))
(when (eq expected-type '&optional)
(when in-optionals
(cmpwarn "Syntax error in type proclamation for function ~A.~&~A"
fname arg-types))
(setf in-optionals t
types (rest types)
expected-type (first types)))
(when (endp fl)
(unless in-optionals
(cmpwarn "Too few arguments for proclaimed function ~A" fname))
(return))
(when lisp-forms
(let* ((form (first fl))
(lisp-form (first al))
(old-type (c1form-type form)))
(and-form-type expected-type form lisp-form
:safe "In the argument ~d of a call to ~a" i fname)
;; In safe mode, we cannot assume that the type of the
;; argument is going to be the right one.
(unless (zerop (cmp-env-optimization 'safety))
(setf (c1form-type form) old-type)))))))
return-type))
(defmacro def-type-propagator (fname lambda-list &body body)
(unless (member '&rest lambda-list)
(let ((var (gensym)))
(setf lambda-list (append lambda-list (list '&rest var))
body (list* `(declare (ignorable ,var)) body)))
`(put-sysprop ',fname 'C1TYPE-PROPAGATOR
#'(ext:lambda-block ,fname ,lambda-list ,@body))))
(defun copy-type-propagator (orig dest-list)
(loop with function = (get-sysprop orig 'C1TYPE-PROPAGATOR)
for name in dest-list
do (put-sysprop name 'C1TYPE-PROPAGATOR function)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; TYPE CHECKING

62
src/new-cmp/cmptypes.lsp → src/cmp/cmptypes.lsp
View file

@ -1,7 +1,6 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; 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
@ -13,7 +12,7 @@
;;;; CMPTYPES -- Data types for the Lisp core structures
;;;;
(in-package "C-DATA")
(in-package #-new-cmp "COMPILER" #+new-cmp "C-DATA")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@ -53,7 +52,8 @@
; 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, :FIXNUM,
;;; :CHAR, :DOUBLE, :FLOAT, REPLACED or DISCARDED
;;; :CHAR, :DOUBLE, :FLOAT, or REPLACED (used for
;;; LET variables).
(function *current-function*)
;;; For local variables, in which function it was created.
;;; For global variables, it doesn't have a meaning.
@ -78,6 +78,11 @@
;;; 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.
#-new-cmp
(index -1) ;;; position in *vars*. Used by similar.
#-new-cmp
(ignorable nil) ;;; Whether there was an IGNORABLE/IGNORE declaration
#+new-cmp
read-only-p ;;; T for variables that are assigned only once.
)
@ -126,7 +131,9 @@
; ref-clb ;;; Unused.
; read-nodes ;;; Nodes (c1forms) in which the reference occurs
cfun ;;; The cfun for the function.
#+new-cmp
(last-lcl 0) ;;; Number of local variables (just to bookkeep names)
#+new-cmp
(last-label 0) ;;; Number of generated labels (same as last-lcl)
(level 0) ;;; Level of lexical nesting for a function.
(env 0) ;;; Size of env of closure.
@ -140,12 +147,14 @@
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.
#+new-cmp
lambda-list ;;; List of (requireds optionals rest-var keywords-p
;;; keywords allow-other-keys-p)
lambda ;;; Lambda c1-form for this function.
(minarg 0) ;;; Min. number arguments that the function receives.
(maxarg call-arguments-limit)
;;; Max. number arguments that the function receives.
lambda ;;; Lambda c1-form for this function.
#+new-cmp
doc ;;; Documentation
(parent *current-function*)
;;; Parent function, NIL if global.
@ -154,13 +163,17 @@
(referred-funs nil) ;;; List of external functions called in this one.
;;; We only register direct calls, not calls via object.
(child-funs nil) ;;; List of local functions defined here.
#+new-cmp
(debug 0) ;;; Debug quality
(file *compile-file-truename*)
(file (car ext:*source-location*))
;;; Source file or NIL
(file-position *compile-file-position*)
(file-position (or (cdr ext:*source-location*) *compile-file-position*))
;;; Top-level form number in source file
#+new-cmp
(toplevel-form *current-toplevel-form*)
#+new-cmp
code-gen-props ;;; Extra properties for code generation
(cmp-env (cmp-env-copy)) ;;; Environment
)
(defstruct (blk (:include ref))
@ -178,7 +191,10 @@
exit ;;; Where to return. A label.
destination ;;; Where the value of the block to go.
var ;;; Variable containing the block ID.
env ;;; Block environment
#-new-cmp
(type 'NIL) ;;; Estimated type.
#+new-cmp
env ;;; Block environment.
)
(defstruct (tag (:include ref))
@ -193,10 +209,17 @@
unwind-exit ;;; Where to unwind-no-exit.
var ;;; Variable containing frame ID.
index ;;; An integer denoting the label.
env ;;; Tag environment
#+new-cmp
env ;;; Tag environment.
)
(defstruct (info)
(local-vars nil) ;;; List of var-objects created directly in the form.
#-new-cmp
(type t) ;;; Type of the form.
(sp-change nil) ;;; Whether execution of the form may change
;;; the value of a special variable.
(volatile nil) ;;; whether there is a possible setjmp. Beppe
)
(defstruct (inline-info)
@ -214,15 +237,14 @@
(defstruct (c1form (:include info)
(:print-object print-c1form)
(:constructor do-make-c1form))
(name nil) ;; See cmptables.lsp for all valid form names
(args '()) ;; Arguments
(env (c-env:cmp-env-copy)) ;; Environment in which this form was compiled
(local-vars nil) ;; List of var-objects created directly in the form.
(sp-change nil) ;; Whether execution of the form may change
;; the value of a special variable.
(volatile nil) ;; whether there is a possible setjmp. Beppe
(form nil) ;; Origin of this form
(toplevel-form) ;; ... including toplevel form in which it appears
(file nil) ;; ... and source file and position
(name nil)
(parent nil)
#+new-cmp
(env (c-env:cmp-env-copy)) ;; Environment in which this form was compiled
#-new-cmp
(env (cmp-env-copy)) ;; Environment in which this form was compiled
(args '())
(form nil)
(toplevel-form nil)
(file nil)
(file-position 0))

6
src/cmp/cmputil.lsp
View file

@ -347,9 +347,3 @@
(<= #.(char-code #\0) cc #.(char-code #\9)))
c #\_)))
(string-downcase (prin1-to-string obj)))))
#-new-cmp
(defun proper-list-p (x &optional test)
(and (listp x)
(handler-case (list-length x) (type-error (c) nil))
(or (null test) (every test x))))

102
src/cmp/cmpwt.lsp
View file

@ -14,110 +14,16 @@
(in-package "COMPILER")
(defvar *wt-string-size* 0)
;;; ======================================================================
;;;
;;; DATA FILES
;;;
;;; Each lisp compiled file consists on code and a data section. Whenever an
;;; #'in-package toplevel form is found, a read-time evaluated expression is
;;; inserted in the data section which changes the current package for the
;;; rest of it. This way it is possible to save some space by writing the
;;; symbol's package only when it does not belong to the current package.
(defun wt-label (label)
(when (cdr label) (wt-nl1 "L" (car label) ":;")))
(defun wt-filtered-comment (text stream single-line)
(declare (string text))
(if single-line
(progn
(fresh-line stream)
(princ "/* " stream))
(format stream "~50T/* "))
(let* ((l (1- (length text))))
(declare (fixnum l))
(dotimes (n l)
(let ((c (schar text n)))
(princ c stream)
(when (and (char= c #\*) (char= (schar text (1+ n)) #\/))
(princ #\\ stream))))
(princ (schar text l) stream))
(format stream "~70T*/")
)
(defun do-wt-comment (message-or-format args single-line-p)
(unless (and (symbolp message-or-format) (not (symbol-package message-or-format)))
(wt-filtered-comment (if (stringp message-or-format)
(if args
(apply #'format nil message-or-format args)
message-or-format)
(princ-to-string message-or-format))
*compiler-output1*
single-line-p)))
(defun wt-comment (message &rest extra)
(do-wt-comment message extra nil))
(defun wt-comment-nl (message &rest extra)
(do-wt-comment message extra t))
(defun wt1 (form)
(typecase form
((or STRING INTEGER CHARACTER)
(princ form *compiler-output1*))
((or DOUBLE-FLOAT SINGLE-FLOAT)
(format *compiler-output1* "~10,,,,,,'eG" form))
(LONG-FLOAT
(format *compiler-output1* "~,,,,,,'eEl" form))
(VAR (wt-var form))
(t (wt-loc form)))
nil)
(defun wt-h1 (form)
(if (consp form)
(let ((fun (get-sysprop (car form) 'wt-loc)))
(if fun
(let ((*compiler-output1* *compiler-output2*))
(apply fun (cdr form)))
(cmperr "The location ~s is undefined." form)))
(princ form *compiler-output2*))
nil)
;;; This routine converts lisp data into C-strings. We have to take
;;; care of escaping special characteres with backslashes. We also have
;;; to split long lines using the fact that multiple strings are joined
;;; together by the compiler.
;;;
(defun wt-filtered-data (string stream &optional one-liner)
(let ((N (length string))
(wt-data-column 80))
(incf *wt-string-size* (1+ N)) ; 1+ accounts for a blank space
(format stream (if one-liner "\"" "~%\""))
(dotimes (i N)
(decf wt-data-column)
(when (< wt-data-column 0)
(format stream "\"~% \"")
(setq wt-data-column 79))
(let ((x (aref string i)))
(cond
((or (< (char-code x) 32)
(> (char-code x) 127))
(case x
; We avoid a trailing backslash+newline because some preprocessors
; remove them.
(#\Newline (princ "\\n" stream))
(#\Tab (princ "\\t" stream))
(t (format stream "\\~3,'0o" (char-code x)))))
((char= x #\\)
(princ "\\\\" stream))
((char= x #\")
(princ "\\\"" stream))
(t (princ x stream)))))
(princ (if one-liner "\"" " \"") stream)
string))
;;; ======================================================================
;;;
;;; DATA FILES
;;;
(defun data-permanent-storage-size ()
(length *permanent-objects*))

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

@ -1,16 +1,28 @@
;;; @configure_input@
(defconstant +cmp-module-files+
'("build:cmp;cmpdefs.lsp"
'("src:cmp;cmppackage.lsp"
"src:cmp;cmptypes.lsp"
"src:cmp;cmpglobals.lsp"
"build:cmp;cmpdefs.lsp"
"src:cmp;cmpmac.lsp"
"src:cmp;cmpform.lsp"
"src:cmp;cmpc-wt.lsp"
"src:cmp;cmpinline.lsp"
"src:cmp;cmputil.lsp"
"src:cmp;cmptype-arith.lsp"
"src:cmp;cmptype-prop.lsp"
"src:cmp;cmptype.lsp"
"src:cmp;cmpbind.lsp"
"src:cmp;cmpblock.lsp"
"src:cmp;cmpcall.lsp"
"src:cmp;cmpcatch.lsp"
"src:cmp;cmpenv.lsp"
"src:cmp;cmpenv-api.lsp"
"src:cmp;cmpenv-fun.lsp"
"src:cmp;cmpenv-declare.lsp"
"src:cmp;cmpenv-proclaim.lsp"
"src:cmp;cmpenv-declaim.lsp"
"src:cmp;cmppolicy.lsp"
"src:cmp;cmpeval.lsp"
"src:cmp;cmpexit.lsp"
"src:cmp;cmpflet.lsp"

29
src/cmp/proclamations.lsp
View file

@ -42,15 +42,12 @@
(in-package "C")
(defun proclaim-function (name arg-types return-type &rest properties)
(defun parse-function-proclamation
(name arg-types return-type &rest properties)
(when (sys:get-sysprop name 'proclaimed-arg-types)
(warn "Duplicate proclamation for ~A" name))
(when (eq arg-types '())
(setf arg-types '(&optional)))
(unless (or (equal arg-types '(*)))
(sys:put-sysprop name 'proclaimed-arg-types arg-types))
(when (and return-type (not (eq 'T return-type)))
(sys:put-sysprop name 'proclaimed-return-type return-type))
(#-new-cmp proclaim-function #+new-cmp c-env::proclaim-function
name (list arg-types return-type))
(loop for p in properties
do (case p
(:no-sp-change
@ -61,8 +58,8 @@
((:no-side-effects :reader)
(sys:put-sysprop name 'no-side-effects t))
(otherwise
(error "Unknown property ~S in function proclamation ~S"
p form)))))
(error "Unknown property ~S in function proclamation for ~S"
p name)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; AUXILIARY TYPES
@ -351,12 +348,12 @@
(proclamation si:*make-special (symbol) symbol)
(proclamation si:*make-constant (symbol t) symbol)
(proclamation si:put-f (list t t) list)
(proclamation si:rem-f (list t) boolean)
(proclamation si:rem-f (list t) (values list boolean))
(proclamation si:set-symbol-plist (symbol list) list)
(proclamation si:putprop (symbol t t) t)
(proclamation si:put-sysprop (t t t) t)
(proclamation si:get-sysprop (t t t) t)
(proclamation si:rem-sysprop (t t) gen-bool)
(proclamation si:get-sysprop (t t) (values t boolean))
(proclamation si:rem-sysprop (t t) boolean)
(proclamation si:put-properties (symbol &rest t) symbol :no-sp-change)
@ -526,7 +523,7 @@
;; (proclamation arithmetic-error-operation (condition) t)
;; ECL extensions
(proclamation si:bit-array-op (t t t t) t)
(proclamation si:bit-array-op (t t t t) (array bit))
(proclamation si:fixnump (t) gen-book :pure)
;; Virtual functions added by the compiler
@ -699,8 +696,8 @@
(proclamation nunion (proper-list proper-list &key) proper-list)
;; ECL extensions
(proclamation member1 (t proper-list t t t) t)
(proclamation si:memq (t proper-list) t)
(proclamation si:member1 (t proper-list t t t) list)
(proclamation si:memq (t proper-list) list)
;;;
;;; 15. ARRAYS
@ -1314,5 +1311,5 @@
))) ; eval-when
(loop for i in '#.(mapcar #'rest +proclamations+)
do (apply #'proclaim-function i))
do (apply #'parse-function-proclamation i))

6
src/compile.lsp.in
View file

@ -71,7 +71,7 @@
;;; * Compile and link Common-Lisp base library
;;;
(setq si::*keep-documentation* nil)
(proclaim '(optimize (safety 2) (space 3)))
(proclaim '(optimize (safety 2) (space 3) (debug 1)))
(let* ((c::*cc-flags* (concatenate 'string "-DECL_API -I\"@true_builddir@/c\" " c::*cc-flags*))
(lsp-objects (compile-if-old "build:lsp;" +lisp-module-files+
:system-p t :c-file t :data-file t :h-file t
@ -79,7 +79,7 @@
)))
#+CLOS
(let* ((c::*compile-to-linking-call* nil))
(proclaim '(optimize (safety 2) (space 3)))
(proclaim '(optimize (safety 2) (space 3) (debug 1)))
(setq lsp-objects (append lsp-objects
(compile-if-old "build:clos;" +clos-module-files+
:system-p t :c-file t :data-file t :h-file t
@ -128,7 +128,7 @@
;;;
;;; * Compile and link Common-Lisp to C compiler
;;;
(proclaim '(optimize (safety 2) (space 3)))
(proclaim '(optimize (safety 2) (space 3) (debug 1)))
(si::pathname-translations "SYS" '(("**;*.*.*" "@ecldir\@/**/*.*")))

3
src/configure vendored
View file

@ -14255,7 +14255,7 @@ $as_echo "$as_me: error: Not a valid argument for --enable-boehm $enable_boehm"
{ (exit 1); exit 1; }; };;
esac
ac_config_files="$ac_config_files bare.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp new-cmp/load.lsp ../Makefile Makefile c/Makefile doc/Makefile doc/ecl.man doc/ecl-config.man ecl/configpre.h:h/config.h.in bin/ecl-config.pre:util/ecl-config lsp/config.pre:lsp/config.lsp.in compile.pre:compile.lsp.in cmp/cmpdefs.pre:cmp/cmpdefs.lsp new-cmp/cmpdefs.pre:new-cmp/cmpdefs.lsp"
ac_config_files="$ac_config_files bare.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp new-cmp/load.lsp ../Makefile Makefile c/Makefile doc/Makefile doc/ecl.man doc/ecl-config.man ecl/configpre.h:h/config.h.in bin/ecl-config.pre:util/ecl-config lsp/config.pre:lsp/config.lsp.in compile.pre:compile.lsp.in cmp/cmpdefs.pre:cmp/cmpdefs.lsp"
ac_config_headers="$ac_config_headers ecl/config.h:ecl/configpre.h"
# FIXME
@ -14870,7 +14870,6 @@ do
"lsp/config.pre") CONFIG_FILES="$CONFIG_FILES lsp/config.pre:lsp/config.lsp.in" ;;
"compile.pre") CONFIG_FILES="$CONFIG_FILES compile.pre:compile.lsp.in" ;;
"cmp/cmpdefs.pre") CONFIG_FILES="$CONFIG_FILES cmp/cmpdefs.pre:cmp/cmpdefs.lsp" ;;
"new-cmp/cmpdefs.pre") CONFIG_FILES="$CONFIG_FILES new-cmp/cmpdefs.pre:new-cmp/cmpdefs.lsp" ;;
"ecl/config.h") CONFIG_HEADERS="$CONFIG_HEADERS ecl/config.h:ecl/configpre.h" ;;
*) { { $as_echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5

1
src/configure.in
View file

@ -891,7 +891,6 @@ AC_CONFIG_FILES([
ecl/configpre.h:h/config.h.in bin/ecl-config.pre:util/ecl-config
lsp/config.pre:lsp/config.lsp.in compile.pre:compile.lsp.in
cmp/cmpdefs.pre:cmp/cmpdefs.lsp
new-cmp/cmpdefs.pre:new-cmp/cmpdefs.lsp
])
AC_CONFIG_HEADERS([ecl/config.h:ecl/configpre.h]) # FIXME
AC_OUTPUT

4
src/new-cmp/cmpc-inline.lsp
View file

@ -65,10 +65,6 @@
(defun get-inline-info (fname types return-type return-rep-type)
(declare (si::c-local))
(let ((output nil))
(dolist (x *inline-functions*)
(when (eq (car x) fname)
(let ((other (inline-type-matches (cdr x) types return-type)))
(setf output (choose-inline-info output other return-type return-rep-type)))))
(unless (safe-compile)
(dolist (x (sys:get-sysprop fname ':INLINE-UNSAFE))
(let ((other (inline-type-matches x types return-type)))

69
src/new-cmp/cmpdefs.lsp
View file

@ -1,69 +0,0 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 2009, 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.
;;;;
;;;; CMPDEFS -- Definitions created at compile / configuration time
(in-package "C")
;;; This is copied into each .h file generated, EXCEPT for system-p calls.
;;; The constant string *include-string* is the content of file "ecl.h".
;;; Here we use just a placeholder: it will be replaced with sed.
(defvar *cmpinclude* "<ecl/ecl-cmp.h>")
;;;
;;; Compiler program and flags.
;;;
(defvar *cc* "@ECL_CC@"
"This variable controls how the C compiler is invoked by ECL.
The default value is \"cc -I. -I/usr/local/include/\".
The second -I option names the directory where the file ECL.h has been installed.
One can set the variable appropriately adding for instance flags which the
C compiler may need to exploit special hardware features (e.g. a floating point
coprocessor).")
(defvar *ld* "@ECL_CC@"
"This variable controls the linker which is used by ECL.")
(defvar *cc-flags* "@CPPFLAGS@ @CFLAGS@ @ECL_CFLAGS@")
(defvar *cc-optimize* #-msvc "-O"
#+msvc "@CFLAGS_OPTIMIZE@")
(defvar *ld-format* #-msvc "~A -o ~S -L~S ~{~S ~} ~@?"
#+msvc "~A -Fe~S~* ~{~S ~} ~@?")
(defvar *cc-format* #-msvc "~A ~A ~:[~*~;~A~] \"-I~A\" -w -c \"~A\" -o \"~A\""
#+msvc "~A ~A ~:[~*~;~A~] -I\"~A\" -w -c \"~A\" -Fo\"~A\"")
#-dlopen
(defvar *ld-flags* "@LDFLAGS@ -lecl @CORE_LIBS@ @FASL_LIBS@ @LIBS@")
#+dlopen
(defvar *ld-flags* #-msvc "@LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@"
#+msvc "@LDFLAGS@ ecl.lib @CLIBS@")
#+dlopen
(defvar *ld-shared-flags* #-msvc "@SHARED_LDFLAGS@ @LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@"
#+msvc "@SHARED_LDFLAGS@ @LDFLAGS@ ecl.lib @CLIBS@")
#+dlopen
(defvar *ld-bundle-flags* #-msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@"
#+msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ ecl.lib @CLIBS@")
(defvar +shared-library-prefix+ "@SHAREDPREFIX@")
(defvar +shared-library-extension+ "@SHAREDEXT@")
(defvar +shared-library-format+ "@SHAREDPREFIX@~a.@SHAREDEXT@")
(defvar +static-library-prefix+ "@LIBPREFIX@")
(defvar +static-library-extension+ "@LIBEXT@")
(defvar +static-library-format+ "@LIBPREFIX@~a.@LIBEXT@")
(defvar +object-file-extension+ "@OBJEXT@")
(defvar +executable-file-format+ "~a@EXEEXT@")
(defvar *ecl-include-directory* @includedir\@)
(defvar *ecl-library-directory* @libdir\@)

680
src/new-cmp/cmpenv.lsp
View file

@ -1,680 +0,0 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;;
;;;; 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.
;;;; CMPENV Environments of the Compiler.
(in-package "C-ENV")
(defun function-arg-types (arg-types &aux (types nil))
(do ((al arg-types (cdr al)))
((or (endp al)
(member (car al) '(&optional &rest &key)))
(nreverse types))
(declare (object al))
(push (c-types:type-filter (car al)) types)))
(defun proper-list-p (x &optional test)
(and (listp x)
(handler-case (list-length x) (type-error (c) nil))
(or (null test) (every test x))))
;;; The valid return type declaration is:
;;; (( VALUES {type}* )) or ( {type}* ).
(defun function-return-type (return-types)
(cond ((endp return-types) t)
((and (consp (car return-types))
(eq (caar return-types) 'VALUES))
(cond ((not (endp (cdr return-types)))
(warn "The function return types ~s is illegal." return-types)
t)
((or (endp (cdar return-types))
(member (cadar return-types) '(&optional &rest &key)))
t)
(t (c-types:type-filter (cadar return-types)))))
(t (c-types:type-filter (car return-types)))))
(defun add-function-proclamation (fname decl)
(if (si:valid-function-name-p fname)
(let* ((arg-types '*)
(return-types '*)
(l decl))
(cond ((null l))
((consp l)
(setf arg-types (pop l)))
(t (warn "The function proclamation ~s ~s is not valid."
fname decl)))
(cond ((null l))
((and (consp l) (null (rest l)))
(setf return-types (function-return-type l)))
(t (warn "The function proclamation ~s ~s is not valid."
fname decl)))
(if (eq arg-types '*)
(rem-sysprop fname 'PROCLAIMED-ARG-TYPES)
(put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types))
(if (eq return-types '*)
(rem-sysprop fname 'PROCLAIMED-RETURN-TYPE)
(put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)))
(warn "The function proclamation ~s ~s is not valid." fname decl)))
(defun add-function-declaration (fname arg-types return-types env)
(if (si::valid-function-name-p fname)
(cmp-env-register-ftype fname (list arg-types return-types) env)
(warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname))
env)
(defun get-arg-types (fname &optional (env *cmp-env*))
(let ((x (cmp-env-search-ftype fname env)))
(if x
(values (first x) t)
(sys: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
(values (second x) t)
(sys: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))))
(if x
(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))))
(if x
(values (second x) t)
(values nil nil))))
(defun get-proclaimed-narg (fun &optional (env *cmp-env*))
(multiple-value-bind (arg-list found)
(get-arg-types fun env)
(if found
(loop for type in arg-list
with minarg = 0
and maxarg = 0
and in-optionals = nil
do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq)
(return (values minarg call-arguments-limit)))
((eq type '&optional)
(setf in-optionals t maxarg minarg))
(in-optionals
(incf maxarg))
(t
(incf minarg)
(incf maxarg)))
finally (return (values minarg maxarg found)))
(values 0 call-arguments-limit found))))
;;; Proclamation and declaration handling.
(defun inline-possible (fname &optional (env *cmp-env*))
(not (or ; (compiler-<push-events)
;(>= *debug* 2) Breaks compilation of STACK-PUSH-VALUES
(let ((x (cmp-env-search-declaration 'notinline env)))
(and x (member fname x :test #'same-fname-p)))
(member fname *notinline* :test #'same-fname-p)
(sys:get-sysprop fname 'CMP-NOTINLINE))))
#-: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
(dolist (var (cdr decl))
(if (symbolp var)
(sys:*make-special var)
(error "Syntax error in proclamation ~s" decl))))
(OPTIMIZE
(dolist (x (cdr decl))
(when (symbolp x) (setq x (list x 3)))
(if (or (not (consp x))
(not (consp (cdr x)))
(not (numberp (second x)))
(not (<= 0 (second x) 3)))
(warn "The OPTIMIZE proclamation ~s is illegal." x)
(case (car x)
(DEBUG (setq *debug* (second x)))
(SAFETY (setq *safety* (second x)))
(SPACE (setq *space* (second x)))
(SPEED (setq *speed* (second x)))
(COMPILATION-SPEED (setq *speed* (- 3 (second x))))
(t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
(TYPE
(if (consp (cdr decl))
(proclaim-var (second decl) (cddr decl))
(error "Syntax error in proclamation ~s" decl)))
(FTYPE
(if (atom (rest decl))
(error "Syntax error in proclamation ~a" decl)
(multiple-value-bind (type-name args)
(si::normalize-type (second decl))
(if (eq type-name 'FUNCTION)
(dolist (v (cddr decl))
(add-function-proclamation v args))
(error "In an FTYPE proclamation, found ~A which is not a function type."
(second decl))))))
(INLINE
(dolist (fun (cdr decl))
(if (si::valid-function-name-p fun)
(sys:rem-sysprop fun 'CMP-NOTINLINE)
(error "Not a valid function name ~s in proclamation ~s" fun decl))))
(NOTINLINE
(dolist (fun (cdr decl))
(if (si::valid-function-name-p fun)
(sys:put-sysprop fun 'CMP-NOTINLINE t)
(error "Not a valid function name ~s in proclamation ~s" fun decl))))
((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE)
;; FIXME! IGNORED!
(dolist (var (cdr decl))
(unless (si::valid-function-name-p var)
(error "Not a valid function name ~s in ~s proclamation" fun decl-name))))
(DECLARATION
(validate-alien-declaration (rest decl) #'error)
(setf si::*alien-declarations*
(nconc (copy-list (rest decl)) si::*alien-declarations*)))
(SI::C-EXPORT-FNAME
(dolist (x (cdr decl))
(cond ((symbolp x)
(multiple-value-bind (found c-name)
(si::mangle-name x t)
(if found
(warn "The function ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." x)
(sys:put-sysprop x 'Lfun c-name))))
((consp x)
(destructuring-bind (c-name lisp-name) x
(if (si::mangle-name lisp-name)
(warn "The funciton ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." lisp-name)
(sys: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)
(proclaim-var decl-name (cdr decl)))
(otherwise
(cond ((multiple-value-bind (ok type)
(c-types:valid-type-specifier decl-name)
(when ok
(proclaim-var type (rest decl))
t)))
((let ((proclaimer (sys:get-sysprop (car decl) :proclaim)))
(when (functionp proclaimer)
(mapc proclaimer (rest decl))
t)))
((alien-declaration-p (first decl)))
(t
(warn "The declaration specifier ~s is unknown." decl-name))))))
(defun type-name-p (name)
(or (sys:get-sysprop name 'SI::DEFTYPE-DEFINITION)
(find-class name nil)
(sys:get-sysprop name 'SI::STRUCTURE-TYPE)))
(defun validate-alien-declaration (names-list error)
(declare (si::c-local))
(dolist (new-declaration names-list)
(unless (symbolp new-declaration)
(funcall error "The declaration ~s is not a symbol" new-declaration))
(when (type-name-p new-declaration)
(funcall error "Symbol ~S cannot be both the name of a type and of a declaration"
new-declaration))))
(defun proclaim-var (type vl)
(setq type (c-types:type-filter type))
(dolist (var vl)
(if (symbolp var)
(let* ((type1 (sys:get-sysprop var 'CMP-TYPE))
(v (find var *undefined-vars* :key #'var-name))
(merged (if type1 (type-and type1 type) type)))
(unless merged
(warn
"Proclamation for variable ~A of type~&~4T~A~&is incompatible with previous declaration~&~4~T~A"
var type type1)
(setq merged T))
(sys:put-sysprop var 'CMP-TYPE merged)
(when v (setf (var-type v) merged)))
(warn "The variable name ~s is not a symbol." var))))
(defun c1body (body doc-p &aux
(all-declarations nil)
(ss nil) ; special vars
(is nil) ; ignored vars
(ts nil) ; typed vars (var . type)
(others nil) ; all other vars
doc form)
(loop
(when (endp body) (return))
(setq form (cmp-macroexpand (car body)))
(cond
((stringp form)
(when (or (null doc-p) (endp (cdr body)) doc) (return))
(setq doc form))
((and (consp form) (eq (car form) 'DECLARE))
(push form all-declarations)
(dolist (decl (cdr form))
(cmpassert (and (proper-list-p decl) (symbolp (first decl)))
"Syntax error in declaration ~s" form)
(let* ((decl-name (first decl))
(decl-args (rest decl)))
(flet ((declare-variables (type var-list)
(cmpassert (proper-list-p var-list #'symbolp)
"Syntax error in declaration ~s" decl)
(when type
(dolist (var var-list)
(push (cons var type) ts)))))
(case decl-name
(SPECIAL
(cmpassert (proper-list-p decl-args #'symbolp)
"Syntax error in declaration ~s" decl)
(setf ss (append decl-args ss)))
(IGNORE
(cmpassert (proper-list-p decl-args #'symbolp)
"Syntax error in declaration ~s" decl)
(setf is (append decl-args is)))
(TYPE
(cmpassert decl-args "Syntax error in declaration ~s" decl)
(declare-variables (first decl-args) (rest decl-args)))
(OBJECT
(declare-variables 'OBJECT decl-args))
;; read-only variable treatment. obsolete!
(:READ-ONLY
(push decl others))
((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL
DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE
POLICY-DEBUG-IHS-FRAME)
(push decl others))
(otherwise
(multiple-value-bind (ok type)
(c-types:valid-type-specifier decl-name)
(cmpassert ok "The declaration specifier ~s is unknown." decl-name)
(declare-variables type decl-args)))
)))))
(t (return)))
(pop body))
(values body ss ts is others doc all-declarations))
(defun default-optimization (optimization)
(ecase optimization
(speed *speed*)
(safety *safety*)
(space *space*)
(debug *debug*)))
(defun search-optimization-quality (declarations what)
(dolist (i (reverse declarations)
(default-optimization what))
(when (and (consp i) (eq (first i) 'policy-debug-ihs-frame)
(eq what 'debug))
(return 2))
(when (and (consp i) (eq (first i) 'optimize))
(dolist (j (rest i))
(cond ((consp j)
(when (eq (first j) what)
(return-from search-optimization-quality (second j))))
((eq j what)
(return-from search-optimization-quality 3)))))))
(defun compute-optimizations (arguments env)
(let ((optimizations (cmp-env-all-optimizations env)))
(dolist (x arguments)
(when (symbolp x) (setq x (list x 3)))
(unless optimizations
(setq optimizations (cmp-env-all-optimizations)))
(if (or (not (consp x))
(not (consp (cdr x)))
(not (numberp (second x)))
(not (<= 0 (second x) 3)))
(cmpwarn "The OPTIMIZE proclamation ~s is illegal." x)
(let ((value (second x)))
(case (car x)
(DEBUG (setf (first optimizations) value))
(SAFETY (setf (second optimizations) value))
(SPACE (setf (third optimizations) value))
(SPEED (setf (fourth optimizations) value))
(COMPILATION-SPEED)
(t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x)))))))
optimizations))
(defun add-declarations (decls &optional (env *cmp-env*))
(dolist (decl decls)
(case (car decl)
(OPTIMIZE
(let ((optimizations (compute-optimizations (rest decl) env)))
(setf env (cmp-env-add-declaration 'optimize optimizations))))
(POLICY-DEBUG-IHS-FRAME
(setf env (cmp-env-add-declaration 'optimize (compute-optimizations '(debug 2) env))))
(FTYPE
(if (atom (rest decl))
(cmpwarn "Syntax error in declaration ~a" decl)
(multiple-value-bind (type-name args)
(si::normalize-type (second decl))
(if (eq type-name 'FUNCTION)
(dolist (v (cddr decl))
(setf env (add-function-declaration v (first args) (rest args) env)))
(cmpwarn "In an FTYPE declaration, found ~A which is not a function type."
(second decl))))))
(INLINE
(let* ((x (copy-list (cmp-env-search-declaration 'notinline)))
(names (rest decl)))
(dolist (fun names)
(unless (si::valid-function-name-p fun)
(cmperr "Not a valid function name ~s in declaration ~s" fun decl))
(setf x (delete fun x :test #'same-fname-p)))
(setf env (cmp-env-add-declaration 'notinline x))))
(NOTINLINE
(let* ((x (cmp-env-search-declaration 'notinline))
(names (rest decl)))
(dolist (fun names)
(if (si::valid-function-name-p fun)
(push fun x)
(cmperr "Not a valid function name ~s in declaration ~s" fun decl)))
(setf env (cmp-env-add-declaration 'notinline x))))
(DECLARATION
(validate-alien-declaration (rest decl) #'cmperr)
(cmp-env-extend-declarations 'alien (rest decl)))
((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE))
((DYNAMIC-EXTENT IGNORABLE)
;; FIXME! SOME ARE IGNORED!
)
(:READ-ONLY)
(otherwise
(unless (alien-declaration-p (first decl))
(cmpwarn "The declaration specifier ~s is unknown." (car decl))))))
env)
(defun check-vdecl (vnames ts is)
(dolist (x ts)
(unless (member (car x) vnames)
(cmpwarn "Type declaration was found for not bound variable ~s."
(car x))))
(dolist (x is)
(unless (member x vnames)
(cmpwarn "Ignore declaration was found for not bound variable ~s." x))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; COMPILER ENVIRONMENT
;;;
(defmacro cmp-env-new ()
'(cons nil nil))
(defun cmp-env-copy (&optional (env *cmp-env*))
(cons (car env) (cdr env)))
(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))
:special
t)
boundp
var)
(cmp-env-variables env))
env)
(defun cmp-env-declare-special (name &optional (env *cmp-env*))
(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))
env)
(defun cmp-env-extend-declaration (type arguments &optional (env *cmp-env*))
(let ((x (cmp-env-search-declaration type)))
(cmp-env-add-declaration type (append arguments x) env)
env))
(defun cmp-env-register-function (fun &optional (env *cmp-env*))
(push (list (fun-name fun) 'function fun)
(cmp-env-functions env))
env)
(defun cmp-env-register-macro (name function &optional (env *cmp-env*))
(push (list name 'si::macro function)
(cmp-env-functions env))
env)
(defun cmp-env-register-ftype (name declaration &optional (env *cmp-env*))
(push (list* :declare name declaration)
(cmp-env-functions env))
env)
(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*))
(push (list name 'si::symbol-macro #'(lambda (whole env) form))
(cmp-env-variables env))
env)
(defun cmp-env-register-block (blk &optional (env *cmp-env*))
(push (list :block (blk-name blk) blk)
(cmp-env-variables env))
env)
(defun cmp-env-register-tag (name tag &optional (env *cmp-env*))
(push (list :tag (list name) tag)
(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 ((ccb nil)
(clb nil)
(unw nil)
(found nil))
(dolist (record (cmp-env-functions env))
(cond ((eq record 'CB)
(setf ccbb t))
((eq record 'LB)
(setf clb t))
((eq record 'UNWIND-PROTECT)
(setf unw t))
((atom record)
(baboon))
;; We have to use EQUAL because the name can be a list (SETF whatever)
((equal (first record) name)
(setf found (first (last record)))
(return))))
(values found ccb clb unw)))
(defun cmp-env-search-variables (type name env)
(let ((ccb nil)
(clb nil)
(unw nil)
(found nil))
(dolist (record (cmp-env-variables env))
(cond ((eq record 'CB)
(setf ccb t))
((eq record 'LB)
(setf clb t))
((eq record 'UNWIND-PROTECT)
(setf unw t))
((atom record)
(baboon))
((not (eq (first record) type)))
((eq type :block)
(when (eq name (second record))
(setf found record)
(return)))
((eq type :tag)
(when (member name (second record) :test #'eql)
(setf found record)
(return)))
((eq (second record) 'si::symbol-macro)
(when (eq name 'si::symbol-macro)
(setf found record))
(return))
(t
(setf found record)
(return))))
(values (first (last found)) ccb clb unw)))
(defun cmp-env-search-block (name &optional (env *cmp-env*))
(cmp-env-search-variables :block name env))
(defun cmp-env-search-tag (name &optional (env *cmp-env*))
(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))
(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)))
(defun cmp-env-search-ftype (name &optional (env *cmp-env*))
(dolist (i env nil)
(when (and (consp i)
(eq (pop i) :declare)
(same-fname-p (pop i) name))
(return i))))
(defun cmp-env-mark (mark &optional (env *cmp-env*))
(cons (cons mark (car env))
(cons mark (cdr env))))
(defun cmp-env-new-variables (new-env old-env)
(loop for i in (ldiff (cmp-env-variables *cmp-env*)
(cmp-env-variables old-env))
when (and (consp i) (var-p (fourth i)))
collect (fourth i)))
(defun cmp-env-search-declaration (kind &optional (env *cmp-env*))
(loop for i in (car env)
when (and (consp i)
(eq (first i) :declare)
(eq (second i) kind))
return (cddr i)))
(defun cmp-env-all-optimizations (&optional (env *cmp-env*))
(or (cmp-env-search-declaration 'optimize)
(list *debug* *safety* *space* *speed*)))
(defun cmp-env-optimization (property &optional (env *cmp-env*))
(let ((x (cmp-env-all-optimizations env)))
(case property
(debug (first x))
(safety (second x))
(space (third x))
(speed (fourth x)))))
(defun policy-assume-right-type (&optional (env *cmp-env*))
(< (cmp-env-optimization 'safety env) 2))
(defun policy-check-stack-overflow (&optional (env *cmp-env*))
"Do we add a stack check to every function?"
(>= (cmp-env-optimization 'safety env) 2))
(defun policy-inline-slot-access-p (&optional (env *cmp-env*))
"Do we inline access to structures and sealed classes?"
(or (< (cmp-env-optimization 'safety env) 2)
(<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env))))
(defun policy-check-all-arguments-p (&optional (env *cmp-env*))
"Do we assume that arguments are the right type?"
(> (cmp-env-optimization 'safety env) 1))
(defun policy-automatic-check-type-p (&optional (env *cmp-env*))
"Do we generate CHECK-TYPE forms for function arguments with type declarations?"
(and *automatic-check-type-in-lambda*
(>= (cmp-env-optimization 'safety env) 1)))
(defun policy-assume-types-dont-change-p (&optional (env *cmp-env*))
"Do we assume that type and class definitions will not change?"
(<= (cmp-env-optimization 'safety env) 1))
(defun policy-open-code-aref/aset-p (&optional (env *cmp-env*))
"Do we inline access to arrays?"
(< (cmp-env-optimization 'debug env) 2))
(defun policy-open-code-accessors (&optional (env *cmp-env*))
"Do we inline access to object slots, including conses and arrays?"
(< (cmp-env-optimization 'debug env) 2))
(defun policy-array-bounds-check-p (&optional (env *cmp-env*))
"Check access to array bounds?"
(>= (cmp-env-optimization 'safety env) 1))
(defun policy-evaluate-forms (&optional (env *cmp-env*))
"Pre-evaluate a function that takes constant arguments?"
(<= (cmp-env-optimization 'debug env) 1))
(defun alien-declaration-p (name)
(or (member name (cmp-env-search-declaration 'alien) :test #'eq)
(member name si:*alien-declarations*)))
(defun policy-global-var-checking (&optional (env *cmp-env*))
"Do we have to read the value of a global variable even if it is discarded?
Also, when reading the value of a global variable, should we ensure it is bound?"
(>= (cmp-env-optimization 'safety env) 1))
(defun policy-global-function-checking (&optional (env *cmp-env*))
"Do we have to read the binding of a global function even if it is discarded?"
(>= (cmp-env-optimization 'safety env) 1))
(defun policy-debug-variable-bindings (&optional (env *cmp-env*))
"Shall we create a vector with the bindings of each LET/LET*/LAMBDA form?"
;; We can only create variable bindings when the function has an IHS frame!!!
(and (policy-debug-ihs-frame env)
(>= (cmp-env-optimization 'debug env) 3)))
(defun policy-debug-ihs-frame (&optional (env *cmp-env*))
"Shall we create an IHS frame so that this function shows up in backtraces?"
;; Note that this is a prerequisite for registering variable bindings. Hence,
;; it has to be recorded in a special variable.
(>= (fun-debug *current-function*) 2))
(defun policy-check-nargs (&optional (env *cmp-env*))
(>= (cmp-env-optimization 'safety) 1))
(defmacro safe-compile ()
`(>= (cmp-env-optimization 'safety) 2))

1
src/new-cmp/cmplam.lsp
View file

@ -414,7 +414,6 @@
(defun exported-fname (name)
(let (cname)
(if (and (symbolp name)
(not (member name *notinline*))
(setf cname (get-sysprop name 'Lfun)))
(values cname t)
(values (next-cfun "L~D~A" name) nil))))

523
src/new-cmp/cmptype.lsp
View file

@ -14,301 +14,6 @@
(in-package "C-TYPES")
;;; CL-TYPE is any valid type specification of Common Lisp.
;;;
;;; TYPE is a representation type used by ECL. TYPE is one of:
;;;
;;; T(BOOLEAN)
;;;
;;; FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT
;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM)
;;; (VECTOR SINGLE-FLOAT) (VECTOR DOUBLE-FLOAT)
;;; (ARRAY T) (ARRAY BASE-CHAR) (ARRAY BIT)
;;; (ARRAY FIXNUM)
;;; (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT)
;;; STANDARD-OBJECT STRUCTURE-OBJECT
;;; SYMBOL
;;; UNKNOWN
;;;
;;; NIL
;;;
;;;
;;; immediate-type:
;;; FIXNUM int
;;; CHARACTER char
;;; SINGLE-FLOAT float
;;; DOUBLE-FLOAT double
(deftype any () 't)
(defun member-type (type disjoint-supertypes)
(member type disjoint-supertypes :test #'subtypep))
(defun type-filter (type &optional values-allowed)
(multiple-value-bind (type-name type-args) (sys::normalize-type type)
(case type-name
((FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT SYMBOL) type-name)
(SHORT-FLOAT #-short-float 'SINGLE-FLOAT #+short-float 'SHORT-FLOAT)
(LONG-FLOAT #-long-float 'DOUBLE-FLOAT #+long-float 'LONG-FLOAT)
((SIMPLE-STRING STRING) 'STRING)
((SIMPLE-BIT-VECTOR BIT-VECTOR) 'BIT-VECTOR)
((NIL T) t)
((SIMPLE-ARRAY ARRAY)
(cond ((endp type-args) '(ARRAY *)) ; Beppe
((eq '* (car type-args)) t)
(t (let ((element-type (upgraded-array-element-type (car type-args)))
(dimensions (if (cdr type-args) (second type-args) '*)))
(if (and (not (eq dimensions '*))
(or (numberp dimensions)
(= (length dimensions) 1)))
(case element-type
(BASE-CHAR 'STRING)
(BIT 'BIT-VECTOR)
(t (list 'VECTOR element-type)))
(list 'ARRAY element-type))))))
(INTEGER (if (subtypep type 'FIXNUM) 'FIXNUM t))
((STREAM CONS) type-name) ; Juanjo
(FUNCTION type-name)
(t (cond ((eq type-name 'VALUES)
(unless values-allowed
(error "VALUES type found in a place where it is not allowed."))
`(VALUES ,@(mapcar #'(lambda (x)
(if (or (eq x '&optional)
(eq x '&rest))
x
(type-filter x)))
type-args)))
#+clos
((subtypep type 'STANDARD-OBJECT) type)
#+clos
((subtypep type 'STRUCTURE-OBJECT) type)
((dolist (v '(FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT
#+short-float SHORT-FLOAT #+long-float LONG-FLOAT
(VECTOR T) STRING BIT-VECTOR
(VECTOR FIXNUM) (VECTOR SINGLE-FLOAT)
(VECTOR DOUBLE-FLOAT) (ARRAY BASE-CHAR)
(ARRAY BIT) (ARRAY FIXNUM)
(ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT)
(ARRAY T))) ; Beppe
(when (subtypep type v) (return v))))
((and (eq type-name 'SATISFIES) ; Beppe
(symbolp (car type-args))
(sys:get-sysprop (car type-args) 'TYPE-FILTER)))
(t t))))))
(defun valid-type-specifier (type)
(handler-case
(if (subtypep type 'T)
(values t (type-filter type))
(values nil nil))
(error (c) (values nil nil))))
(defun known-type-p (type)
(subtypep type 'T))
(defun-equal-cached type-and (t1 t2)
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
(return-from type-and t1))
(when (eq t1 '*)
(return-from type-and t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*)
(si::*save-types-database* t)
(si::*member-types* si::*member-types*)
(si::*elementary-types* si::*elementary-types*)
(tag1 (si::safe-canonical-type t1))
(tag2 (si::safe-canonical-type t2)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1)
tag2 (si::safe-canonical-type t2))
(cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL
NIL)
((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t1)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t2)
(t
`(AND ,t1 ,t2))))
((eq tag1 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
t2)
((eq tag2 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
t1)
((null tag1)
(setf c::*compiler-break-enable* t)
;(error "foo")
(cmpnote "Unknown type ~S. Assuming it is T." t1)
t2)
(t
(setf c::*compiler-break-enable* t)
;(error "foo")
(cmpnote "Unknown type ~S. Assuming it is T." t2)
t1))))
(defun-equal-cached values-type-primary-type (type)
(when (and (consp type) (eq (first type) 'VALUES))
(let ((subtype (second type)))
(when (or (eq subtype '&optional) (eq subtype '&rest))
(setf type (cddr type))
(when (or (null type)
(eq (setf subtype (first type)) '&optional)
(eq subtype '&rest))
(cmperr "Syntax error in type expression ~S" type))
;; An &optional or &rest output value might be missing
;; If this is the case, the the value will be NIL.
(setf subtype (type-or 'null subtype)))
(setf type subtype)))
type)
(defun-equal-cached values-type-to-n-types (type length)
(if (or (atom type) (not (eql (first type) 'values)))
(list* type (make-list (1- length) :initial-element 'NULL))
(do* ((l (rest type))
(output '())
(n length (1- n)))
((or (null l) (zerop n)) (nreverse output))
(let ((type (pop l)))
(case type
(&optional
(when (null l)
(cmperr "Syntax error in type expression ~S" type))
(setf type (pop l)))
(&rest
(when (null l)
(cmperr "Syntax error in type expression ~S" type))
(return-from values-type-to-n-types
(nreconc output (make-list n :initial-element (first l))))))
(push type output)))))
(defun split-values-type (type)
(if (or (atom type) (not (eq (first type) 'VALUES)))
(values (list type) nil nil)
(let ((rest (member '&rest type))
(opt (member '&optional type)))
(values (ldiff (rest type) (or rest opt))
(ldiff (rest (member '&optional type)) rest)
(rest (member '&rest type))))))
(defun-equal-cached values-type-or (t1 t2)
(when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
(return-from values-type-or t2))
(when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
(return-from values-type-or t1))
(unless t1
(return-from values-type-or t2))
(unless t2
(return-from values-type-or t1))
(multiple-value-bind (req1 opt1 rest1)
(split-values-type t1)
(multiple-value-bind (req2 opt2 rest2)
(split-values-type t2)
(let ((req '())
(opt '())
(rest '()))
(loop for t1 in req1
do (cond (req2
(push (type-or t1 (pop req2)) req))
(opt2
(push (type-or t1 (pop opt2)) opt))
(rest2
(push (type-or t1 (first rest2)) opt))
(t
(push t1 opt))))
(loop for t1 in opt1
do (cond (req2
(push (type-or t1 (pop req2)) opt))
(opt2
(push (type-or t1 (pop opt2)) opt))
(rest2
(push (type-or t1 (first rest2)) opt))
(t
(push t1 opt))))
(let ((t1 (if rest1 (first rest1) t)))
(loop for t2 in req2
do (push (type-or t1 t2) opt))
(loop for t2 in opt2
do (push (type-or t1 t2) opt))
(if rest2
(setf rest (list (type-or t1 (first rest2))))
(setf rest rest1)))
`(VALUES ,@(nreverse req)
,@(and opt (cons '&optional (nreverse opt)))
,@(and rest (cons '&optional rest)))))))
(defun-equal-cached values-type-and (t1 t2)
(when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
(return-from values-type-and t1))
(when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
(return-from values-type-and t2))
(when (or (null t1) (null t2))
(return-from values-type-and nil))
(multiple-value-bind (req1 opt1 rest1)
(split-values-type t1)
(multiple-value-bind (req2 opt2 rest2)
(split-values-type t2)
(let ((req '())
(opt '())
(rest '()))
(loop for t1 in req1
do (cond (req2 (push (type-and t1 (pop req2)) req))
(opt2 (push (type-and t1 (pop opt2)) req))
(rest2 (push (type-and t1 (first rest2)) req))
(t (setf opt1 nil rest1 nil) (return))))
(loop for t1 in opt1
do (cond (req2 (push (type-and t1 (pop req2)) req))
(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)))
(loop for t2 in req2
do (push (type-and t1 t2) req))
(loop for t2 in opt2
do (push (type-and t1 t2) opt))
(when rest2
(setf rest (list (type-and t1 (first rest2)))))))
`(VALUES ,@(nreverse req)
,@(and opt (cons '&optional (nreverse opt)))
,@(and rest (cons '&optional rest)))))))
(defun-equal-cached type-or (t1 t2)
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
(return-from type-or t1))
(when (eq t1 '*)
(return-from type-or t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*)
(si::*save-types-database* t)
(si::*member-types* si::*member-types*)
(si::*elementary-types* si::*elementary-types*)
(tag1 (si::safe-canonical-type t1))
(tag2 (si::safe-canonical-type t2)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1)
tag2 (si::safe-canonical-type t2))
(cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t2)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t1)
(t
`(OR ,t1 ,t2))))
((eq tag1 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
T)
((eq tag2 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
T)
((null tag1)
(cmpnote "Unknown type ~S" t1)
T)
(t
(cmpnote "Unknown type ~S" t2)
T))))
(defun type>= (type1 type2)
(subtypep type2 type1))
;;;
;;; and-form-type
;;; returns a copy of form whose type is the type-and of type and the form's
@ -337,234 +42,6 @@
(defun default-init-loc (var)
(c1form-arg 0 (c1expr (default-init var))))
;;----------------------------------------------------------------------
;; (FUNCTION ...) types. This code is a continuation of predlib.lsp.
;; It implements function types and a SUBTYPEP relationship between them.
;;
(in-package "SI")
(defstruct function-type
required
optional
rest
key-p
keywords
keyword-types
allow-other-keys-p
output)
(defun canonical-function-type (ftype)
(when (function-type-p ftype)
(return-from canonical-function-type ftype))
(flet ((ftype-error ()
(error "Syntax error in FUNCTION type definition ~S" ftype)))
(let (o k k-t values)
(unless (and (= (length ftype) 3) (eql (first ftype) 'FUNCTION))
(ftype-error))
(multiple-value-bind (requireds optionals rest key-flag keywords
allow-other-keys-p auxs)
(si::process-lambda-list (second ftype) 'FTYPE)
(dotimes (i (pop optionals))
(let ((type (first optionals))
(init (second optionals))
(flag (third optionals)))
(setq optionals (cdddr optionals))
(when (or init flag) (ftype-error))
(push type o)))
(dotimes (i (pop keywords))
(let ((keyword (first keywords))
(var (second keywords))
(type (third keywords))
(flag (fourth keywords)))
(setq keywords (cddddr keywords))
(when (or var flag) (ftype-error))
(push keyword k)
(push type k-t)))
(setf values (third ftype))
(cond ((atom values) (setf values (list 'VALUES values)))
((and (listp values) (eql (first values) 'VALUES)))
(t (ftype-error)))
(when (and rest key-flag
(not (subtypep 'keyword rest)))
(ftype-error))
(make-function-type :required (rest requireds)
:optional o
:rest rest
:key-p key-flag
:keywords k
:keyword-types k-t
:allow-other-keys-p allow-other-keys-p
:output (canonical-values-type values))))))
(defconstant +function-type-tag+ (cdr (assoc 'FUNCTION *elementary-types*)))
(defun register-function-type (type)
(or (find-registered-tag type)
(find-registered-tag (setq ftype (canonical-function-type type)))
(let ((tag (register-type ftype #'function-type-p #'function-type-<=)))
(update-types +function-type-tag+ tag)
tag)))
(defun function-type-<= (f1 f2)
(unless (and (every* #'subtypep
(function-type-required f2)
(function-type-required f1))
(do* ((o1 (function-type-optional f1) (cdr o1))
(o2 (function-type-optional f2) (cdr o2))
(r1 (function-type-rest f1))
(r2 (function-type-rest f2))
t1 t2)
((and (endp o1) (endp o2)) t)
(setf t1 (cond ((consp o1) (first o1))
(r1 r1)
(t (return nil)))
t2 (cond ((consp o2) (first o2))
(r2 r2)
(t (return nil))))
(unless (subtypep t1 t2)
(return nil)))
(subtypep (function-type-output f1)
(function-type-output f2))
(eql (function-type-key-p f1) (function-type-key-p f2))
(or (function-type-allow-other-keys-p f2)
(not (function-type-allow-other-keys-p f1))))
(return-from function-type-<= nil))
(do* ((k2 (function-type-keywords f2))
(k-t2 (function-type-keyword-types f2))
(k1 (function-type-keywords f1) (cdr k1))
(k-t1 (function-type-keyword-types f1) (cdr k1)))
((endp k1)
t)
(unless
(let* ((n (position (first k1) k2)))
(when n
(let ((t2 (nth n k-t2)))
(subtypep (first k-t1) t2))))
(return-from function-type-<= nil))))
;;----------------------------------------------------------------------
;; (VALUES ...) type
(defstruct values-type
min-values
max-values
required
optional
rest)
(defun register-values-type (vtype)
(or (find-registered-tag vtype)
(find-registered-tag (setf vtype (canonical-values-type vtype)))
(register-type vtype #'values-type-p #'values-type-<=)))
(defun canonical-values-type (vtype)
(when (values-type-p vtype)
(return-from canonical-values-type vtype))
(flet ((vtype-error ()
(error "Syntax error in VALUES type definition ~S" vtype)))
(unless (and (listp vtype) (eql (pop vtype) 'VALUES))
(vtype-error))
(let ((required '())
(optional '())
(rest nil))
(do ()
((endp vtype)
(make-values-type :min-values (length required)
:max-values (if rest multiple-values-limit
(+ (length required)
(length optional)))
:required (nreverse required)
:optional (nreverse optional)
:rest rest))
(let ((type (pop vtype)))
(if (eql type '&optional)
(do ()
((endp vtype))
(let ((type (pop vtype)))
(if (eql type '&rest)
(if (endp vtype)
(ftype-error)
(setf rest (first vtype)))
(push type optional))))
(push type required)))))))
(defun values-type-<= (v1 v2)
(and (= (values-type-min-values v1) (values-type-min-values v2))
(= (values-type-max-values v1) (values-type-max-values v2))
(every* #'subtypep (values-type-required v1) (values-type-required v2))
(every* #'subtypep (values-type-optional v1) (values-type-optional v2))
(subtypep (values-type-rest v1) (values-type-rest v2))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; TYPE PROPAGATORS
;;;
(in-package "C-TYPES")
(defun infer-arg-and-return-types (fname forms &optional (env *cmp-env*))
(let ((found (sys:get-sysprop fname 'C1TYPE-PROPAGATOR))
arg-types
(return-type '(VALUES &REST T)))
(cond (found
(multiple-value-setq (arg-types return-type)
(apply found fname (mapcar #'location-primary-type forms))))
((multiple-value-setq (arg-types found)
(get-arg-types fname env))
(setf return-type (or (get-return-type fname) return-type))))
(values arg-types return-type found)))
(defun enforce-types (fname arg-types arguments)
(do* ((types arg-types (rest types))
(args arguments (rest args))
(i 1 (1+ i))
(in-optionals nil))
((endp types)
(when types
(cmpwarn "Too many arguments passed to ~A" fname)))
(let ((expected-type (first types)))
(when (member expected-type '(* &rest &key &allow-other-keys) :test #'eq)
(return))
(when (eq expected-type '&optional)
(when (or in-optionals (null (rest types)))
(cmpwarn "Syntax error in type proclamation for function ~A.~&~A"
fname arg-types))
(setf in-optionals t
types (rest types)
expected-type (first types)))
(when (endp args)
(unless in-optionals
(cmpwarn "Too few arguments for proclaimed function ~A" fname))
(return))
(let* ((value (first args))
(actual-type (location-primary-type value))
(intersection (type-and actual-type expected-type)))
(unless intersection
(cmperr "The argument ~d of function ~a has type~&~4T~A~&instead of expected~&~4T~A"
i fname actual-type expected-type))))))
(defun propagate-types (fname forms)
(multiple-value-bind (arg-types return-type found)
(infer-arg-and-return-types fname forms)
(when found
(enforce-types fname arg-types forms))
return-type))
(defmacro def-type-propagator (fname lambda-list &body body)
(unless (member '&rest lambda-list)
(let ((var (gensym)))
(setf lambda-list (append lambda-list (list '&rest var))
body (list* `(declare (ignorable ,var)) body)))
`(sys:put-sysprop ',fname 'C1TYPE-PROPAGATOR
#'(ext:lambda-block ,fname ,lambda-list ,@body))))
(defun copy-type-propagator (orig dest-list)
(loop with function = (sys:get-sysprop orig 'C1TYPE-PROPAGATOR)
for name in dest-list
do (sys:put-sysprop name 'C1TYPE-PROPAGATOR function)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; TYPE CHECKING

22
src/new-cmp/load.lsp.in
View file

@ -2,21 +2,26 @@
(defconstant +cmp-module-files+
'("src:new-cmp;cmppackage.lsp"
"src:new-cmp;cmptypes.lsp"
"src:new-cmp;cmpglobals.lsp"
"build:new-cmp;cmpdefs.lsp"
"src:cmp;cmptypes.lsp"
"src:cmp;cmpglobals.lsp"
"build:cmp;cmpdefs.lsp"
"src:new-cmp;cmptables.lsp"
"src:new-cmp;cmpdata.lsp"
"src:new-cmp;cmpmac.lsp"
"src:new-cmp;cmpform.lsp"
"src:new-cmp;cmploc.lsp"
"src:cmp;cmputil.lsp"
"src:cmp;cmptype-arith.lsp"
"src:cmp;cmptype-prop.lsp"
"src:new-cmp;cmptype.lsp"
"src:new-cmp;cmptranslate.lsp"
"src:new-cmp;cmpblock.lsp"
"src:new-cmp;cmpcall.lsp"
"src:new-cmp;cmpcatch.lsp"
"src:new-cmp;cmpenv.lsp"
"src:cmp;cmpenv-api.lsp"
"src:cmp;cmpenv-fun.lsp"
"src:cmp;cmpenv-decl.lsp"
"src:cmp;cmppolicy.lsp"
"src:new-cmp;cmpeval.lsp"
"src:new-cmp;cmpcffi.lsp"
"src:new-cmp;cmpflet.lsp"
@ -41,7 +46,7 @@
"src:new-cmp;cmparray.lsp"
"src:new-cmp;cmppass.lsp"
"src:new-cmp;cmpc.lsp"
"src:new-cmp;cmpc-wt.lsp"
"src:cmp;cmpc-wt.lsp"
"src:new-cmp;cmpc-loc.lsp"
"src:new-cmp;cmpc-set.lsp"
"src:new-cmp;cmpc-ffi.lsp"
@ -53,9 +58,10 @@
"src:new-cmp;cmpc-tables.lsp"
"src:new-cmp;cmpc-cbk.lsp"
"src:new-cmp;cmpc-top.lsp"
"src:new-cmp;cmpmain.lsp"))
"src:new-cmp;cmpmain.lsp"
"src:cmp;proclamations.lsp"
"src:cmp;sysfun.lsp"))
(let ((si::*keep-documentation* nil))
(mapc #'(lambda (x) (load x :verbose t)) +cmp-module-files+)
(load "src:new-cmp;sysfun" :verbose t))
(mapc #'(lambda (x) (load x :verbose t)) +cmp-module-files+))

2208
src/new-cmp/sysfun.lsp
View file

File diff suppressed because it is too large Load diff