src/pcl/compiler-support.lisp

   1 ;;;; things which the main SBCL compiler needs to know about the
   2 ;;;; implementation of CLOS
   3 ;;;;
   4 ;;;; (Our CLOS is derived from PCL, which was implemented in terms of
   5 ;;;; portable high-level Common Lisp. But now that it no longer needs
   6 ;;;; to be portable, we can make some special hacks to support it
   7 ;;;; better.)
   8
   9 ;;;; This software is part of the SBCL system. See the README file for more
  10 ;;;; information.
  11
  12 ;;;; This software is derived from software originally released by Xerox
  13 ;;;; Corporation. Copyright and release statements follow. Later modifications
  14 ;;;; to the software are in the public domain and are provided with
  15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  16 ;;;; information.
  17
  18 ;;;; copyright information from original PCL sources:
  19 ;;;;
  20 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  21 ;;;; All rights reserved.
  22 ;;;;
  23 ;;;; Use and copying of this software and preparation of derivative works based
  24 ;;;; upon this software are permitted. Any distribution of this software or
  25 ;;;; derivative works must comply with all applicable United States export
  26 ;;;; control laws.
  27 ;;;;
  28 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  29 ;;;; warranty about the software, its performance or its conformity to any
  30 ;;;; specification.
  31
  32 (in-package "SB-C")
  33 \f
  34 ;;;; very low-level representation of instances with meta-class
  35 ;;;; STANDARD-CLASS
  36
  37 (defknown sb-pcl::pcl-instance-p (t) boolean
  38   (movable foldable flushable explicit-check))
  39
  40 (deftransform sb-pcl::pcl-instance-p ((object))
  41   (let* ((otype (lvar-type object))
  42          (standard-object (specifier-type 'standard-object)))
  43     (cond
  44       ;; Flush tests whose result is known at compile time.
  45       ((csubtypep otype standard-object) t)
  46       ((not (types-equal-or-intersect otype standard-object)) nil)
  47       (t
  48        `(typep (layout-of object) 'sb-pcl::wrapper)))))
  49
  50 (defun sb-pcl::safe-code-p (&optional env)
  51   (let* ((lexenv (or env (make-null-lexenv)))
  52          (policy (lexenv-policy lexenv)))
  53     (eql (cdr (assoc 'safety policy)) 3)))
  54
  55 (define-source-context defmethod (name &rest stuff)
  56   (let ((arg-pos (position-if #'listp stuff)))
  57     (if arg-pos
  58         `(defmethod ,name ,@(subseq stuff 0 arg-pos)
  59            ,(handler-case
  60                 (nth-value 2 (sb-pcl::parse-specialized-lambda-list
  61                               (elt stuff arg-pos)))
  62               (error () "<illegal syntax>")))
  63         `(defmethod ,name "<illegal syntax>"))))
  64
  65 (defvar sb-pcl::*internal-pcl-generalized-fun-name-symbols* nil)
  66
  67 (defmacro define-internal-pcl-function-name-syntax (name &body body)
  68   `(progn
  69      (define-function-name-syntax ,name ,@body)
  70      (pushnew ',name sb-pcl::*internal-pcl-generalized-fun-name-symbols*)))
  71
  72 (define-internal-pcl-function-name-syntax sb-pcl::slot-accessor (list)
  73   (when (= (length list) 4)
  74     (destructuring-bind (class slot rwb) (cdr list)
  75       (when (and (member rwb '(sb-pcl::reader sb-pcl::writer sb-pcl::boundp))
  76                  (symbolp slot)
  77                  (symbolp class))
  78         (values t slot)))))
  79
  80 (define-internal-pcl-function-name-syntax sb-pcl::fast-method (list)
  81   (valid-function-name-p (cadr list)))
  82
  83 (define-internal-pcl-function-name-syntax sb-pcl::slow-method (list)
  84   (valid-function-name-p (cadr list)))
  85
  86 (define-internal-pcl-function-name-syntax sb-pcl::ctor (list)
  87   (valid-function-name-p (cadr list)))
  88
  89 (defun sb-pcl::random-documentation (name type)
  90   (cdr (assoc type (info :random-documentation :stuff name))))
  91
  92 (defun sb-pcl::set-random-documentation (name type new-value)
  93   (let ((pair (assoc type (info :random-documentation :stuff name))))
  94     (if pair
  95         (setf (cdr pair) new-value)
  96         (push (cons type new-value)
  97               (info :random-documentation :stuff name))))
  98   new-value)
  99
 100 (defsetf sb-pcl::random-documentation sb-pcl::set-random-documentation)
 101
 102 ;;;; SLOT-VALUE optimizations
 103
 104 (defknown slot-value (t symbol) t (any))
 105 (defknown sb-pcl::set-slot-value (t symbol t) t (any))
 106
 107 (defun pcl-boot-state-complete-p ()
 108   (eq 'sb-pcl::complete sb-pcl::*boot-state*))
 109
 110 ;;; These essentially duplicate what the compiler-macros in slots.lisp
 111 ;;; do, but catch more cases. We retain the compiler-macros since they
 112 ;;; can be used during the build, and because they catch common cases
 113 ;;; slightly more cheaply then the transforms. (Transforms add new
 114 ;;; lambdas, which requires more work by the compiler.)
 115
 116 (deftransform slot-value ((object slot-name))
 117   "optimize"
 118   (let (c-slot-name)
 119     (if (and (pcl-boot-state-complete-p)
 120              (constant-lvar-p slot-name)
 121              (setf c-slot-name (lvar-value slot-name))
 122              (sb-pcl::interned-symbol-p c-slot-name))
 123         `(sb-pcl::accessor-slot-value object ',c-slot-name)
 124         (give-up-ir1-transform "Slot name is not constant."))))
 125
 126 (deftransform sb-pcl::set-slot-value ((object slot-name new-value)
 127                                       (t symbol t) t
 128                                       ;; Safe code wants to check the
 129                                       ;; type, and the global accessor
 130                                       ;; won't do that. Also see the
 131                                       ;; comment in the
 132                                       ;; compiler-macro.
 133                                       :policy (< safety 3))
 134   "optimize"
 135   (let (c-slot-name)
 136     (if (and (pcl-boot-state-complete-p)
 137              (constant-lvar-p slot-name)
 138              (setf c-slot-name (lvar-value slot-name))
 139              (sb-pcl::interned-symbol-p c-slot-name))
 140         `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value)
 141         (give-up-ir1-transform "Slot name is not constant."))))