| 1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2009 Clozure Associates |
|---|
| 4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
|---|
| 5 | ;;; This file is part of Clozure CL. |
|---|
| 6 | ;;; |
|---|
| 7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
|---|
| 8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
|---|
| 9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
|---|
| 10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
|---|
| 11 | ;;; conflict, the preamble takes precedence. |
|---|
| 12 | ;;; |
|---|
| 13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
|---|
| 14 | ;;; |
|---|
| 15 | ;;; The LLGPL is also available online at |
|---|
| 16 | ;;; http://opensource.franz.com/preamble.html |
|---|
| 17 | |
|---|
| 18 | |
|---|
| 19 | ;; used by compiler and eval - stuff here is not excised with rest of compiler |
|---|
| 20 | |
|---|
| 21 | |
|---|
| 22 | (in-package :ccl) |
|---|
| 23 | |
|---|
| 24 | #|| Note: when MCL-AppGen 4.0 is built, the following form will need to be included in it: |
|---|
| 25 | ; for compiler-special-form-p, called by cheap-eval-in-environment |
|---|
| 26 | (defparameter *nx1-compiler-special-forms* |
|---|
| 27 | `(%DEFUN %FUNCTION %NEW-PTR %NEWGOTAG %PRIMITIVE %VREFLET BLOCK CATCH COMPILER-LET DEBIND |
|---|
| 28 | DECLARE EVAL-WHEN FBIND FLET FUNCTION GO IF LABELS LAP LAP-INLINE LET LET* LOAD-TIME-VALUE |
|---|
| 29 | LOCALLY MACRO-BIND MACROLET MAKE-LIST MULTIPLE-VALUE-BIND MULTIPLE-VALUE-CALL |
|---|
| 30 | MULTIPLE-VALUE-LIST MULTIPLE-VALUE-PROG1 NEW-LAP NEW-LAP-INLINE NFUNCTION OLD-LAP |
|---|
| 31 | OLD-LAP-INLINE OR PROG1 PROGN PROGV QUOTE RETURN-FROM SETQ STRUCT-REF STRUCT-SET |
|---|
| 32 | SYMBOL-MACROLET TAGBODY THE THROW UNWIND-PROTECT WITH-STACK-DOUBLE-FLOATS WITHOUT-INTERRUPTS)) |
|---|
| 33 | ||# |
|---|
| 34 | |
|---|
| 35 | (eval-when (:compile-toplevel) |
|---|
| 36 | (require 'nxenv)) |
|---|
| 37 | |
|---|
| 38 | (defvar *lisp-compiler-version* 666 "I lost count.") |
|---|
| 39 | |
|---|
| 40 | (defvar *nx-compile-time-types* nil) |
|---|
| 41 | (defvar *nx-proclaimed-types* nil) |
|---|
| 42 | (defvar *nx-method-warning-name* nil) |
|---|
| 43 | |
|---|
| 44 | (defvar *nx-current-code-note*) |
|---|
| 45 | |
|---|
| 46 | ;; The problem with undefind type warnings is that there is no in-language way to shut |
|---|
| 47 | ;; them up even when the reference is intentional. (In case of undefined functions, |
|---|
| 48 | ;; you can declare FTYPE and that will turn off any warnings without interfering with |
|---|
| 49 | ;; the function being defined later). For now just provide this as an out. |
|---|
| 50 | (defvar *compiler-warn-on-undefined-type-references* #+ccl-qres t #-ccl-qres t) |
|---|
| 51 | |
|---|
| 52 | |
|---|
| 53 | |
|---|
| 54 | ;; In lieu of a slot in acode. Don't reference this variable elsewhere because I'm |
|---|
| 55 | ;; hoping to make it go away. |
|---|
| 56 | (defparameter *nx-acode-note-map* nil) |
|---|
| 57 | |
|---|
| 58 | (defun acode-note (acode &aux (hash *nx-acode-note-map*)) |
|---|
| 59 | (and hash (gethash acode hash))) |
|---|
| 60 | |
|---|
| 61 | (defun (setf acode-note) (note acode) |
|---|
| 62 | (when note |
|---|
| 63 | (assert *nx-acode-note-map*) |
|---|
| 64 | ;; Only record if have a unique key |
|---|
| 65 | (unless (or (atom acode) |
|---|
| 66 | (nx-null acode) |
|---|
| 67 | (nx-t acode)) |
|---|
| 68 | (setf (gethash acode *nx-acode-note-map*) note)))) |
|---|
| 69 | |
|---|
| 70 | |
|---|
| 71 | (defstruct (code-note (:constructor %make-code-note)) |
|---|
| 72 | ;; Code coverage state. This MUST be the first slot - see nx2-code-coverage. |
|---|
| 73 | code-coverage |
|---|
| 74 | ;; The source note of this form, or NIL if random code form (no file info, |
|---|
| 75 | ;; generated by macros or other source transform) |
|---|
| 76 | source-note |
|---|
| 77 | ;; the note that was being compiled when this note was emitted. |
|---|
| 78 | parent-note |
|---|
| 79 | ;; start/end position in the acode string for the toplevel lfun containing this code note. |
|---|
| 80 | acode-range |
|---|
| 81 | #+debug-code-notes ;; The actual source form - useful for debugging, otherwise unused. |
|---|
| 82 | form) |
|---|
| 83 | |
|---|
| 84 | (defun make-code-note (&key form source-note parent-note) |
|---|
| 85 | (declare (ignorable form)) |
|---|
| 86 | (let ((note (%make-code-note |
|---|
| 87 | :source-note source-note |
|---|
| 88 | :parent-note parent-note))) |
|---|
| 89 | #+debug-code-notes |
|---|
| 90 | (when form |
|---|
| 91 | ;; Unfortunately, recording the macroexpanded form is problematic, since they |
|---|
| 92 | ;; can have references to non-dumpable forms, see e.g. loop. |
|---|
| 93 | (setf (code-note-form note) |
|---|
| 94 | (with-output-to-string (s) (let ((*print-circle* t)) (prin1 form s))))) |
|---|
| 95 | note)) |
|---|
| 96 | |
|---|
| 97 | (defmethod print-object ((note code-note) stream) |
|---|
| 98 | (print-unreadable-object (note stream :type t :identity t) |
|---|
| 99 | (format stream "[~s]" (code-note-code-coverage note)) |
|---|
| 100 | (let ((sn (code-note-source-note note))) |
|---|
| 101 | (if sn |
|---|
| 102 | (progn |
|---|
| 103 | (format stream " for ") |
|---|
| 104 | (print-source-note sn stream)) |
|---|
| 105 | #+debug-code-notes |
|---|
| 106 | (when (code-note-form note) |
|---|
| 107 | (format stream " form ~a" |
|---|
| 108 | (string-sans-most-whitespace (code-note-form note)))))))) |
|---|
| 109 | |
|---|
| 110 | (defun nx-ensure-code-note (form &optional parent-note) |
|---|
| 111 | (let* ((parent-note (or parent-note *nx-current-code-note*)) |
|---|
| 112 | (source-note (nx-source-note form))) |
|---|
| 113 | (unless (and source-note |
|---|
| 114 | ;; Look out for a case like a lambda macro that turns (lambda ...) |
|---|
| 115 | ;; into (FUNCTION (lambda ...)) which then has (lambda ...) |
|---|
| 116 | ;; as a child. Create a fresh note for the child, to avoid ambiguity. |
|---|
| 117 | ;; Another case is forms wrapping THE around themselves. |
|---|
| 118 | (neq source-note (code-note-source-note parent-note)) |
|---|
| 119 | ;; Don't use source notes from a different toplevel form, which could |
|---|
| 120 | ;; happen due to inlining etc. The result then is that the source note |
|---|
| 121 | ;; appears in multiple places, and shows partial coverage (from the |
|---|
| 122 | ;; other reference) in code that's never executed. |
|---|
| 123 | (loop for p = parent-note then (code-note-parent-note p) |
|---|
| 124 | when (null p) return t |
|---|
| 125 | when (code-note-source-note p) |
|---|
| 126 | return (eq (loop for n = source-note then s |
|---|
| 127 | as s = (source-note-source n) |
|---|
| 128 | unless (source-note-p s) return n) |
|---|
| 129 | (loop for n = (code-note-source-note p) then s |
|---|
| 130 | as s = (source-note-source n) |
|---|
| 131 | unless (source-note-p s) return n)))) |
|---|
| 132 | (setq source-note nil)) |
|---|
| 133 | (make-code-note :form form :source-note source-note :parent-note parent-note))) |
|---|
| 134 | |
|---|
| 135 | (defun nx-note-source-transformation (original new &aux (source-notes *nx-source-note-map*) sn) |
|---|
| 136 | (when (and source-notes |
|---|
| 137 | (setq sn (gethash original source-notes)) |
|---|
| 138 | (not (gethash new source-notes))) |
|---|
| 139 | (setf (gethash new source-notes) sn))) |
|---|
| 140 | |
|---|
| 141 | |
|---|
| 142 | (defvar *nx1-alphatizers* (make-hash-table :size 180 :test #'eq)) |
|---|
| 143 | |
|---|
| 144 | (let ((policy (%istruct 'compiler-policy |
|---|
| 145 | #'(lambda (env) |
|---|
| 146 | #+ccl-qres (< (debug-optimize-quantity env) 2) |
|---|
| 147 | #-ccl-qres (neq (debug-optimize-quantity env) 3)) ; allow-tail-recursion-elimination |
|---|
| 148 | #'(lambda (env) |
|---|
| 149 | (declare (ignorable env)) |
|---|
| 150 | #+ccl-qres nil |
|---|
| 151 | #-ccl-qres (eq (debug-optimize-quantity env) 3)) ; inhibit-register-allocation |
|---|
| 152 | #'(lambda (env) |
|---|
| 153 | (let* ((safety (safety-optimize-quantity env))) |
|---|
| 154 | (and (< safety 3) |
|---|
| 155 | (>= (speed-optimize-quantity env) |
|---|
| 156 | safety)))) ; trust-declarations |
|---|
| 157 | #'(lambda (env) |
|---|
| 158 | #+ccl-qres (> (speed-optimize-quantity env) |
|---|
| 159 | (space-optimize-quantity env)) |
|---|
| 160 | #-ccl-qres (>= (speed-optimize-quantity env) |
|---|
| 161 | (+ (space-optimize-quantity env) 2))) ; open-code-inline |
|---|
| 162 | #'(lambda (env) |
|---|
| 163 | (and (eq (speed-optimize-quantity env) 3) |
|---|
| 164 | (eq (safety-optimize-quantity env) 0))) ; inhibit-safety-checking |
|---|
| 165 | #'(lambda (env) |
|---|
| 166 | (let* ((safety (safety-optimize-quantity env))) |
|---|
| 167 | (or (eq safety 3) |
|---|
| 168 | (> safety (speed-optimize-quantity env))))) ;declarations-typecheck |
|---|
| 169 | #'(lambda (env) |
|---|
| 170 | (neq (debug-optimize-quantity env) 3)) ; inline-self-calls |
|---|
| 171 | #'(lambda (env) |
|---|
| 172 | (and (neq (compilation-speed-optimize-quantity env) 3) |
|---|
| 173 | (or (neq (speed-optimize-quantity env) 0) |
|---|
| 174 | (and (neq (safety-optimize-quantity env) 3) |
|---|
| 175 | (neq (debug-optimize-quantity env) 3))))) ; allow-transforms |
|---|
| 176 | #'(lambda (var env) ; force-boundp-checks |
|---|
| 177 | (declare (ignore var)) |
|---|
| 178 | (eq (safety-optimize-quantity env) 3)) |
|---|
| 179 | #'(lambda (var val env) ; allow-constant-substitution |
|---|
| 180 | (declare (ignore var val env)) |
|---|
| 181 | t) |
|---|
| 182 | nil ; extensions |
|---|
| 183 | ))) |
|---|
| 184 | (defun new-compiler-policy (&key (allow-tail-recursion-elimination nil atr-p) |
|---|
| 185 | (inhibit-register-allocation nil ira-p) |
|---|
| 186 | (trust-declarations nil td-p) |
|---|
| 187 | (open-code-inline nil oci-p) |
|---|
| 188 | (inhibit-safety-checking nil ischeck-p) |
|---|
| 189 | (inline-self-calls nil iscall-p) |
|---|
| 190 | (allow-transforms nil at-p) |
|---|
| 191 | (force-boundp-checks nil fb-p) |
|---|
| 192 | (allow-constant-substitution nil acs-p) |
|---|
| 193 | (declarations-typecheck nil dt-p)) |
|---|
| 194 | (let ((p (copy-uvector policy))) |
|---|
| 195 | (if atr-p (setf (policy.allow-tail-recursion-elimination p) allow-tail-recursion-elimination)) |
|---|
| 196 | (if ira-p (setf (policy.inhibit-register-allocation p) inhibit-register-allocation)) |
|---|
| 197 | (if td-p (setf (policy.trust-declarations p) trust-declarations)) |
|---|
| 198 | (if oci-p (setf (policy.open-code-inline p) open-code-inline)) |
|---|
| 199 | (if ischeck-p (setf (policy.inhibit-safety-checking p) inhibit-safety-checking)) |
|---|
| 200 | (if iscall-p (setf (policy.inline-self-calls p) inline-self-calls)) |
|---|
| 201 | (if at-p (setf (policy.allow-transforms p) allow-transforms)) |
|---|
| 202 | (if fb-p (setf (policy.force-boundp-checks p) force-boundp-checks)) |
|---|
| 203 | (if acs-p (setf (policy.allow-constant-substitution p) allow-constant-substitution)) |
|---|
| 204 | (if dt-p (setf (policy.declarations-typecheck p) declarations-typecheck)) |
|---|
| 205 | p)) |
|---|
| 206 | (defun %default-compiler-policy () policy)) |
|---|
| 207 | |
|---|
| 208 | (%include "ccl:compiler;lambda-list.lisp") |
|---|
| 209 | |
|---|
| 210 | ;Syntactic Environment Access. |
|---|
| 211 | |
|---|
| 212 | (defun declaration-information (decl-name &optional env) |
|---|
| 213 | (if (and env (not (istruct-typep env 'lexical-environment))) |
|---|
| 214 | (report-bad-arg env 'lexical-environment)) |
|---|
| 215 | ; *** This needs to deal with things defined with DEFINE-DECLARATION *** |
|---|
| 216 | (case decl-name |
|---|
| 217 | (optimize |
|---|
| 218 | (list |
|---|
| 219 | (list 'speed (speed-optimize-quantity env)) |
|---|
| 220 | (list 'safety (safety-optimize-quantity env)) |
|---|
| 221 | (list 'compilation-speed (compilation-speed-optimize-quantity env)) |
|---|
| 222 | (list 'space (space-optimize-quantity env)) |
|---|
| 223 | (list 'debug (debug-optimize-quantity env)))) |
|---|
| 224 | (declaration |
|---|
| 225 | *nx-known-declarations*))) |
|---|
| 226 | |
|---|
| 227 | (defun function-information (name &optional env &aux decls) |
|---|
| 228 | (let ((name (ensure-valid-function-name name))) |
|---|
| 229 | (if (and env (not (istruct-typep env 'lexical-environment))) |
|---|
| 230 | (report-bad-arg env 'lexical-environment)) |
|---|
| 231 | (if (special-operator-p name) |
|---|
| 232 | (values :special-form nil nil) |
|---|
| 233 | (flet ((process-new-fdecls (fdecls) |
|---|
| 234 | (dolist (fdecl fdecls) |
|---|
| 235 | (when (eq (car fdecl) name) |
|---|
| 236 | (let ((decl-type (cadr fdecl))) |
|---|
| 237 | (when (and (memq decl-type '(dynamic-extent inline ftype)) |
|---|
| 238 | (not (assq decl-type decls))) |
|---|
| 239 | (push (cdr fdecl) decls))))))) |
|---|
| 240 | (declare (dynamic-extent #'process-new-fdecls)) |
|---|
| 241 | (do* ((root t) |
|---|
| 242 | (contour env (when root (lexenv.parent-env contour)))) |
|---|
| 243 | ((null contour) |
|---|
| 244 | (if (macro-function name) |
|---|
| 245 | (values :macro nil nil) |
|---|
| 246 | (if (fboundp name) |
|---|
| 247 | (values :function |
|---|
| 248 | nil |
|---|
| 249 | (if (assq 'inline decls) |
|---|
| 250 | decls |
|---|
| 251 | (if (proclaimed-inline-p name) |
|---|
| 252 | (push '(inline . inline) decls) |
|---|
| 253 | (if (proclaimed-notinline-p name) |
|---|
| 254 | (push '(inline . notinline) decls))))) |
|---|
| 255 | (values nil nil decls)))) |
|---|
| 256 | (if (istruct-typep contour 'definition-environment) |
|---|
| 257 | (if (assq name (defenv.functions contour)) |
|---|
| 258 | (return (values :macro nil nil)) |
|---|
| 259 | (progn (setq root nil) (process-new-fdecls (defenv.fdecls contour)))) |
|---|
| 260 | (progn |
|---|
| 261 | (process-new-fdecls (lexenv.fdecls contour)) |
|---|
| 262 | (let ((found (assq name (lexenv.functions contour)))) |
|---|
| 263 | (when found |
|---|
| 264 | (return |
|---|
| 265 | (if (and (consp (cdr found))(eq (%cadr found) 'macro)) |
|---|
| 266 | (values :macro t nil) |
|---|
| 267 | (values :function t decls)))))))))))) |
|---|
| 268 | |
|---|
| 269 | (defun variable-information (var &optional env) |
|---|
| 270 | (setq var (require-type var 'symbol)) |
|---|
| 271 | (if (and env (not (istruct-typep env 'lexical-environment))) |
|---|
| 272 | (report-bad-arg env 'lexical-environment)) |
|---|
| 273 | (let* ((vartype nil) |
|---|
| 274 | (boundp nil) |
|---|
| 275 | (envtype nil) |
|---|
| 276 | (typedecls (nx-declared-type var env)) ; should grovel nested/shadowed special decls for us. |
|---|
| 277 | (decls (if (and typedecls (neq t typedecls)) (list (cons 'type typedecls))))) |
|---|
| 278 | (loop |
|---|
| 279 | (cond ((null env) |
|---|
| 280 | (if (constant-symbol-p var) |
|---|
| 281 | (setq vartype :constant decls nil) |
|---|
| 282 | (if (proclaimed-special-p var) |
|---|
| 283 | (setq vartype :special) |
|---|
| 284 | (let* ((not-a-symbol-macro (cons nil nil))) |
|---|
| 285 | (declare (dynamic-extent not-a-symbol-macro)) |
|---|
| 286 | (unless (eq (gethash var *symbol-macros* not-a-symbol-macro) |
|---|
| 287 | not-a-symbol-macro) |
|---|
| 288 | (setq vartype :symbol-macro))))) |
|---|
| 289 | (return)) |
|---|
| 290 | ((eq (setq envtype (istruct-type-name env)) 'definition-environment) |
|---|
| 291 | (cond ((assq var (defenv.constants env)) |
|---|
| 292 | (setq vartype :constant) |
|---|
| 293 | (return)) |
|---|
| 294 | ((assq var (defenv.symbol-macros env)) |
|---|
| 295 | (setq vartype :symbol-macro) |
|---|
| 296 | (return)) |
|---|
| 297 | ((assq var (defenv.specials env)) |
|---|
| 298 | (setq vartype :special) |
|---|
| 299 | (return)))) |
|---|
| 300 | (t |
|---|
| 301 | (dolist (vdecl (lexenv.vdecls env)) |
|---|
| 302 | (when (eq (car vdecl) var) |
|---|
| 303 | (let ((decltype (cadr vdecl))) |
|---|
| 304 | (unless (assq decltype decls) |
|---|
| 305 | (case decltype |
|---|
| 306 | (special (setq vartype :special)) |
|---|
| 307 | ((type dynamic-extent ignore) (push (cdr vdecl) decls))))))) |
|---|
| 308 | (let ((vars (lexenv.variables env))) |
|---|
| 309 | (unless (atom vars) |
|---|
| 310 | (dolist (v vars) |
|---|
| 311 | (when (eq (var-name v) var) |
|---|
| 312 | (setq boundp t) |
|---|
| 313 | (if (and (consp (var-ea v)) |
|---|
| 314 | (eq :symbol-macro (car (var-ea v)))) |
|---|
| 315 | (setq vartype :symbol-macro) |
|---|
| 316 | (unless vartype (setq vartype |
|---|
| 317 | (let* ((bits (var-bits v))) |
|---|
| 318 | (if (and (typep bits 'integer) |
|---|
| 319 | (logbitp $vbitspecial bits)) |
|---|
| 320 | :special |
|---|
| 321 | :lexical))))) |
|---|
| 322 | (return))) |
|---|
| 323 | (when vartype (return)))))) |
|---|
| 324 | (setq env (if (eq envtype 'lexical-environment) (lexenv.parent-env env)))) |
|---|
| 325 | (values vartype boundp decls))) |
|---|
| 326 | |
|---|
| 327 | (defun nx-target-type (typespec) |
|---|
| 328 | ;; Could do a lot more here |
|---|
| 329 | (if (or (eq *host-backend* *target-backend*) |
|---|
| 330 | (not (eq typespec 'fixnum))) |
|---|
| 331 | typespec |
|---|
| 332 | (target-word-size-case |
|---|
| 333 | (32 '(signed-byte 30)) |
|---|
| 334 | (64 '(signed-byte 61))))) |
|---|
| 335 | |
|---|
| 336 | ; Type declarations affect all references. |
|---|
| 337 | (defun nx-declared-type (sym &optional (env *nx-lexical-environment*)) |
|---|
| 338 | (loop |
|---|
| 339 | (when (or (null env) (istruct-typep env 'definition-environment)) (return)) |
|---|
| 340 | (dolist (decl (lexenv.vdecls env)) |
|---|
| 341 | (if (and (eq (car decl) sym) |
|---|
| 342 | (eq (cadr decl) 'type)) |
|---|
| 343 | (return-from nx-declared-type (nx-target-type (cddr decl))))) |
|---|
| 344 | (let ((vars (lexenv.variables env))) |
|---|
| 345 | (when (and (consp vars) |
|---|
| 346 | (dolist (var vars) |
|---|
| 347 | (when (eq (var-name var) sym) |
|---|
| 348 | (return t)))) |
|---|
| 349 | (return-from nx-declared-type t))) |
|---|
| 350 | (setq env (lexenv.parent-env env))) |
|---|
| 351 | (let ((decl (or (assq sym *nx-compile-time-types*) |
|---|
| 352 | (assq sym *nx-proclaimed-types*)))) |
|---|
| 353 | (if decl (%cdr decl) t))) |
|---|
| 354 | |
|---|
| 355 | (defun nx-declared-result-type (sym &optional (env *nx-lexical-environment*) args) |
|---|
| 356 | (when (symbolp (setq sym (maybe-setf-function-name sym))) |
|---|
| 357 | (let* ((ftype (find-ftype-decl sym env args)) |
|---|
| 358 | (ctype (and ftype (if (typep ftype 'ctype) ftype (specifier-type-if-known ftype env))))) |
|---|
| 359 | (unless (or (null ctype) |
|---|
| 360 | (not (function-ctype-p ctype)) |
|---|
| 361 | (eq *wild-type* (function-ctype-returns ctype))) |
|---|
| 362 | (let ((result-type (type-specifier (single-value-type (function-ctype-returns ctype))))) |
|---|
| 363 | (and (neq result-type 't) result-type)))))) |
|---|
| 364 | |
|---|
| 365 | (defmacro define-declaration (decl-name lambda-list &body body &environment env) |
|---|
| 366 | (multiple-value-bind (body decls) |
|---|
| 367 | (parse-body body env) |
|---|
| 368 | (let ((fn `(nfunction (define-declaration ,decl-name) |
|---|
| 369 | (lambda ,lambda-list |
|---|
| 370 | ,@decls |
|---|
| 371 | (block ,decl-name |
|---|
| 372 | ,@body))))) |
|---|
| 373 | `(progn |
|---|
| 374 | (proclaim '(declaration ,decl-name)) |
|---|
| 375 | (setf (getf *declaration-handlers* ',decl-name) ,fn))))) |
|---|
| 376 | |
|---|
| 377 | (defun check-environment-args (variable symbol-macro function macro) |
|---|
| 378 | (flet ((check-all-pairs (pairlist argname) |
|---|
| 379 | (dolist (pair pairlist) |
|---|
| 380 | (unless (and (consp pair) (consp (%cdr pair)) (null (%cddr pair)) (symbolp (%car pair))) |
|---|
| 381 | (signal-simple-program-error "Malformed ~s argument: ~s is not of the form (~S ~S) in ~S" |
|---|
| 382 | argname |
|---|
| 383 | pair |
|---|
| 384 | 'name |
|---|
| 385 | 'definition |
|---|
| 386 | pairlist)))) |
|---|
| 387 | (check-all-symbols (symlist argname pairs pairsname) |
|---|
| 388 | (dolist (v symlist) |
|---|
| 389 | (unless (symbolp v) |
|---|
| 390 | (signal-simple-program-error "Malformed ~S list: ~S is not a symbol in ~S." argname v symlist)) |
|---|
| 391 | (when (assq v pairs) |
|---|
| 392 | (signal-simple-program-error "~S ~S conflicts with ~S ~S" argname v pairsname (assq v pairs)))))) |
|---|
| 393 | (check-all-pairs symbol-macro :symbol-macro) |
|---|
| 394 | (check-all-pairs macro :macro) |
|---|
| 395 | (check-all-symbols variable :variable symbol-macro :symbol-macro) |
|---|
| 396 | (check-all-symbols function :function macro :macro))) |
|---|
| 397 | |
|---|
| 398 | |
|---|
| 399 | ;; This -isn't- PARSE-DECLARATIONS. It can't work; neither can this ... |
|---|
| 400 | (defun process-declarations (env decls symbol-macros) |
|---|
| 401 | (let ((vdecls nil) |
|---|
| 402 | (fdecls nil) |
|---|
| 403 | (mdecls nil)) |
|---|
| 404 | (flet ((add-type-decl (spec) |
|---|
| 405 | (destructuring-bind (typespec &rest vars) spec |
|---|
| 406 | (dolist (var vars) |
|---|
| 407 | (when (non-nil-symbol-p var) |
|---|
| 408 | (push (list* var |
|---|
| 409 | 'type |
|---|
| 410 | (let ((already (assq 'type (nth-value 2 (variable-information var env))))) |
|---|
| 411 | (if already |
|---|
| 412 | (let ((oldtype (%cdr already))) |
|---|
| 413 | (if oldtype |
|---|
| 414 | (if (subtypep oldtype typespec) |
|---|
| 415 | oldtype |
|---|
| 416 | (if (subtypep typespec oldtype) |
|---|
| 417 | typespec)))) |
|---|
| 418 | typespec))) |
|---|
| 419 | vdecls)))))) |
|---|
| 420 | ; do SPECIAL declarations first - this approximates the right thing, but doesn't quite make it. |
|---|
| 421 | (dolist (decl decls) |
|---|
| 422 | (when (eq (car decl) 'special) |
|---|
| 423 | (dolist (spec (%cdr decl)) |
|---|
| 424 | (when (non-nil-symbol-p spec) |
|---|
| 425 | (if (assq spec symbol-macros) |
|---|
| 426 | (signal-program-error "Special declaration cannot be applied to symbol-macro ~S" spec)) |
|---|
| 427 | (push (list* spec 'special t) vdecls))))) |
|---|
| 428 | (dolist (decl decls) |
|---|
| 429 | (let ((decltype (car decl))) |
|---|
| 430 | (case decltype |
|---|
| 431 | ((inline notinline) |
|---|
| 432 | (dolist (spec (%cdr decl)) |
|---|
| 433 | (let ((fname nil)) |
|---|
| 434 | (if (non-nil-symbol-p spec) |
|---|
| 435 | (setq fname spec) |
|---|
| 436 | (if (setf-function-name-p spec) |
|---|
| 437 | (setq fname (setf-function-name (cadr spec))))) |
|---|
| 438 | (if fname |
|---|
| 439 | (push (list* fname decltype t) fdecls))))) |
|---|
| 440 | (optimize |
|---|
| 441 | (dolist (spec (%cdr decl)) |
|---|
| 442 | (let ((val 3) |
|---|
| 443 | (quantity spec)) |
|---|
| 444 | (if (consp spec) |
|---|
| 445 | (setq quantity (car spec) val (cadr spec))) |
|---|
| 446 | (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed))) |
|---|
| 447 | (push (cons quantity val) mdecls))))) |
|---|
| 448 | (dynamic-extent |
|---|
| 449 | (dolist (spec (%cdr decl)) |
|---|
| 450 | (if (non-nil-symbol-p spec) |
|---|
| 451 | (push (list* spec decltype t) vdecls) |
|---|
| 452 | (if (and (consp spec) (eq (%car spec) 'function)) |
|---|
| 453 | (let ((fname (cadr spec))) |
|---|
| 454 | (if (not (non-nil-symbol-p fname)) |
|---|
| 455 | (setq fname |
|---|
| 456 | (if (setf-function-name-p fname) |
|---|
| 457 | (setf-function-name (cadr fname))))) |
|---|
| 458 | (if fname (push (list* fname decltype t) fdecls))))))) |
|---|
| 459 | (type (add-type-decl (cdr decl))) |
|---|
| 460 | (ftype (destructuring-bind (typespec &rest fnames) (%cdr decl) |
|---|
| 461 | (dolist (name fnames) |
|---|
| 462 | (let ((fname name)) |
|---|
| 463 | (if (not (non-nil-symbol-p fname)) |
|---|
| 464 | (setq fname |
|---|
| 465 | (if (setf-function-name-p fname) |
|---|
| 466 | (setf-function-name (cadr fname))))) |
|---|
| 467 | (if fname (push (list* fname decltype typespec) fdecls)))))) |
|---|
| 468 | (special) |
|---|
| 469 | (t |
|---|
| 470 | (if (memq decltype *cl-types*) |
|---|
| 471 | (add-type-decl decl) |
|---|
| 472 | (let ((handler (getf *declaration-handlers* decltype))) |
|---|
| 473 | (when handler |
|---|
| 474 | (multiple-value-bind (type info) (funcall handler decl) |
|---|
| 475 | (ecase type |
|---|
| 476 | (:variable |
|---|
| 477 | (dolist (v info) (push (apply #'list* v) vdecls))) |
|---|
| 478 | (:function |
|---|
| 479 | (dolist (f info) (push (apply #'list* f) fdecls))) |
|---|
| 480 | (:declare ;; N.B. CLtL/2 semantics |
|---|
| 481 | (push info mdecls))))))))))) |
|---|
| 482 | (setf (lexenv.vdecls env) (nconc vdecls (lexenv.vdecls env)) |
|---|
| 483 | (lexenv.fdecls env) (nconc fdecls (lexenv.fdecls env)) |
|---|
| 484 | (lexenv.mdecls env) (nconc mdecls (lexenv.mdecls env)))))) |
|---|
| 485 | |
|---|
| 486 | |
|---|
| 487 | (defun nx-cons-var (name &optional (bits 0)) |
|---|
| 488 | (%istruct 'var name bits nil nil nil nil 0 nil)) |
|---|
| 489 | |
|---|
| 490 | |
|---|
| 491 | (defun augment-environment (env &key variable symbol-macro function macro declare) |
|---|
| 492 | (if (and env (not (istruct-typep env 'lexical-environment))) |
|---|
| 493 | (report-bad-arg env 'lexical-environment)) |
|---|
| 494 | (check-environment-args variable symbol-macro function macro) |
|---|
| 495 | (let* ((vars (mapcar #'nx-cons-var variable)) |
|---|
| 496 | (symbol-macros (mapcar #'(lambda (s) |
|---|
| 497 | (let* ((sym (car s))) |
|---|
| 498 | (unless (and (symbolp sym) |
|---|
| 499 | (not (constantp sym env)) |
|---|
| 500 | (not (eq (variable-information sym env) :special))) |
|---|
| 501 | (signal-program-error "~S can't by bound as a SYMBOL-MACRO" sym)) |
|---|
| 502 | (let ((v (nx-cons-var (car s)))) |
|---|
| 503 | (setf (var-expansion v) (cons :symbol-macro (cadr s))) |
|---|
| 504 | v))) |
|---|
| 505 | symbol-macro)) |
|---|
| 506 | (macros (mapcar #'(lambda (m) (list* (car m) 'macro (cadr m))) macro)) |
|---|
| 507 | (functions (mapcar #'(lambda (f) (list* f 'function nil)) function)) |
|---|
| 508 | (new-env (new-lexical-environment env))) |
|---|
| 509 | (setf (lexenv.variables new-env) (nconc vars symbol-macros) |
|---|
| 510 | (lexenv.functions new-env) (nconc functions macros)) |
|---|
| 511 | (process-declarations new-env declare symbol-macro) |
|---|
| 512 | new-env)) |
|---|
| 513 | |
|---|
| 514 | (defun enclose (lambda-expression &optional env) |
|---|
| 515 | (if (and env (not (istruct-typep env 'lexical-environment))) |
|---|
| 516 | (report-bad-arg env 'lexical-environment)) |
|---|
| 517 | (unless (lambda-expression-p lambda-expression) |
|---|
| 518 | (error "Invalid lambda-expression ~S." lambda-expression)) |
|---|
| 519 | (%make-function nil lambda-expression env)) |
|---|
| 520 | |
|---|
| 521 | #|| Might be nicer to do %declaim |
|---|
| 522 | (defmacro declaim (&rest decl-specs &environment env) |
|---|
| 523 | `(progn |
|---|
| 524 | (eval-when (:load-toplevel :execute) |
|---|
| 525 | (proclaim ',@decl-specs)) |
|---|
| 526 | (eval-when (:compile-toplevel) |
|---|
| 527 | (%declaim ',@decl-specs ,env)))) |
|---|
| 528 | ||# |
|---|
| 529 | |
|---|
| 530 | (defmacro declaim (&environment env &rest decl-specs) |
|---|
| 531 | "DECLAIM Declaration* |
|---|
| 532 | Do a declaration or declarations for the global environment." |
|---|
| 533 | (let* ((body (mapcar #'(lambda (spec) `(proclaim ',spec)) decl-specs))) |
|---|
| 534 | `(progn |
|---|
| 535 | (eval-when (:compile-toplevel) |
|---|
| 536 | (compile-time-proclamation ',decl-specs ,env)) |
|---|
| 537 | (eval-when (:load-toplevel :execute) |
|---|
| 538 | ,@body)))) |
|---|
| 539 | |
|---|
| 540 | (defvar *strict-checking* nil |
|---|
| 541 | "If true, issues warnings/errors in more cases, e.g. for valid but non-portable code") |
|---|
| 542 | |
|---|
| 543 | |
|---|
| 544 | ;; Should be true if compiler warnings UI doesn't use source locations, false if it does. |
|---|
| 545 | (defvar *merge-compiler-warnings* t "If false, don't merge compiler warnings with different source locations") |
|---|
| 546 | |
|---|
| 547 | ;;; If warnings have more than a single entry on their |
|---|
| 548 | ;;; args slot, don't merge them. |
|---|
| 549 | (defun merge-compiler-warnings (old-warnings) |
|---|
| 550 | (let ((warnings nil)) |
|---|
| 551 | (dolist (w old-warnings) |
|---|
| 552 | (let* ((w-args (compiler-warning-args w))) |
|---|
| 553 | (if |
|---|
| 554 | (or (cdr w-args) |
|---|
| 555 | ;; See if W can be merged into an existing warning |
|---|
| 556 | (dolist (w1 warnings t) |
|---|
| 557 | (let ((w1-args (compiler-warning-args w1))) |
|---|
| 558 | (when (and (eq (compiler-warning-warning-type w) |
|---|
| 559 | (compiler-warning-warning-type w1)) |
|---|
| 560 | w1-args |
|---|
| 561 | (null (cdr w1-args)) |
|---|
| 562 | (eq (%car w-args) |
|---|
| 563 | (%car w1-args)) |
|---|
| 564 | (or *merge-compiler-warnings* |
|---|
| 565 | (eq (compiler-warning-source-note w) |
|---|
| 566 | (compiler-warning-source-note w1)))) |
|---|
| 567 | (let ((nrefs (compiler-warning-nrefs w1))) |
|---|
| 568 | (setf (compiler-warning-nrefs w1) |
|---|
| 569 | (cons (compiler-warning-source-note w) |
|---|
| 570 | (or nrefs |
|---|
| 571 | (list (compiler-warning-source-note w1))))) |
|---|
| 572 | (return nil)))))) |
|---|
| 573 | (push w warnings)))) |
|---|
| 574 | warnings)) |
|---|
| 575 | |
|---|
| 576 | ;;; This is called by, e.g., note-function-info & so can't be -too- funky ... |
|---|
| 577 | ;;; don't call proclaimed-inline-p or proclaimed-notinline-p with alphatized crap |
|---|
| 578 | |
|---|
| 579 | (defun nx-declared-inline-p (sym env) |
|---|
| 580 | (setq sym (maybe-setf-function-name sym)) |
|---|
| 581 | (loop |
|---|
| 582 | (when (listp env) |
|---|
| 583 | (return (and (symbolp sym) |
|---|
| 584 | (proclaimed-inline-p sym)))) |
|---|
| 585 | (dolist (decl (lexenv.fdecls env)) |
|---|
| 586 | (when (and (eq (car decl) sym) |
|---|
| 587 | (eq (cadr decl) 'inline)) |
|---|
| 588 | (return-from nx-declared-inline-p (eq (cddr decl) 'inline)))) |
|---|
| 589 | (setq env (lexenv.parent-env env)))) |
|---|
| 590 | |
|---|
| 591 | (defun report-compile-time-argument-mismatch (condition stream &aux (type (compiler-warning-warning-type condition))) |
|---|
| 592 | (destructuring-bind (callee reason args spread-p) |
|---|
| 593 | (compiler-warning-args condition) |
|---|
| 594 | (format stream "In the ~a ~s with arguments ~:s,~% " |
|---|
| 595 | (if spread-p "application of" "call to") |
|---|
| 596 | callee |
|---|
| 597 | args) |
|---|
| 598 | (ecase (car reason) |
|---|
| 599 | (:toomany |
|---|
| 600 | (destructuring-bind (provided max) |
|---|
| 601 | (cdr reason) |
|---|
| 602 | (format stream "~d argument~:p ~:*~[were~;was~:;were~] provided, but at most ~d ~:*~[are~;is~:;are~] accepted~& by " provided max))) |
|---|
| 603 | (:toofew |
|---|
| 604 | (destructuring-bind (provided min) |
|---|
| 605 | (cdr reason) |
|---|
| 606 | (format stream "~d argument~:p ~:*~[were~;was~:;were~] provided, but at least ~d ~:*~[are~;is~:;are~] required~& by " provided min))) |
|---|
| 607 | (:odd-keywords |
|---|
| 608 | (let* ((tail (cadr reason))) |
|---|
| 609 | (format stream "the variable portion of the argument list ~s contains an odd number~& of arguments and so can't be used to initialize keyword parameters~& for " tail))) |
|---|
| 610 | (:unknown-keyword |
|---|
| 611 | (destructuring-bind (badguy goodguys) |
|---|
| 612 | (cdr reason) |
|---|
| 613 | (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~:s, which are recognized by " |
|---|
| 614 | (consp badguy) badguy goodguys))) |
|---|
| 615 | (:unknown-gf-keywords |
|---|
| 616 | (let ((badguys (cadr reason))) |
|---|
| 617 | (when (and (consp badguys) (null (%cdr badguys))) (setq badguys (car badguys))) |
|---|
| 618 | (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not recognized by " |
|---|
| 619 | |
|---|
| 620 | (consp badguys) badguys)))) |
|---|
| 621 | (format stream |
|---|
| 622 | (ecase type |
|---|
| 623 | (:ftype-mismatch "the FTYPE declaration of ~s") |
|---|
| 624 | (:global-mismatch "the current global definition of ~s") |
|---|
| 625 | (:environment-mismatch "the definition of ~s visible in the current compilation unit.") |
|---|
| 626 | (:lexical-mismatch "the lexically visible definition of ~s") |
|---|
| 627 | ;; This can happen when compiling without compilation unit: |
|---|
| 628 | (:deferred-mismatch "~s")) |
|---|
| 629 | callee))) |
|---|
| 630 | |
|---|
| 631 | (defparameter *compiler-warning-formats* |
|---|
| 632 | '((:special . "Undeclared free variable ~S") |
|---|
| 633 | (:unused . "Unused lexical variable ~S") |
|---|
| 634 | (:ignore . "Variable ~S not ignored.") |
|---|
| 635 | (:undefined-function . "Undefined function ~S") ;; (deferred) |
|---|
| 636 | (:undefined-type . "Undefined type ~S") ;; (deferred) |
|---|
| 637 | (:unknown-type-in-declaration . "Unknown or invalid type ~S, declaration ignored") |
|---|
| 638 | (:bad-declaration . "Unknown or invalid declaration ~S") |
|---|
| 639 | (:invalid-type . report-invalid-type-compiler-warning) |
|---|
| 640 | (:unknown-declaration-variable . "~s declaration for unknown variable ~s") |
|---|
| 641 | (:unknown-declaration-function . "~s declaration for unknown function ~s") |
|---|
| 642 | (:macro-used-before-definition . "Macro function ~S was used before it was defined.") |
|---|
| 643 | (:unsettable . "Shouldn't assign to variable ~S") |
|---|
| 644 | (:global-mismatch . report-compile-time-argument-mismatch) |
|---|
| 645 | (:environment-mismatch . report-compile-time-argument-mismatch) |
|---|
| 646 | (:lexical-mismatch . report-compile-time-argument-mismatch) |
|---|
| 647 | (:ftype-mismatch . report-compile-time-argument-mismatch) |
|---|
| 648 | (:deferred-mismatch . report-compile-time-argument-mismatch) |
|---|
| 649 | (:type . "Type declarations violated in ~S") |
|---|
| 650 | (:type-conflict . "Conflicting type declarations for ~S") |
|---|
| 651 | (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.") |
|---|
| 652 | (:lambda . "Suspicious lambda-list: ~s") |
|---|
| 653 | (:incongruent-gf-lambda-list . "Lambda list of generic function ~s is incongruent with previously defined methods") |
|---|
| 654 | (:incongruent-method-lambda-list . "Lambda list of ~s is incongruent with previous definition of ~s") |
|---|
| 655 | (:gf-keys-not-accepted . "~s does not accept keywords ~s required by the generic functions") |
|---|
| 656 | (:result-ignored . "Function result ignored in call to ~s") |
|---|
| 657 | (:duplicate-definition . report-compile-time-duplicate-definition) |
|---|
| 658 | (:format-error . "~:{~@?~%~}") |
|---|
| 659 | (:program-error . "~a") |
|---|
| 660 | (:unsure . "Nonspecific warning"))) |
|---|
| 661 | |
|---|
| 662 | (defun report-invalid-type-compiler-warning (condition stream) |
|---|
| 663 | (destructuring-bind (type &optional why) (compiler-warning-args condition) |
|---|
| 664 | (when (typep why 'invalid-type-specifier) |
|---|
| 665 | (setq type (invalid-type-specifier-typespec why) why nil)) |
|---|
| 666 | (format stream "Invalid type specifier ~S~@[: ~A~]" type why))) |
|---|
| 667 | |
|---|
| 668 | (defun report-compile-time-duplicate-definition (condition stream) |
|---|
| 669 | (destructuring-bind (name old-file new-file &optional from to) (compiler-warning-args condition) |
|---|
| 670 | (format stream |
|---|
| 671 | "Duplicate definitions of ~s~:[~*~;~:* (as a ~a and a ~a)~]~:[~;, in this file~:[~; and in ~s~]~]" |
|---|
| 672 | (maybe-setf-name name) from to |
|---|
| 673 | (and old-file new-file) |
|---|
| 674 | (neq old-file new-file) |
|---|
| 675 | old-file))) |
|---|
| 676 | |
|---|
| 677 | (defun adjust-compiler-warning-args (warning-type args) |
|---|
| 678 | (case warning-type |
|---|
| 679 | ((:undefined-function :result-ignored) (mapcar #'maybe-setf-name args)) |
|---|
| 680 | (t args))) |
|---|
| 681 | |
|---|
| 682 | |
|---|
| 683 | (defun report-compiler-warning (condition stream &key short) |
|---|
| 684 | (let* ((warning-type (compiler-warning-warning-type condition)) |
|---|
| 685 | (format-string (cdr (assq warning-type *compiler-warning-formats*))) |
|---|
| 686 | (warning-args (compiler-warning-args condition))) |
|---|
| 687 | (unless short |
|---|
| 688 | (let ((name (reverse (compiler-warning-function-name condition)))) |
|---|
| 689 | (format stream "In ") |
|---|
| 690 | (print-nested-name name stream) |
|---|
| 691 | (when (every #'null name) |
|---|
| 692 | (let ((position (source-note-start-pos (compiler-warning-source-note condition)))) |
|---|
| 693 | (when position (format stream " at position ~s" position)))) |
|---|
| 694 | (format stream ": "))) |
|---|
| 695 | (if (typep format-string 'string) |
|---|
| 696 | (apply #'format stream format-string (adjust-compiler-warning-args warning-type warning-args)) |
|---|
| 697 | (if (null format-string) |
|---|
| 698 | (format stream "~A: ~S" warning-type warning-args) |
|---|
| 699 | (funcall format-string condition stream))) |
|---|
| 700 | ;(format stream ".") |
|---|
| 701 | (let ((nrefs (compiler-warning-nrefs condition))) |
|---|
| 702 | (when nrefs |
|---|
| 703 | (format stream " (~D references)" (length nrefs)))))) |
|---|
| 704 | |
|---|
| 705 | (defun environment-structref-info (name env) |
|---|
| 706 | (let ((defenv (definition-environment env))) |
|---|
| 707 | (when defenv |
|---|
| 708 | (cdr (assq name (defenv.structrefs defenv)))))) |
|---|
| 709 | |
|---|
| 710 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 711 | ;; |
|---|
| 712 | ;; For code coverage, pretty-print acode to string and store position info in code notes. |
|---|
| 713 | ;; |
|---|
| 714 | ;; decomp-acode can also be used separately for debugging. |
|---|
| 715 | ;; |
|---|
| 716 | (defmacro dbg-assert (form) |
|---|
| 717 | #+debug-code-notes `(assert ,form)) |
|---|
| 718 | |
|---|
| 719 | (defvar *acode-right-margin* 120) |
|---|
| 720 | (defvar *nx-pprint-stream* nil) |
|---|
| 721 | (defvar *nx-acode-inner-refs* :default) |
|---|
| 722 | (defvar *nx-acode-refs-counter* 0) |
|---|
| 723 | |
|---|
| 724 | (defun nx-pprinting-p (stream) |
|---|
| 725 | (and *nx-pprint-stream* |
|---|
| 726 | (typep stream 'xp-stream) |
|---|
| 727 | (slot-value stream 'xp-structure) |
|---|
| 728 | (eq *nx-pprint-stream* (xp-base-stream (slot-value stream 'xp-structure))))) |
|---|
| 729 | |
|---|
| 730 | (defstruct acode-ref |
|---|
| 731 | object) |
|---|
| 732 | |
|---|
| 733 | (defstruct (acode-afunc-ref (:include acode-ref)) |
|---|
| 734 | afunc |
|---|
| 735 | index) |
|---|
| 736 | |
|---|
| 737 | (defun nx-record-code-coverage-acode (afunc) |
|---|
| 738 | (assert *nx-current-code-note*) |
|---|
| 739 | (let* ((form->note (make-hash-table :test #'eq)) |
|---|
| 740 | (*nx-acode-inner-refs* nil) |
|---|
| 741 | (*nx-acode-refs-counter* 0) |
|---|
| 742 | (form (decomp-acode (afunc-acode afunc) |
|---|
| 743 | :prettify t |
|---|
| 744 | :hook (lambda (acode form &aux (note (acode-note acode))) |
|---|
| 745 | ;; For expressions within without-compiling-code-coverage, there is a source |
|---|
| 746 | ;; note and not a code note, so need to check for code note explicitly. |
|---|
| 747 | (when (code-note-p note) |
|---|
| 748 | (dbg-assert (null (gethash form form->note))) |
|---|
| 749 | (dbg-assert (null (code-note-acode-range note))) |
|---|
| 750 | (setf (gethash form form->note) note))))) |
|---|
| 751 | (package *package*) |
|---|
| 752 | (string (with-standard-io-syntax |
|---|
| 753 | (with-output-to-string (*nx-pprint-stream*) |
|---|
| 754 | (let* ((*package* package) |
|---|
| 755 | (*print-right-margin* *acode-right-margin*) |
|---|
| 756 | (*print-case* :downcase) |
|---|
| 757 | (*print-readably* nil)) |
|---|
| 758 | (pprint-recording-positions |
|---|
| 759 | form *nx-pprint-stream* |
|---|
| 760 | (lambda (form open-p pos) |
|---|
| 761 | (let* ((note (gethash form form->note)) |
|---|
| 762 | (range (and note (code-note-acode-range note)))) |
|---|
| 763 | (when note |
|---|
| 764 | (cond (open-p |
|---|
| 765 | (dbg-assert (null range)) |
|---|
| 766 | (setf (code-note-acode-range note) |
|---|
| 767 | (encode-file-range pos pos))) |
|---|
| 768 | (t |
|---|
| 769 | (dbg-assert (not (null range))) |
|---|
| 770 | (multiple-value-bind (start end) |
|---|
| 771 | (decode-file-range range) |
|---|
| 772 | (declare (ignorable end)) |
|---|
| 773 | (dbg-assert (eq start end)) |
|---|
| 774 | (setf (code-note-acode-range note) |
|---|
| 775 | (encode-file-range start pos)))))))))))))) |
|---|
| 776 | (iterate store ((afunc afunc)) |
|---|
| 777 | (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string) |
|---|
| 778 | (loop for inner in (afunc-inner-functions afunc) |
|---|
| 779 | unless (getf (afunc-lfun-info inner) '%function-acode-string) |
|---|
| 780 | do (store inner))) |
|---|
| 781 | afunc)) |
|---|
| 782 | |
|---|
| 783 | (defmethod print-object ((ref acode-afunc-ref) stream) |
|---|
| 784 | (if (nx-pprinting-p stream) |
|---|
| 785 | (let ((index (acode-afunc-ref-index ref))) |
|---|
| 786 | (when index ;; referenced multiple times. |
|---|
| 787 | (if (eql index 0) ;; never referenced before? |
|---|
| 788 | (format stream "#~d=" |
|---|
| 789 | (setf (acode-afunc-ref-index ref) (incf *nx-acode-refs-counter*))) |
|---|
| 790 | ;; If not first reference, just point back. |
|---|
| 791 | (return-from print-object (format stream "#~d#" index)))) |
|---|
| 792 | (write-1 (acode-afunc-ref-object ref) stream)) |
|---|
| 793 | (call-next-method))) |
|---|
| 794 | |
|---|
| 795 | (defmethod print-object ((ref acode-ref) stream) |
|---|
| 796 | (if (nx-pprinting-p stream) |
|---|
| 797 | (write-1 (acode-ref-object ref) stream) |
|---|
| 798 | (call-next-method))) |
|---|
| 799 | |
|---|
| 800 | (defun decomp-ref (obj) |
|---|
| 801 | (if (and (listp *nx-acode-inner-refs*) ;; code coverage case |
|---|
| 802 | (not (acode-p obj))) |
|---|
| 803 | (make-acode-ref :object obj) |
|---|
| 804 | obj)) |
|---|
| 805 | |
|---|
| 806 | (defvar *decomp-prettify* nil "If true, loses info but results in more recognizable lisp") |
|---|
| 807 | |
|---|
| 808 | (defvar *decomp-hook* nil) |
|---|
| 809 | |
|---|
| 810 | (defun decomp-acode (acode &key (hook *decomp-hook*) (prettify *decomp-prettify*)) |
|---|
| 811 | (let ((*decomp-hook* hook) |
|---|
| 812 | (*decomp-prettify* prettify)) |
|---|
| 813 | (decomp-form acode))) |
|---|
| 814 | |
|---|
| 815 | (defun decomp-form (acode) |
|---|
| 816 | (cond ((eq acode *nx-t*) t) |
|---|
| 817 | ((eq acode *nx-nil*) nil) |
|---|
| 818 | (t (let* ((op (car acode)) |
|---|
| 819 | (num (length *next-nx-operators*)) |
|---|
| 820 | (name (when (and (fixnump op) |
|---|
| 821 | (<= 0 op) |
|---|
| 822 | (setq op (logand op operator-id-mask)) |
|---|
| 823 | (< op num)) |
|---|
| 824 | (car (nth (- num op 1) *next-nx-operators*)))) |
|---|
| 825 | (new (decomp-using-name (or name op) (cdr acode)))) |
|---|
| 826 | (when *decomp-hook* |
|---|
| 827 | (funcall *decomp-hook* acode new)) |
|---|
| 828 | new)))) |
|---|
| 829 | |
|---|
| 830 | |
|---|
| 831 | (defun decomp-afunc (afunc) |
|---|
| 832 | (setq afunc (require-type afunc 'afunc)) |
|---|
| 833 | (dbg-assert (afunc-acode afunc)) |
|---|
| 834 | (if (listp *nx-acode-inner-refs*) ;; code coverage case |
|---|
| 835 | (let ((ref (find afunc *nx-acode-inner-refs* :key #'acode-afunc-ref-afunc))) |
|---|
| 836 | (if ref ;; seen before, mark that multiply referenced. |
|---|
| 837 | (setf (acode-afunc-ref-index ref) 0) |
|---|
| 838 | (push (setq ref (make-acode-afunc-ref :afunc afunc |
|---|
| 839 | :object (decomp-form (afunc-acode afunc)))) |
|---|
| 840 | *nx-acode-inner-refs*)) |
|---|
| 841 | ref) |
|---|
| 842 | afunc)) |
|---|
| 843 | |
|---|
| 844 | (defun decomp-var (var) |
|---|
| 845 | (decomp-ref (var-name (require-type var 'var)))) |
|---|
| 846 | |
|---|
| 847 | (defun decomp-formlist (formlist) |
|---|
| 848 | (mapcar #'decomp-form formlist)) |
|---|
| 849 | |
|---|
| 850 | (defun decomp-arglist (arglist) |
|---|
| 851 | (destructuring-bind (stack-forms register-forms) arglist |
|---|
| 852 | (nconc (decomp-formlist stack-forms) |
|---|
| 853 | (nreverse (decomp-formlist register-forms))))) |
|---|
| 854 | |
|---|
| 855 | (defun decomp-lambda-list (req opt rest keys auxen &optional whole) |
|---|
| 856 | (flet ((decomp-arg (var) |
|---|
| 857 | (if (acode-p var) |
|---|
| 858 | (destructuring-bind (op whole req opt rest keys auxen) var |
|---|
| 859 | (assert (eq op (%nx1-operator lambda-list))) ;; fake |
|---|
| 860 | (decomp-lambda-list req opt rest keys auxen whole)) |
|---|
| 861 | (decomp-var var)))) |
|---|
| 862 | (let ((whole (and whole (list '&whole (decomp-arg whole)))) |
|---|
| 863 | (reqs (mapcar #'decomp-arg req)) |
|---|
| 864 | (opts (when opt (cons '&optional (apply #'mapcar |
|---|
| 865 | (lambda (var init supp) |
|---|
| 866 | (if (and (not supp) (eq init *nx-nil*)) |
|---|
| 867 | (decomp-arg var) |
|---|
| 868 | (list* (decomp-arg var) |
|---|
| 869 | (decomp-form init) |
|---|
| 870 | (and supp (list (decomp-arg supp)))))) |
|---|
| 871 | opt)))) |
|---|
| 872 | (rest (when rest (list '&rest (decomp-arg rest)))) |
|---|
| 873 | (keys (when keys |
|---|
| 874 | (destructuring-bind (aok vars supps inits keyvect) keys |
|---|
| 875 | (nconc |
|---|
| 876 | (when vars |
|---|
| 877 | (cons '&key (map 'list (lambda (var supp init key) |
|---|
| 878 | (let* ((sym (decomp-arg var)) |
|---|
| 879 | (arg (if (and (symbolp sym) (eq (make-keyword sym) key)) |
|---|
| 880 | sym |
|---|
| 881 | (list key sym)))) |
|---|
| 882 | (if (and (not supp) (eq init *nx-nil*) (eq arg sym)) |
|---|
| 883 | sym |
|---|
| 884 | (list* arg |
|---|
| 885 | (decomp-form init) |
|---|
| 886 | (and supp (list (decomp-arg supp))))))) |
|---|
| 887 | vars supps inits keyvect))) |
|---|
| 888 | (when aok (list '&allow-other-keys)))))) |
|---|
| 889 | (auxen (when (car auxen) |
|---|
| 890 | (cons '&aux (apply #'mapcar |
|---|
| 891 | (lambda (var init) |
|---|
| 892 | (if (eq init *nx-nil*) |
|---|
| 893 | (decomp-arg var) |
|---|
| 894 | (list (decomp-arg var) (decomp-form init)))) |
|---|
| 895 | auxen))))) |
|---|
| 896 | (nconc whole reqs opts rest keys auxen)))) |
|---|
| 897 | |
|---|
| 898 | (defmacro defdecomp (names arglist &body body) |
|---|
| 899 | (let ((op-var (car arglist)) |
|---|
| 900 | (args-vars (cdr arglist)) |
|---|
| 901 | (op-decls nil) |
|---|
| 902 | (args-var (gensym))) |
|---|
| 903 | (multiple-value-bind (body decls) (parse-body body nil) |
|---|
| 904 | ;; Kludge but good enuff for here |
|---|
| 905 | (setq decls (loop for decl in decls |
|---|
| 906 | collect (cons (car decl) |
|---|
| 907 | (loop for exp in (cdr decl) |
|---|
| 908 | do (when (and (consp exp) (member op-var (cdr exp))) |
|---|
| 909 | (push (list (car exp) op-var) op-decls)) |
|---|
| 910 | collect (cons (car exp) (remove op-var (cdr exp))))))) |
|---|
| 911 | `(progn |
|---|
| 912 | ,@(loop for name in (if (atom names) (list names) names) |
|---|
| 913 | collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,args-var) |
|---|
| 914 | (declare ,@op-decls) |
|---|
| 915 | (destructuring-bind ,args-vars ,args-var |
|---|
| 916 | ,@decls |
|---|
| 917 | ,@body))))))) |
|---|
| 918 | |
|---|
| 919 | ;; Default method |
|---|
| 920 | (defmethod decomp-using-name (op forms) |
|---|
| 921 | `(,op ,@(decomp-formlist forms))) |
|---|
| 922 | |
|---|
| 923 | ;; not real op, kludge generated below for lambda-bind |
|---|
| 924 | (defdecomp keyref (op index) |
|---|
| 925 | `(,op ,index)) |
|---|
| 926 | |
|---|
| 927 | (defdecomp immediate (op imm) |
|---|
| 928 | (when *decomp-prettify* |
|---|
| 929 | (setq op 'quote)) |
|---|
| 930 | `(,op ,imm)) |
|---|
| 931 | |
|---|
| 932 | (defdecomp fixnum (op raw-fixnum) |
|---|
| 933 | (declare (ignore op)) |
|---|
| 934 | (decomp-ref raw-fixnum)) |
|---|
| 935 | |
|---|
| 936 | (defdecomp %function (op symbol) |
|---|
| 937 | (when *decomp-prettify* |
|---|
| 938 | (setq op 'function)) |
|---|
| 939 | `(,op ,symbol)) |
|---|
| 940 | |
|---|
| 941 | (defdecomp simple-function (op afunc) |
|---|
| 942 | (when *decomp-prettify* |
|---|
| 943 | (setq op 'function)) |
|---|
| 944 | `(,op ,(decomp-afunc afunc))) |
|---|
| 945 | |
|---|
| 946 | (defdecomp closed-function (op afunc) |
|---|
| 947 | (when *decomp-prettify* |
|---|
| 948 | (setq op 'function)) |
|---|
| 949 | `(,op ,(decomp-afunc afunc))) |
|---|
| 950 | |
|---|
| 951 | (defdecomp (progn prog1 multiple-value-prog1 or list %temp-list values) (op form-list) |
|---|
| 952 | `(,op ,@(decomp-formlist form-list))) |
|---|
| 953 | |
|---|
| 954 | (defdecomp multiple-value-call (op fn form-list) |
|---|
| 955 | `(,op ,(decomp-form fn) ,@(decomp-formlist form-list))) |
|---|
| 956 | |
|---|
| 957 | (defdecomp vector (op formlist) |
|---|
| 958 | `(,op ,@(decomp-formlist formlist))) |
|---|
| 959 | |
|---|
| 960 | (defdecomp (%gvector list* %err-disp) (op arglist) |
|---|
| 961 | `(,op ,@(decomp-arglist arglist))) |
|---|
| 962 | |
|---|
| 963 | (defdecomp (i386-syscall syscall eabi-syscall poweropen-syscall |
|---|
| 964 | i386-ff-call ff-call eabi-ff-call poweropen-ff-call) |
|---|
| 965 | (op target argspecs argvals resultspec &rest rest) |
|---|
| 966 | `(,op |
|---|
| 967 | ,(decomp-form target) |
|---|
| 968 | ,@(mapcan (lambda (spec val) (list spec (decomp-form val))) argspecs argvals) |
|---|
| 969 | ,resultspec |
|---|
| 970 | ,@rest)) |
|---|
| 971 | |
|---|
| 972 | (defdecomp (consp characterp istruct-typep %ptr-eql int>0-p %izerop endp eq %ilogbitp %base-char-p not neq) (op cc &rest forms) |
|---|
| 973 | (if (eq (acode-immediate-operand cc) :eq) |
|---|
| 974 | `(,op ,@(decomp-formlist forms)) |
|---|
| 975 | `(,op ,(decomp-form cc) ,@(decomp-formlist forms)))) |
|---|
| 976 | |
|---|
| 977 | (defdecomp (typed-form type-asserted-form) (op typespec form &optional check-p) |
|---|
| 978 | `(,op ',typespec ,(decomp-form form) ,@(and check-p (list check-p)))) |
|---|
| 979 | |
|---|
| 980 | (defdecomp (%i+ %i-) (op form1 form2 &optional overflow-p) |
|---|
| 981 | `(,op ,(decomp-form form1) ,(decomp-form form2) ,overflow-p)) |
|---|
| 982 | |
|---|
| 983 | (defdecomp (immediate-get-xxx %immediate-set-xxx) (op bits &rest forms) |
|---|
| 984 | `(,op ,bits ,@(decomp-formlist forms))) |
|---|
| 985 | |
|---|
| 986 | (defdecomp call (op fn arglist &optional spread-p) |
|---|
| 987 | (setq op (if spread-p 'apply 'funcall)) |
|---|
| 988 | `(,op ,(decomp-form fn) ,@(decomp-arglist arglist))) |
|---|
| 989 | |
|---|
| 990 | (defdecomp lexical-function-call (op afunc arglist &optional spread-p) |
|---|
| 991 | (setq op (if *decomp-prettify* |
|---|
| 992 | (if spread-p 'apply 'funcall) |
|---|
| 993 | (if spread-p 'lexical-apply 'lexical-funcall))) |
|---|
| 994 | `(,op ,(decomp-afunc afunc) ,@(decomp-arglist arglist))) |
|---|
| 995 | |
|---|
| 996 | (defdecomp self-call (op arglist &optional spread-p) |
|---|
| 997 | (declare (Ignore op)) |
|---|
| 998 | `(,(if spread-p 'self-apply 'self-funcall) ,@(decomp-arglist arglist))) |
|---|
| 999 | |
|---|
| 1000 | (defdecomp (free-reference special-ref bound-special-ref global-ref) (op symbol) |
|---|
| 1001 | (if *decomp-prettify* |
|---|
| 1002 | (decomp-ref symbol) |
|---|
| 1003 | `(,op ,symbol))) |
|---|
| 1004 | |
|---|
| 1005 | (defdecomp (setq-special setq-free global-setq) (op symbol form) |
|---|
| 1006 | (when *decomp-prettify* |
|---|
| 1007 | (setq op 'setq)) |
|---|
| 1008 | `(,op ,symbol ,(decomp-form form))) |
|---|
| 1009 | |
|---|
| 1010 | (defdecomp inherited-arg (op var) |
|---|
| 1011 | `(,op ,(decomp-var var))) |
|---|
| 1012 | |
|---|
| 1013 | (defdecomp lexical-reference (op var) |
|---|
| 1014 | (if *decomp-prettify* |
|---|
| 1015 | (decomp-var var) |
|---|
| 1016 | `(,op ,(decomp-var var)))) |
|---|
| 1017 | |
|---|
| 1018 | (defdecomp setq-lexical (op var form) |
|---|
| 1019 | (when *decomp-prettify* |
|---|
| 1020 | (setq op 'setq)) |
|---|
| 1021 | `(,op ,(decomp-var var) ,(decomp-form form))) |
|---|
| 1022 | |
|---|
| 1023 | (defdecomp (let let* with-downward-closures) (op vars vals body p2decls) |
|---|
| 1024 | (declare (ignore p2decls)) |
|---|
| 1025 | `(,op ,(mapcar (lambda (var val) (list (decomp-var var) (decomp-form val))) vars vals) |
|---|
| 1026 | ,(decomp-form body))) |
|---|
| 1027 | |
|---|
| 1028 | (defdecomp %decls-body (op form p2decls) |
|---|
| 1029 | (declare (ignore p2decls)) |
|---|
| 1030 | `(,op ,(decomp-form form))) |
|---|
| 1031 | |
|---|
| 1032 | (defdecomp multiple-value-bind (op vars form body p2decls) |
|---|
| 1033 | (declare (ignore p2decls)) |
|---|
| 1034 | `(,op ,(mapcar #'decomp-var vars) ,(decomp-form form) ,(decomp-form body))) |
|---|
| 1035 | |
|---|
| 1036 | |
|---|
| 1037 | (defdecomp lambda-list (op req opt rest keys auxen body p2decls &optional code-note) |
|---|
| 1038 | (declare (ignore p2decls code-note)) |
|---|
| 1039 | (when *decomp-prettify* |
|---|
| 1040 | (setq op 'lambda)) |
|---|
| 1041 | `(,op ,(decomp-lambda-list req opt rest keys auxen) ,(decomp-form body))) |
|---|
| 1042 | |
|---|
| 1043 | (defdecomp debind (op ll form req opt rest keys auxen whole body p2decls cdr-p) |
|---|
| 1044 | (declare (ignore ll p2decls cdr-p)) |
|---|
| 1045 | `(,op ,(decomp-lambda-list req opt rest keys auxen whole) ,(decomp-form form) ,(decomp-form body))) |
|---|
| 1046 | |
|---|
| 1047 | (defdecomp lambda-bind (op vals req rest keys-p auxen body p2decls) |
|---|
| 1048 | (declare (ignore keys-p p2decls)) |
|---|
| 1049 | (when (find-if #'fixnump (cadr auxen)) |
|---|
| 1050 | (destructuring-bind (vars vals) auxen |
|---|
| 1051 | (setq auxen (list vars |
|---|
| 1052 | (mapcar (lambda (x) (if (fixnump x) `(keyref ,x) x)) vals))))) |
|---|
| 1053 | (let ((lambda-list (decomp-lambda-list req nil rest nil auxen))) |
|---|
| 1054 | `(,op ,lambda-list ,(decomp-formlist vals) ,(decomp-form body)))) |
|---|
| 1055 | |
|---|
| 1056 | (defdecomp (flet labels) (op vars afuncs body p2decls) |
|---|
| 1057 | (declare (ignore p2decls)) |
|---|
| 1058 | `(,op ,(mapcar (lambda (var afunc) |
|---|
| 1059 | (list (decomp-var var) (decomp-afunc afunc))) |
|---|
| 1060 | vars afuncs) |
|---|
| 1061 | ,(decomp-form body))) |
|---|
| 1062 | |
|---|
| 1063 | (defdecomp local-go (op tag) |
|---|
| 1064 | (when *decomp-prettify* |
|---|
| 1065 | (setq op 'go)) |
|---|
| 1066 | `(,op ,(car tag))) |
|---|
| 1067 | |
|---|
| 1068 | (defdecomp tag-label (op &rest tag) |
|---|
| 1069 | (if *decomp-prettify* |
|---|
| 1070 | (decomp-ref (car tag)) |
|---|
| 1071 | `(,op ,(car tag)))) |
|---|
| 1072 | |
|---|
| 1073 | (defdecomp local-tagbody (op tags forms) |
|---|
| 1074 | (declare (ignore tags)) |
|---|
| 1075 | (when *decomp-prettify* |
|---|
| 1076 | (setq op 'tagbody)) |
|---|
| 1077 | `(,op ,@(decomp-formlist forms))) |
|---|
| 1078 | |
|---|
| 1079 | (defdecomp local-block (op block body) |
|---|
| 1080 | (when *decomp-prettify* |
|---|
| 1081 | (setq op 'block)) |
|---|
| 1082 | `(,op ,(car block) ,(decomp-form body))) |
|---|
| 1083 | |
|---|
| 1084 | (defdecomp local-return-from (op block form) |
|---|
| 1085 | (when *decomp-prettify* |
|---|
| 1086 | (setq op 'return-from)) |
|---|
| 1087 | `(,op ,(car block) ,(decomp-form form))) |
|---|
| 1088 | |
|---|
| 1089 | ; end |
|---|
