x86-64: Remove rex-reg disassembler format

[sbcl.git] / src / interpreter / eval.lisp

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-INTERPRETER")

;;; *APPLYHOOK* works more-or-less as described in CLtL2, which is
;;; not at all like the *SELF-APPLYHOOK* that hooks every call
;;; into a function as part of the function itself.
;;; Don't bind it to an interpreted-function; probably don't bind to a
;;; symbol, and definitely not a lambda expression- just a compiled function.
;;; Also note: it's never rebound to NIL around each application,
;;; because that would make EVAL non-tail-recursive.  It is assumed that
;;; anyone messing with it knows what (s)he is doing.
(defvar *applyhook* nil)

;;; Retrieve the value of the binding (either lexical or special) of
;;; the variable named by SYMBOL in the environment ENV. For symbol
;;; macros the expansion is returned instead.
;;; Second values is T if the primary value is a macroexpansion.
;;; Tertiary value is the type to assert, or NIL if no type should be asserted.
;;; That is, policy-related decisions need to be made here, not in the caller.
(defun expand-or-eval-symbol (env symbol)
  (declare (symbol symbol))
  (binding* (((binding kind nil value) (find-lexical-var env symbol))
             (type (var-type-assertion env symbol binding :read))
             ((macro-p value)
              (if kind
                  (case kind
                    (:normal (values nil value))
                    (:macro  (values t (symexpand env symbol value)))
                    (t       (values nil (symbol-value symbol))))
                  (case (info :variable :kind symbol)
                    (:macro  (values t (symexpand env symbol)))
                    (:alien  (values nil (alien-value symbol)))
                    (t       (values nil (symbol-value symbol)))))))
    (values value macro-p type)))

