Newer
Older
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; This file contains load-time support for declaration processing. It is
;;; split off from the compiler so that the compiler doesn'thave to be in the
;;; cold load.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package "C")
(in-package "EXTENSIONS")
(export '(inhibit-warnings))
(in-package "LISP")
(export '(declaim proclaim))
(in-package "C")
;;; True if the type system has been properly initialized, and thus is o.k. to
;;; use.
;;;
(defvar *type-system-initialized* nil)
;;; The Cookie holds information about the compilation environment for a node.
;;; See the Node definition for a description of how it is used.
;;;
(defstruct cookie
(speed nil :type (or (rational 0 3) null))
(space nil :type (or (rational 0 3) null))
(safety nil :type (or (rational 0 3) null))
(cspeed nil :type (or (rational 0 3) null))
(brevity nil :type (or (rational 0 3) null))
(debug nil :type (or (rational 0 3) null)))
;;; The *default-cookie* represents the current global compiler policy
;;; information. Whenever the policy is changed, we copy the structure so that
;;; old uses will still get the old values.
;;;
(proclaim '(type cookie *default-cookie*))
(defvar *default-cookie* (make-cookie :safety 1 :speed 1 :space 1 :cspeed 1
:brevity 1 :debug 2))
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
;;; Parse-Lambda-List -- Interface
;;;
;;; Break a lambda-list into its component parts. We return eight values:
;;; 1] A list of the required args.
;;; 2] A list of the optional arg specs.
;;; 3] True if a rest arg was specified.
;;; 4] The rest arg.
;;; 5] A boolean indicating whether keywords args are present.
;;; 6] A list of the keyword arg specs.
;;; 7] True if &allow-other-keys was specified.
;;; 8] A list of the &aux specifiers.
;;;
;;; The top-level lambda-list syntax is checked for validity, but the arg
;;; specifiers are just passed through untouched. If something is wrong, we
;;; use Compiler-Error, aborting compilation to the last recovery point.
;;;
;;; [Eventually this should go into the code sources, since it is used in
;;; various random places such as the function type parsing.]
;;;
(proclaim '(function parse-lambda-list (list)
(values list list boolean t boolean list boolean list)))
(defun parse-lambda-list (list)
(collect ((required)
(optional)
(keys)
(aux))
(let ((restp nil)
(rest nil)
(keyp nil)
(allowp nil)
(state :required))
(dolist (arg list)
(if (and (symbolp arg)
(let ((name (symbol-name arg)))
(and (/= (length name) 0)
(char= (char name 0) #\&))))
(case arg
(&optional
(unless (eq state :required)
(compiler-error "Misplaced &optional in lambda-list: ~S." list))
(setq state '&optional))
(&rest
(unless (member state '(:required &optional))
(compiler-error "Misplaced &rest in lambda-list: ~S." list))
(setq state '&rest))
(&key
(unless (member state '(:required &optional :post-rest))
(compiler-error "Misplaced &key in lambda-list: ~S." list))
(setq keyp t)
(setq state '&key))
(&allow-other-keys
(unless (eq state '&key)
(compiler-error "Misplaced &allow-other-keys in lambda-list: ~S." list))
(setq allowp t state '&allow-other-keys))
(&aux
(when (eq state '&rest)
(compiler-error "Misplaced &aux in lambda-list: ~S." list))
(setq state '&aux))
(t
(compiler-error "Unknown &keyword in lambda-list: ~S." arg)))
(case state
(:required (required arg))
(&optional (optional arg))
(&rest
(setq restp t rest arg state :post-rest))
(&key (keys arg))
(&aux (aux arg))
(t
(compiler-error "Found garbage in lambda-list when expecting a keyword: ~S." arg)))))
(values (required) (optional) restp rest keyp (keys) allowp (aux)))))
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
;;; Check-Function-Name -- Interface
;;;
;;; Check that Name is a valid function name, returning the name if OK, and
;;; doing an error if not. In addition to checking for basic well-formedness,
;;; we also check that symbol names are not NIL or the name of a special form.
;;;
(defun check-function-name (name)
(typecase name
(list
(unless (and (consp name) (consp (cdr name))
(null (cddr name)) (eq (car name) 'setf)
(symbolp (cadr name)))
(compiler-error "Illegal function name: ~S." name))
name)
(symbol
(when (eq (info function kind name) :special-form)
(compiler-error "Special form is an illegal function name: ~S." name))
name)
(t
(compiler-error "Illegal function name: ~S." name))))
;;; Define-Function-Name -- Interface
;;;
;;; Check the legality of a function name that is being introduced. If it
;;; names a macro, then give a warning and blast the macro information.
;;;
(proclaim '(function define-function-name (t) void))
(defun define-function-name (name)
(check-function-name name)
(ecase (info function kind name)
(:function)
(:special-from
(compiler-error "~S names a special form, so cannot be a function." name))
(:macro
(compiler-warning "~S previously defined as a macro." name)
(setf (info function kind name) :function)
(setf (info function where-from name) :assumed)
(clear-info function macro-function name))
((nil)
(setf (info function kind name) :function)))
name)
;;; Process-Optimize-Declaration -- Interface
;;;
;;; Return a new cookie containing the policy information represented by the
;;; optimize declaration Spec. Any parameters not specified are defaulted from
;;; Cookie.
;;;
(proclaim '(function process-optimize-declaration (list cookie) cookie))
(defun process-optimize-declaration (spec cookie)
(let ((res (copy-cookie cookie)))
(dolist (quality (cdr spec))
(let ((quality (if (atom quality) (list quality 3) quality)))
(if (and (consp (cdr quality)) (null (cddr quality))
(typep (second quality) 'real) (<= 0 (second quality) 3))
(let ((value (rational (second quality))))
(case (first quality)
(speed (setf (cookie-speed res) value))
(space (setf (cookie-space res) value))
(safety (setf (cookie-safety res) value))
(compilation-speed (setf (cookie-cspeed res) value))
((inhibit-warnings brevity) (setf (cookie-brevity res) value))
(debug-info (setf (cookie-debug res) value))
(t
(compiler-warning "Unknown optimization quality ~S in ~S."
(car quality) spec))))
(compiler-warning
"Malformed optimization quality specifier ~S in ~S."
quality spec))))
res))
;;; DECLAIM -- Public
;;;
;;; For now, just PROCLAIM without any EVAL-WHEN.
;;;
(defmacro declaim (&rest specs)
"DECLAIM Declaration*
Do a declaration for the global environment."
`(progn ,@(mapcar #'(lambda (x)
`(proclaim ',x))
specs)))
;;; %Proclaim -- Interface
;;;
;;; This function is the guts of proclaim, since it does the global
;;; environment updating.
;;;
(defun %proclaim (form)
(unless (consp form)
(error "Malformed PROCLAIM spec: ~S." form))
(let ((kind (first form))
(args (rest form)))
(case kind
(special
(dolist (name args)
(unless (symbolp name)
(error "Variable name is not a symbol: ~S." name))
(clear-info variable constant-value name)
(setf (info variable kind name) :special)))
(type
(when *type-system-initialized*
(let ((type (specifier-type (first args))))
(dolist (name (rest args))
(unless (symbolp name)
(error "Variable name is not a symbol: ~S." name))
(setf (info variable type name) type)
(setf (info variable where-from name) :declared)))))
(when *type-system-initialized*
(let ((type (specifier-type (first args))))
(unless (csubtypep type (specifier-type 'function))
(error "Declared functional type is not a function type: ~S."
(first args)))
(dolist (name (rest args))
(define-function-name name)
(setf (info function type name) type)
(setf (info function where-from name) :declared)))))
(when *type-system-initialized*
(%proclaim `(ftype (function . ,(rest args)) ,(first args)))))
(setq *default-cookie*
(process-optimize-declaration form *default-cookie*)))
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
((inline notinline maybe-inline)
(dolist (name args)
(define-function-name name)
(setf (info function inlinep name)
(case kind
(inline :inline)
(notinline :notinline)
(maybe-inline :maybe-inline)))))
(declaration
(dolist (decl args)
(unless (symbolp decl)
(error "Declaration to be RECOGNIZED is not a symbol: ~S." decl))
(setf (info declaration recognized decl) t)))
(t
(if (member kind type-specifier-symbols)
(%proclaim `(type . ,form))
(error "Unrecognized proclamation: ~S." form)))))
(undefined-value))
;;;
(setf (symbol-function 'proclaim) #'%proclaim)
;;; %%Compiler-Defstruct -- Interface
;;;
;;; This function updates the global compiler information to represent the
;;; definition of the the structure described by Info.
;;;
(defun %%compiler-defstruct (info)
(declare (type defstruct-description info))
(let ((name (dd-name info)))
(dolist (inc (dd-includes info))
(let ((info (info type structure-info inc)))
(unless info
(error "Structure type ~S is included by ~S but not defined."
inc name))
(pushnew name (dd-included-by info))))
(let ((old (info type structure-info name)))
(when old
(setf (dd-included-by info) (dd-included-by old))))
(setf (info type kind name) :structure)
(setf (info type structure-info name) info)
(when (info type expander name)
(setf (info type expander name) nil))
(%note-type-defined name))
;;; ### Should declare arg/result types.
(let ((copier (dd-copier info)))
(when copier
(define-function-name copier)
(setf (info function where-from copier) :defined)))
;;; ### Should make a known type predicate.
(let ((predicate (dd-predicate info)))
(when predicate
(define-function-name predicate)
(setf (info function where-from predicate) :defined)))
(dolist (slot (dd-slots info))
(let ((fun (dsd-accessor slot)))
(define-function-name fun)
(setf (info function accessor-for fun) info)
;;
;; ### Bootstrap hack...
;; This blows away any inverse that has been loaded into the bootstrap
;; environment. Probably this should be more general (expanders, etc.),
;; and also perhaps done on other functions.
(when (info setf inverse fun)
(setf (info setf inverse fun) nil))
(unless (dsd-read-only slot)
(setf (info function accessor-for `(setf ,fun)) info))))
(undefined-value))
(setf (symbol-function '%compiler-defstruct) #'%%compiler-defstruct)
;;; %NOTE-TYPE-DEFINED -- Interface
;;;
;;; Note that the type Name has been (re)defined, updating the undefined
;;; warnings and VALUES-SPECIFIER-TYPE cache.
;;;
(defun %note-type-defined (name)
(declare (symbol name))
(when (boundp '*undefined-warnings*)
(note-name-defined name :type))
(when (boundp '*values-specifier-type-cache-vector*)
(values-specifier-type-cache-clear))
(undefined-value))
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
;;;; Dummy definitions of COMPILER-ERROR, etc.
;;;
;;; Until the compiler is properly loaded, we make the compiler error
;;; functions synonyms for the obvious standard error function.
;;;
(defun compiler-error (string &rest args)
(apply #'error string args))
(defun compiler-warning (string &rest args)
(apply #'warn string args))
(defun compiler-note (string &rest args)
(apply #'warn string args))
(defun compiler-error-message (string &rest args)
(apply #'warn string args))
;;; Alien=>Lisp-Transform -- Internal
;;;
;;; This is the transform for alien-operators and other alien-valued
;;; things which may be evaluated normally to yield an alien-value structure.
;;;
(defun alien=>lisp-transform (form)
(multiple-value-bind (binds stuff res)
(analyze-alien-expression nil form)
`(let* ,(reverse binds)
,(ignore-unreferenced-vars binds)
,@(nreverse stuff)
,(if (ct-a-val-alien res)
(ct-a-val-alien res)
`(lisp::make-alien-value
,(ct-a-val-sap res)
,(ct-a-val-offset res)
,(ct-a-val-size res)
',(ct-a-val-type res))))))