;; Macros must go through the hook, but we can avoid it if the hook is FUNCALL.
(defun symexpand (env sym
                  &optional (expansion (info :variable :macro-expansion sym)))
  (let ((hook (valid-macroexpand-hook)))
    (if (eq hook #'funcall)
        expansion
        (funcall hook
                 (lambda (form env) (declare (ignore form env)) expansion)
                 sym env))))

;;; Implementation note: APPLY is the main reason the interpreter conses.
;;; It would be nice if you could preallocate a DX arglist and pass that
;;; on the stack. Applying directly from a DX arglist would make the
;;; interpreter non-tail-recursive, so we don't want to do that.
;;; There is sort of a way - assuming MAKE-LIST is made to be DXable -
;;; but it is probably much worse for performance:
;;; (multiple-value-call thing
;;;    (let ((foo (make-list n)))
;;;       (setf (nth 0 foo) (eval-nth-arg ...))
;;;       (values-list foo)
;;;

(defparameter *eval-level* -1)
(defparameter *eval-verbose* nil)

;;; These are the forms sb-fasteval will process for itself when the evaluator
;;; mode is :COMPILE. They all preserve a bidirectional mapping between
;;; LEXENV and subtypes of BASIC-ENV. Things like BLOCK/RETURN could not.
;;; The list also happens to match the the tiny evaluator (in 'eval'),
;;; though it might be reasonable to have additional things here.
(defconstant-eqx !simple-special-operators
  '(eval-when if progn quote locally macrolet symbol-macrolet setq)
  #'equal)

(defun %eval (exp env)
  (labels
      ((%%eval (&aux fname special-op)
         (cond
          ((symbolp exp)
           ;; CLHS 3.1.2.1.1 Symbols as Forms
           (binding* (((val expanded-p type) (expand-or-eval-symbol env exp))
                      (eval-val (if expanded-p (%eval val env) val)))
             (when (and type (not (itypep eval-val type)))
               (typecheck-fail/ref exp eval-val type))
             eval-val))
          ;; CLHS 3.1.2.1.3 Self-Evaluating Objects
          ;; We can save a few instructions vs. testing ATOM
          ;; because SYMBOLP was already picked off.
          ((not (listp exp)) exp)
          ;; CLHS 3.1.2.1.2 Conses as Forms
          ((eq (setq fname (car exp)) 'setq)
           (eval-setq (cdr exp) env nil)) ; SEXPR = nil
          ;; CLHS 3.1.2.1.2.4 Lambda Forms
          ((typep fname '(cons (eql lambda)))
           (if (eq sb-ext:*evaluator-mode* :interpret)
               ;; It should be possible to avoid consing a function,
               ;; but this syntax isn't common enough to matter.
               (apply-it (funcall (if (must-freeze-p env) #'enclose-freeze #'enclose)
                                  (make-proto-fn fname) env nil))
               (compile-it)))
          ((not (symbolp fname))
           (ip-error "Invalid function name: ~S" fname))
          ;; CLHS 3.1.2.1.2.1 Special Forms
          ;; Pick off special forms first for speed. Special operators
          ;; can't be shadowed by local defs.
          ((setq special-op (let ((fdefn (sb-impl::symbol-fdefn fname)))
                              (and fdefn (!special-form-handler fdefn))))
           (if (or (eq sb-ext:*evaluator-mode* :interpret)
                   (member fname !simple-special-operators))
               (funcall (truly-the function (car special-op)) (cdr exp) env)
               (compile-it)))
          (t
           ;; Everything else: macros and functions.
           (multiple-value-bind (fn macro-p) (get-function (car exp) env)
             (if macro-p
                 (%eval (funcall (valid-macroexpand-hook) fn exp env) env)
                 (apply-it fn))))))
       (compile-it () ; the escape hatch for evaluator-mode = :COMPILE.
         (sb-impl::%simple-eval
          exp (if env (lexenv-from-env env) (make-null-lexenv))))
       (apply-it (f)
         (let ((args (mapcar (lambda (arg) (%eval arg env)) (cdr exp)))
               (h *applyhook*))
           (if (or (null h)
                   (eq h (load-time-value #'funcall t))
                   (eq h 'funcall))
               (apply f args)
               (funcall h f args)))))
    ;; Binding *EVAL-LEVEL* inhibits tail-call, so try to avoid it
    (if *eval-verbose*
        (let ((*eval-level* (1+ *eval-level*)))
          (let ((*print-circle* t))
            (format t "~&~vA~S~%" *eval-level* "" `(%eval ,exp)))
          (%%eval))
        (%%eval))))

;; DIGEST-FORM both "digests" and EVALs a form.
;; It should stash an optimized handler into the SEXPR so that DIGEST-FORM
;; will (ideally) not be called again on this SEXPR.
;; The new handler is invoked right away.
;;
;; A few special-form-processors exist for standard macros. I test INFO on
;; special-forms before considering FIND-LEXICAL-FUN. After I apply my
;; globaldb speedups, it will actually be faster to use the two-part test
;; than just check the lexical environment. Usually existence of a processor
;; implies a special form, which is illegal to rebind lexically; whereas
;; technically it's legal to rebind standard macros, though weird and
;; scoring no readability points.
;;
(defun digest-form (form env sexpr)
  (declare (sexpr sexpr))
  (cond ((symbolp form) ; CLHS 3.1.2.1.1 Symbols as Forms
         (return-from digest-form (symeval form env sexpr)))
        ((not (listp form)) ; CLHS 3.1.2.1.3 Self-Evaluating Objects
         (setf (sexpr-handler sexpr) (return-constant form))
         (return-from digest-form form)))
  ;; CLHS 3.1.2.1.2 Conses as Forms
  (let ((fname (car form)))
    (cond ((eq fname 'setq)
           ;; SETQ mandates a different protocol which slightly
           ;; simplifies the treatment of symbol macros.
           (return-from digest-form
             (eval-setq (cdr form) env sexpr)))
          ((typep fname '(cons (eql lambda)))
           ;; CLHS 3.1.2.1.2.4 "A lambda form is equivalent to using funcall of
           ;; a lexical closure of the lambda expression on the given arguments."
           (return-from digest-form
             (digest-form `(funcall #',fname ,@(cdr form)) env sexpr)))
          ((not (symbolp fname))
           (ip-error "Invalid function name: ~S" fname)))
    ;; CLHS 3.1.2.1.2.1 Special Forms.
    (let ((fdefn (sb-impl::symbol-fdefn fname)))
      (awhen (and fdefn (!special-form-handler fdefn))
        (return-from digest-form
          (let ((digested-form
                 (funcall (truly-the function (cdr it)) (cdr form) env)))
            (cond (digested-form
                   (setf (sexpr-handler sexpr) digested-form)
                   (%dispatch sexpr env))
                  ((eq (info :function :kind fname) :special-form)
                   ;; Special operators that reimplement macros can decline,
                   ;; falling back upon the macro. This allows faster
                   ;; implementations of things like AND,OR,COND,INCF
                   ;; without having to deal with their full generality.
                   (error "Operator ~S mustn't decline to handle ~S"
                          fname form)))))))
    (let ((frame-ptr (local-fn-frame-ptr fname env)))
      (if (eq frame-ptr :macro)
          ;; CLHS 3.1.2.1.2.2 Macro Forms
          (multiple-value-bind (expansion keys)
              (tracing-macroexpand-1 form env)
            (cond (keys
                   (setf expansion (%sexpr expansion)
                           (sexpr-handler sexpr)
                           (digest-macro-form expansion fname keys))
                   (dispatch expansion env))
                  (t
                   (digest-form expansion env sexpr))))
        (progn
          (setf (sexpr-handler sexpr)
                (if frame-ptr ; a lexical function
                    (digest-local-call frame-ptr (cdr form))
                    (digest-global-call fname (cdr form) env)))
          (%dispatch sexpr env))))))

(fmakunbound 'eval-in-environment)
(defun eval-in-environment (form env)
  (incf *eval-calls*)
  (let ((interpreter-env
         (typecase env
          (sb-kernel:lexenv (if (sb-c::null-lexenv-p env) nil (env-from-lexenv env)))
          (t env))))
    (if (eq interpreter-env :compile)
        (funcall (handler-case
                     ;; Final arg of T means signal errors immediately rather
                     ;; than returning a function that signals when called.
                     (sb-c::actually-compile nil `(lambda () ,form) env nil nil t)
                  (error ()
                     ;; Whatever went wrong, just say "too complex"
                   (error 'compiler-environment-too-complex-error
                          :format-control
                          "~@<Lexical environment is too complex to evaluate in: ~S~:@>"
                          :format-arguments (list env)))))
        ;; FIXME: should this be (OR INTERPTER-ENV (CAPTURE-TOPLEVEL-ENV)) ?
        ;; Whether we decide to capture the policy here or not, there will always
        ;; be some use-case that comes out wrong. Capturing it is necessary for
        ;; the following to work in the interpreter:
        #|
        (defmacro some-macro (x &environment e)
          (if (policy e (= safety 3)) (expand-to-safe-code) (expand-normally)))
        (with-compilation-unit (:policy '(optimize (safety 3)))
           (some-macro (whatever)))
        |#
        ;; because WITH-COMPILATION-UNIT rebinds *POLICY* and so we need
        ;; to look at that policy regardless of whether interpreting or compiling.
        ;; But %COERCE-TO-POLICY as used in the (POLICY) macro would return
        ;; **BASELINE-POLICY** instead of *POLICY* when given NIL as the env,
        ;; because the compiler wants that.
        ;; But if we do capture the policy up front, then we _fail_ to see
        ;; any changes that are made by PROCLAIM because those _don't_
        ;; affect the policy in an interpreter environment.
        (%eval form interpreter-env))))

(defun unintern-init-only-stuff ()
  (let ((this-pkg (find-package "SB-INTERPRETER")))
    (do-symbols (s this-pkg)
      (when (or (and (eq (symbol-package s) this-pkg)
                     (macro-function s)
                     (not (member s '(defspecial do-decl-spec)))) ; for SB-CLTL2
                (eq s '%%eval)) ; got inlined
        (unintern s this-pkg)))))