Changeset 15040


Ignore:
Timestamp:
Oct 24, 2011, 11:13:57 AM (8 years ago)
Author:
gb
Message:

NX1-FORM and friends (including alphatizers) take a "context" argument,
which can have one of the values NIL, :VALUE, or :RETURN. This allows
us to recognize (logical) tail-calls in the frontend and to detect cases
where form will be executed for side effects only.

Location:
trunk/source/compiler
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx0.lisp

    r14989 r15040  
    275275  def)
    276276
     277
     278;;; Note that all lexical variables bound at this time are live across
     279;;; a non-tail call by setting a bit in each such var.  This may not
     280;;; be exactt (for many reasons), but it may help the register allocator:
     281;;; if a variable is unlikely to be live across a call, there's less
     282;;; reason to keep it in a register that's preserved across calls.
     283
     284(defun nx-note-bound-vars-live-across-call ()
     285  (dolist (var *nx-bound-vars*)
     286    (let* ((local-bits (var-local-bits var)))
     287      (declare (fixnum local-bits))
     288      (unless (logbitp $vbitspecial (nx-var-bits var))
     289        (setf (var-local-bits var) (logior (ash 1 $vlocalbitiveacrosscall) local-bits))))))
     290
    277291(defsetf compiler-macro-function set-compiler-macro-function)
    278292
     
    409423
    410424
    411 (defun nx1-typed-var-initform (pending sym form &optional (env *nx-lexical-environment*))
    412   (let* ((type t)
    413          (*nx-form-type* (if (nx-trust-declarations env)
    414                            (dolist (decl (pending-declarations-vdecls pending) type)
    415                              (when (and (eq (car decl) sym) (eq (cadr decl) 'type))
    416                                (setq type (nx1-type-intersect sym (nx-target-type type) (cddr decl)))))
    417                            t)))
    418     (nx1-typed-form form env)))
     425
    419426
    420427; Guess.
     
    12951302
    12961303
    1297 (defun nx-block-info (blockname &optional (afunc *nx-current-function*) &aux
    1298   blocks
    1299   parent
    1300   (toplevel (eq afunc *nx-current-function*))
    1301   blockinfo)
    1302  (when afunc
    1303   (setq
    1304    blocks (if toplevel *nx-blocks* (afunc-blocks afunc))
    1305    blockinfo (assq blockname blocks)
    1306    parent (afunc-parent afunc))
    1307   (if blockinfo
    1308    (values blockinfo nil)
    1309    (when parent
    1310     (when (setq blockinfo (nx-block-info blockname parent))
    1311      (values blockinfo t))))))
     1304(defun nx-block-info (blockname)
     1305  (do* ((toplevel t nil)
     1306        (afunc *nx-current-function*(afunc-parent afunc)))
     1307       ((null afunc) (values nil nil))
     1308    (let* ((info (assq blockname (if toplevel *nx-blocks* (afunc-blocks afunc)))))
     1309      (if info
     1310        (return-from nx-block-info (values info (not toplevel)))))))
     1311
    13121312
    13131313(defun nx-tag-info (tagname &optional (afunc *nx-current-function*) &aux
     
    15041504                        nil
    15051505                        nil
    1506                         (nx1-env-body body old-env)
     1506                        (nx1-env-body :value body old-env)
    15071507                        *nx-new-p2decls*))))
    15081508      (when (eq (car l) '&method)
     
    15241524                           (nx-parse-simple-lambda-list pending ll)
    15251525        (nx-effect-other-decls pending *nx-lexical-environment*)
    1526         (setq body (nx1-env-body body old-env))
     1526        (setq body (nx1-env-body :return body old-env))
    15271527        (nx1-punt-bindings (%car auxen) (%cdr auxen))
    15281528        (when methvar
     
    16601660            (when (consp var)
    16611661              (setq sym (pop var) initform (pop var) spvar (%car var)))
    1662             (push (if no-acode initform (nx1-form initform)) optinits)
     1662            (push (if no-acode initform (nx1-form :value initform)) optinits)
    16631663            (push (if (symbolp sym)
    16641664                          (nx-new-structured-var pending sym)
     
    16981698                    (setq kvar (%car sym))
    16991699                    (setq kkey (make-keyword kvar))))
    1700                 (setq kinit (if no-acode (%cadr sym) (nx1-form (%cadr sym))))
     1700                (setq kinit (if no-acode (%cadr sym) (nx1-form :value (%cadr sym))))
    17011701                (setq ksupp (%caddr sym))))
    17021702            (push (if (symbolp kvar)
     
    17191719        (let ((auxvar (nx-pair-name pair))
    17201720              (auxval (nx-pair-initform pair)))
    1721           (push (if no-acode auxval (nx1-form auxval)) auxvals)
     1721          (push (if no-acode auxval (nx1-form :value auxval)) auxvals)
    17221722          (push (nx-new-var pending auxvar) auxvars)))
    17231723      (values
     
    17341734    (list (%nx1-operator lambda-list) whole req opt rest keys auxen)))
    17351735
    1736 (defun nx1-form (form &optional (*nx-lexical-environment* *nx-lexical-environment*))
    1737   (let* ((*nx-form-type* (if (and (consp form) (eq (car form) 'the))
    1738                            (nx-target-type (cadr form))
    1739                            t)))
    1740     (nx1-typed-form form *nx-lexical-environment*)))
    1741 
    1742 (defun nx1-typed-form (original env)
    1743   (with-program-error-handler
    1744       (lambda (c)
    1745         (let ((replacement (runtime-program-error-form c)))
    1746           (nx-note-source-transformation original replacement)
    1747           (nx1-transformed-form (nx-transform replacement env) env)))
    1748     (multiple-value-bind (form changed source) (nx-transform original env)
    1749       (declare (ignore changed))
    1750       ;; Bind this for cases where the transformed form is an atom, so it doesn't remember the source it came from.
    1751       (let ((*nx-current-note* (or source *nx-current-note*)))
    1752         (nx1-transformed-form form env)))))
    1753 
    1754 (defun nx1-transformed-form (form env)
    1755   (let* ((*nx-current-note* (or (nx-source-note form) *nx-current-note*))
    1756          (*nx-current-code-note*  (and *nx-current-code-note*
    1757                                        (or (nx-ensure-code-note form *nx-current-code-note*)
    1758                                            (compiler-bug "No source note for ~s" form))))
    1759          (acode (if (consp form)
    1760                   (nx1-combination form env)
    1761                   (let* ((symbolp (non-nil-symbol-p form))
    1762                          (constant-value (unless symbolp form))
    1763                          (constant-symbol-p nil))
    1764                     (if symbolp
    1765                       (multiple-value-setq (constant-value constant-symbol-p)
    1766                         (nx-transform-defined-constant form env)))
    1767                     (if (and symbolp (not constant-symbol-p))
    1768                       (nx1-symbol form env)
    1769                       (nx1-immediate (nx-unquote constant-value)))))))
    1770     (unless (acode-note acode) ;; leave it with most specific note
    1771       (cond (*nx-current-code-note*
    1772              (setf (acode-note acode) *nx-current-code-note*))
    1773             (*record-pc-mapping*
    1774              (setf (acode-note acode) (nx-source-note form)))))
    1775     acode))
    1776 
    1777 (defun nx1-prefer-areg (form env)
    1778   (nx1-form form env))
    1779 
    1780 (defun nx1-target-fixnump (form)
    1781   (when (typep form 'integer)
    1782     (let* ((target (backend-target-arch *target-backend*)))
    1783       (and
    1784        (>= form (arch::target-most-negative-fixnum target))
    1785        (<= form (arch::target-most-positive-fixnum target))))))
    1786 
    1787 
    1788 (defun nx1-immediate (form)
     1736
     1737(defun nx1-immediate (context form)
     1738  (declare (ignorable context))
    17891739  (cond ((eq form t) (make-acode (%nx1-operator t)))
    1790         ((null form) (make-acode (%nx1-operator nil)))
    1791         ((nx1-target-fixnump form)
    1792          (make-acode (%nx1-operator fixnum) form))
    1793         (t (make-acode (%nx1-operator immediate) form))))
    1794 
    1795 (defun nx2-constant-form-value (form)
    1796   (setq form (nx-untyped-form form))
    1797   (and (or (nx-null form)
    1798            (nx-t form)
    1799            (and (acode-p form)
    1800                 (or (eq (acode-operator form) (%nx1-operator immediate))
    1801                     (eq (acode-operator form) (%nx1-operator fixnum))
    1802                     (eq (acode-operator form) (%nx1-operator simple-function)))))
    1803        form))
    1804 
    1805 (defun nx-natural-constant-p (form)
    1806   (setq form (nx-untyped-form form))
    1807   (if (consp form)
    1808     (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
    1809                         (eq (acode-operator form) (%nx1-operator immediate)))
    1810                   (cadr form))))
    1811       (and (typep val *nx-target-natural-type*) val))))
    1812 
    1813 (defun nx-u32-constant-p (form)
    1814   (setq form (nx-untyped-form form))
    1815   (if (consp form)
    1816     (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
    1817                         (eq (acode-operator form) (%nx1-operator immediate)))
    1818                   (cadr form))))
    1819       (and (typep val '(unsigned-byte 32)) val))))
    1820 
    1821 (defun nx-u31-constant-p (form)
    1822   (setq form (nx-untyped-form form))
    1823   (if (consp form)
    1824     (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
    1825                         (eq (acode-operator form) (%nx1-operator immediate)))
    1826                   (cadr form))))
    1827       (and (typep val '(unsigned-byte 31)) val))))
    1828 
    1829 
    1830 ;;; Reference-count vcell, fcell refs.
    1831 (defun nx1-note-vcell-ref (sym)
    1832   (let* ((there (assq sym *nx1-vcells*))
    1833          (count (expt 4 *nx-loop-nesting-level*)))
    1834     (if there
    1835       (%rplacd there (%i+ (%cdr there) count))
    1836       (push (cons sym count) *nx1-vcells*)))
    1837   sym)
    1838 
    1839 (defun nx1-note-fcell-ref (sym)
    1840   (let* ((there (assq sym *nx1-fcells*))
    1841          (count (expt 4 *nx-loop-nesting-level*)))
    1842     (if there
    1843       (%rplacd there (%i+ (%cdr there) count))
    1844       (push (cons sym count) *nx1-fcells*))
    1845     sym))
    1846 
    1847 ; Note that "simple lexical refs" may not be; that's the whole problem ...
    1848 (defun nx1-symbol (form &optional (env *nx-lexical-environment*))
     1740          ((null form) (make-acode (%nx1-operator nil)))
     1741          ((nx1-target-fixnump form)
     1742           (make-acode (%nx1-operator fixnum) form))
     1743          (t (make-acode (%nx1-operator immediate) form))))
     1744
     1745;;; Note that "simple lexical refs" may not be; that's the whole problem ...
     1746(defun nx1-symbol (context form &optional (env *nx-lexical-environment*))
    18491747  (let* ((type (nx-declared-type form))
    18501748         (form
     
    18561754                  (nx-set-var-bits more (%ilogior (%ilsl $vbitreffed 1) (nx-var-bits more)))
    18571755                  (if (eq type t)
    1858                     (nx1-form inherited-p)
    1859                     (nx1-form `(the ,(prog1 type (setq type t)) ,inherited-p))))
     1756                    (nx1-form context inherited-p)
     1757                    (nx1-form context `(the ,(prog1 type (setq type t)) ,inherited-p))))
    18601758                (progn
    18611759                  (when (not inherited-p)
    18621760                    (nx-set-var-bits info (%ilogior2 (%ilsl $vbitreffed 1) (nx-var-bits info))))
    1863                   (nx-adjust-ref-count info)
     1761                  (when context
     1762                    (nx-adjust-ref-count info))
    18641763                  (nx-make-lexical-reference info)))
    18651764              (make-acode
     
    18821781      (make-acode (%nx1-operator typed-form) type form))))
    18831782
     1783(defun nx1-combination (context form env)
     1784  (destructuring-bind (sym &rest args) form
     1785    (if (symbolp sym)
     1786      (let* ((*nx-sfname* sym) special)
     1787        (if (and (setq special (gethash sym *nx1-alphatizers*))
     1788                 (or (not (functionp (fboundp sym)))
     1789                     (memq sym '(apply funcall ;; see bug #285
     1790                                 %defun        ;; see bug #295
     1791                                 ))
     1792                     (< (safety-optimize-quantity env) 3))
     1793                 ;;(not (nx-lexical-finfo sym env))
     1794                 (not (nx-declared-notinline-p sym *nx-lexical-environment*)))
     1795          (funcall special context form env) ; pass environment arg ...
     1796          (progn           
     1797            (nx1-typed-call context sym args))))
     1798      (if (lambda-expression-p sym)
     1799        (nx1-lambda-bind context (%cadr sym) args (%cddr sym))
     1800        (nx-error "In the form ~S, ~S is not a symbol or lambda expression." form sym)))))
     1801
     1802(defun nx1-transformed-form (context form env)
     1803  (let* ((*nx-current-note* (or (nx-source-note form) *nx-current-note*))
     1804         (*nx-current-code-note*  (and *nx-current-code-note*
     1805                                       (or (nx-ensure-code-note form *nx-current-code-note*)
     1806                                           (compiler-bug "No source note for ~s" form))))
     1807         (acode (if (consp form)
     1808                  (nx1-combination context form env)
     1809                  (let* ((symbolp (non-nil-symbol-p form))
     1810                         (constant-value (unless symbolp form))
     1811                         (constant-symbol-p nil))
     1812                    (if symbolp
     1813                      (multiple-value-setq (constant-value constant-symbol-p)
     1814                        (nx-transform-defined-constant form env)))
     1815                    (if (and symbolp (not constant-symbol-p))
     1816                      (nx1-symbol context form env)
     1817                      (nx1-immediate context (nx-unquote constant-value)))))))
     1818    (unless (acode-note acode) ;; leave it with most specific note
     1819      (cond (*nx-current-code-note*
     1820             (setf (acode-note acode) *nx-current-code-note*))
     1821            (*record-pc-mapping*
     1822             (setf (acode-note acode) (nx-source-note form)))))
     1823    acode))
     1824
     1825(defun nx1-typed-form (context original env)
     1826  (with-program-error-handler
     1827      (lambda (c)
     1828        (let ((replacement (runtime-program-error-form c)))
     1829          (nx-note-source-transformation original replacement)
     1830          (nx1-transformed-form context (nx-transform replacement env) env)))
     1831    (multiple-value-bind (form changed source) (nx-transform original env)
     1832      (declare (ignore changed))
     1833      ;; Bind this for cases where the transformed form is an atom, so it doesn't remember the source it came from.
     1834      (let ((*nx-current-note* (or source *nx-current-note*)))
     1835        (nx1-transformed-form context form env)))))
     1836
     1837(defun nx1-form (context form &optional (*nx-lexical-environment* *nx-lexical-environment*))
     1838  #-bootstrapped
     1839  (unless (member context '(nil :return :value))
     1840    (break "bad context ~s" context))
     1841  (let* ((*nx-form-type* (if (and (consp form) (eq (car form) 'the))
     1842                           (nx-target-type (cadr form))
     1843                           t)))
     1844    (nx1-typed-form context form *nx-lexical-environment*)))
     1845
     1846(defun nx1-typed-var-initform (pending sym form &optional (env *nx-lexical-environment*))
     1847  (let* ((type t)
     1848         (*nx-form-type* (if (nx-trust-declarations env)
     1849                           (dolist (decl (pending-declarations-vdecls pending) type)
     1850                             (when (and (eq (car decl) sym) (eq (cadr decl) 'type))
     1851                               (setq type (nx1-type-intersect sym (nx-target-type type) (cddr decl)))))
     1852                           t)))
     1853    (nx1-typed-form :value form env)))
     1854
     1855
     1856
     1857
     1858
     1859(defun nx1-target-fixnump (form)
     1860  (when (typep form 'integer)
     1861    (let* ((target (backend-target-arch *target-backend*)))
     1862      (and
     1863       (>= form (arch::target-most-negative-fixnum target))
     1864       (<= form (arch::target-most-positive-fixnum target))))))
     1865
     1866
     1867
     1868
     1869(defun nx2-constant-form-value (form)
     1870  (setq form (nx-untyped-form form))
     1871  (and (or (nx-null form)
     1872           (nx-t form)
     1873           (and (acode-p form)
     1874                (or (eq (acode-operator form) (%nx1-operator immediate))
     1875                    (eq (acode-operator form) (%nx1-operator fixnum))
     1876                    (eq (acode-operator form) (%nx1-operator simple-function)))))
     1877       form))
     1878
     1879(defun nx-natural-constant-p (form)
     1880  (setq form (nx-untyped-form form))
     1881  (if (consp form)
     1882    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
     1883                        (eq (acode-operator form) (%nx1-operator immediate)))
     1884                  (cadr form))))
     1885      (and (typep val *nx-target-natural-type*) val))))
     1886
     1887(defun nx-u32-constant-p (form)
     1888  (setq form (nx-untyped-form form))
     1889  (if (consp form)
     1890    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
     1891                        (eq (acode-operator form) (%nx1-operator immediate)))
     1892                  (cadr form))))
     1893      (and (typep val '(unsigned-byte 32)) val))))
     1894
     1895(defun nx-u31-constant-p (form)
     1896  (setq form (nx-untyped-form form))
     1897  (if (consp form)
     1898    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
     1899                        (eq (acode-operator form) (%nx1-operator immediate)))
     1900                  (cadr form))))
     1901      (and (typep val '(unsigned-byte 31)) val))))
     1902
     1903
     1904;;; Reference-count vcell, fcell refs.
     1905(defun nx1-note-vcell-ref (sym)
     1906  (let* ((there (assq sym *nx1-vcells*))
     1907         (count (expt 4 *nx-loop-nesting-level*)))
     1908    (if there
     1909      (%rplacd there (%i+ (%cdr there) count))
     1910      (push (cons sym count) *nx1-vcells*)))
     1911  sym)
     1912
     1913(defun nx1-note-fcell-ref (sym)
     1914  (let* ((there (assq sym *nx1-fcells*))
     1915         (count (expt 4 *nx-loop-nesting-level*)))
     1916    (if there
     1917      (%rplacd there (%i+ (%cdr there) count))
     1918      (push (cons sym count) *nx1-fcells*))
     1919    sym))
     1920
     1921
     1922
    18841923(defun nx1-check-special-ref (form auxinfo)
    18851924  (or (eq auxinfo :special)
     
    19441983
    19451984
    1946 (defun nx1-combination (form env)
    1947   (destructuring-bind (sym &rest args) form
    1948     (if (symbolp sym)
    1949       (let* ((*nx-sfname* sym) special)
    1950         (if (and (setq special (gethash sym *nx1-alphatizers*))
    1951                  (or (not (functionp (fboundp sym)))
    1952                      (memq sym '(apply funcall ;; see bug #285
    1953                                  %defun        ;; see bug #295
    1954                                  ))
    1955                      (< (safety-optimize-quantity env) 3))
    1956                  ;;(not (nx-lexical-finfo sym env))
    1957                  (not (nx-declared-notinline-p sym *nx-lexical-environment*)))
    1958           (funcall special form env) ; pass environment arg ...
    1959           (progn           
    1960             (nx1-typed-call sym args))))
    1961       (if (lambda-expression-p sym)
    1962         (nx1-lambda-bind (%cadr sym) args (%cddr sym))
    1963         (nx-error "In the form ~S, ~S is not a symbol or lambda expression." form sym)))))
    1964 
    1965 (defun nx1-treat-as-call (args)
    1966   (nx1-typed-call (car args) (%cdr args)))
    1967 
    1968 (defun nx1-typed-call (fn args &optional spread-p)
     1985;;; If "sym" is an expression (not a symbol which names a function),
     1986;;; the caller has already alphatized it.
     1987(defun nx1-call (context sym args &optional spread-p global-only inhibit-inline)
     1988  (nx1-verify-length args 0 nil)
     1989  (when (and (acode-p sym) (eq (acode-operator sym) (%nx1-operator immediate)))
     1990    (multiple-value-bind (valid name) (valid-function-name-p (%cadr sym))
     1991      (when valid
     1992        (setq global-only t sym name))))
     1993  (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
     1994    (if (nx-self-call-p sym global-only)
     1995      ;; Should check for downward functions here as well.
     1996      (multiple-value-bind (deftype reason)
     1997                           (nx1-check-call-args *nx-current-function* args spread-p)
     1998        (when deftype
     1999          (nx1-whine deftype sym reason args spread-p))
     2000        (if (eq context :return)
     2001          ;; Could check policy, note things that interfere with
     2002          ;; tail call, and try to better estimate whether or not
     2003          ;; this will be a real tail call.
     2004          (setf (afunc-bits *nx-current-function*)
     2005                (logior (ash 1 $fbittailcallsself) (afunc-bits *nx-current-function*)))
     2006          (nx-note-bound-vars-live-across-call))
     2007        (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p))
     2008      (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only)
     2009        (or (and (not inhibit-inline)
     2010                 (nx1-expand-inline-call context lambda-form containing-env token args spread-p *nx-lexical-environment*))
     2011            (multiple-value-bind (info afunc) (if (and  (symbolp sym) (not global-only)) (nx-lexical-finfo sym))
     2012              (when (eq 'macro (car info))
     2013                (nx-error "Can't call macro function ~s" sym))
     2014              (nx-record-xref-info :direct-calls sym)
     2015              (if (and afunc (%ilogbitp $fbitruntimedef (afunc-bits afunc)))
     2016                (let ((sym (var-name (afunc-lfun afunc))))
     2017                  (nx1-form
     2018                   context
     2019                   (if spread-p
     2020                     `(,(if (eql spread-p 0) 'applyv 'apply) ,sym ,args)
     2021                     `(funcall ,sym ,@args))))
     2022                (let* ((val (nx1-call-form context sym afunc args spread-p)))
     2023                    (when afunc
     2024                      (let ((callers (afunc-callers afunc))
     2025                            (self *nx-current-function*))
     2026                        (unless (or (eq self afunc) (memq self callers))
     2027                          (setf (afunc-callers afunc) (cons self callers)))))
     2028                    (if (and (null afunc) (memq sym *nx-never-tail-call*))
     2029                      (make-acode (%nx1-operator values) (list val))
     2030                      val)))))))))
     2031
     2032
     2033(defun nx1-treat-as-call (context args)
     2034  (nx1-typed-call context (car args) (%cdr args)))
     2035
     2036(defun nx1-typed-call (context fn args &optional spread-p)
    19692037  (let ((global-only nil)
    19702038        (errors-p nil)
     
    19782046        (nx1-check-typed-call fn args spread-p global-only)))
    19792047    (setq result-type (nx1-type-intersect fn *nx-form-type* result-type))
    1980     (let ((form (nx1-call fn args spread-p global-only errors-p)))
     2048    (let ((form (nx1-call context fn args spread-p global-only errors-p)))
    19812049      (if (eq result-type t)
    19822050        form
     
    22742342   (arch::builtin-function-name-offset name))
    22752343
    2276 (defun nx1-call-form (global-name afunc arglist spread-p  &optional (env *nx-lexical-environment*))
     2344(defun nx1-call-form (context global-name afunc arglist spread-p  &optional (env *nx-lexical-environment*))
     2345  (unless (eq context :return)
     2346    (nx-note-bound-vars-live-across-call))
    22772347  (if afunc
    22782348    (make-acode (%nx1-operator lexical-function-call) afunc (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*))) spread-p)
     
    22912361        (make-acode (%nx1-operator call)
    22922362                     (if (symbolp global-name)
    2293                        (nx1-immediate (nx1-note-fcell-ref global-name))
     2363                       (nx1-immediate context (if context (nx1-note-fcell-ref global-name) global-name))
    22942364                       global-name)
    22952365                     (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*)))
    22962366                     spread-p)))))
    22972367 
    2298 ;;; If "sym" is an expression (not a symbol which names a function),
    2299 ;;; the caller has already alphatized it.
    2300 (defun nx1-call (sym args &optional spread-p global-only inhibit-inline)
    2301   (nx1-verify-length args 0 nil)
    2302   (when (and (acode-p sym) (eq (acode-operator sym) (%nx1-operator immediate)))
    2303     (multiple-value-bind (valid name) (valid-function-name-p (%cadr sym))
    2304       (when valid
    2305         (setq global-only t sym name))))
    2306   (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
    2307     (if (nx-self-call-p sym global-only)
    2308       ;; Should check for downward functions here as well.
    2309       (multiple-value-bind (deftype reason)
    2310                            (nx1-check-call-args *nx-current-function* args spread-p)
    2311         (when deftype
    2312           (nx1-whine deftype sym reason args spread-p))
    2313         (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p))
    2314       (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only)
    2315         (or (and (not inhibit-inline)
    2316                  (nx1-expand-inline-call lambda-form containing-env token args spread-p *nx-lexical-environment*))
    2317             (multiple-value-bind (info afunc) (if (and  (symbolp sym) (not global-only)) (nx-lexical-finfo sym))
    2318               (when (eq 'macro (car info))
    2319                 (nx-error "Can't call macro function ~s" sym))
    2320               (nx-record-xref-info :direct-calls sym)
    2321               (if (and afunc (%ilogbitp $fbitruntimedef (afunc-bits afunc)))
    2322                 (let ((sym (var-name (afunc-lfun afunc))))
    2323                   (nx1-form
    2324                    (if spread-p
    2325                      `(,(if (eql spread-p 0) 'applyv 'apply) ,sym ,args)
    2326                      `(funcall ,sym ,@args))))
    2327                 (let* ((val (nx1-call-form sym afunc args spread-p)))
    2328                     (when afunc
    2329                       (let ((callers (afunc-callers afunc))
    2330                             (self *nx-current-function*))
    2331                         (unless (or (eq self afunc) (memq self callers))
    2332                           (setf (afunc-callers afunc) (cons self callers)))))
    2333                     (if (and (null afunc) (memq sym *nx-never-tail-call*))
    2334                       (make-acode (%nx1-operator values) (list val))
    2335                       val)))))))))
    2336 
    2337 (defun nx1-expand-inline-call (lambda-form env token args spread-p old-env)
     2368
     2369
     2370(defun nx1-expand-inline-call (context lambda-form env token args spread-p old-env)
    23382371  (if (and (or (null spread-p) (eq (length args) 1)))
    23392372    (if (and token (not (memq token *nx-inline-expansions*)))
     
    23502383                  (debug . ,(debug-optimize-quantity old-env))))
    23512384          (if spread-p
    2352             (nx1-destructure lambda-list (car args) nil nil body new-env)
    2353             (nx1-lambda-bind lambda-list args body new-env)))))))
     2385            (nx1-destructure context lambda-list (car args) nil nil body new-env)
     2386            (nx1-lambda-bind context lambda-list args body new-env)))))))
    23542387             
    23552388; note that regforms are reversed: arg_z is always in the car
     
    23632396       (dotimes (i nstkargs (nreverse stkforms))
    23642397         (declare (fixnum i))
    2365          (push (nx1-form (%car args)) stkforms)
     2398         (push (nx1-form :value (%car args)) stkforms)
    23662399         (setq args (%cdr args)))
    23672400       (dolist (arg args regforms)
    2368          (push (nx1-form arg) regforms)))))
    2369 
    2370 (defun nx1-formlist (args)
     2401         (push (nx1-form :value arg) regforms)))))
     2402
     2403(defun nx1-formlist (context args)
    23712404  (let* ((a nil))
    23722405    (dolist (arg args)
    2373       (push (nx1-form arg) a))
     2406      (push (nx1-form (if context :value) arg) a))
    23742407    (nreverse a)))
    23752408
     
    27792812            (subtypep *nx-form-type* *nx-target-natural-type*)))))
    27802813
    2781 (defun nx-binary-boole-op (whole env arg-1 arg-2 fixop intop naturalop)
     2814(defun nx-binary-boole-op (context whole env arg-1 arg-2 fixop intop naturalop)
    27822815  (let* ((use-fixop (nx-binary-fixnum-op-p arg-1 arg-2 env t))
    27832816         (use-naturalop (nx-binary-natural-op-p arg-1 arg-2 env)))
     
    27872820                    (if use-naturalop *nx-target-natural-type* 'integer))
    27882821                  (make-acode (if use-fixop fixop (if use-naturalop naturalop intop))
    2789                               (nx1-form arg-1)
    2790                               (nx1-form arg-2)))
    2791       (nx1-treat-as-call whole))))
     2822                              (nx1-form :value arg-1)
     2823                              (nx1-form :value arg-2)))
     2824      (nx1-treat-as-call context whole))))
    27922825
    27932826(defun nx-global-p (sym &optional (env *nx-lexical-environment*))
  • trunk/source/compiler/nx1.lisp

    r14983 r15040  
    1717
    1818(in-package "CCL")
     19
     20   
     21(defmacro defnx1 (name sym contextvar arglist &body forms &environment env)
     22  (unless (verify-lambda-list arglist t t t)
     23    (error "Invalid lambda list ~s" arglist))
     24  (multiple-value-bind (lambda-list whole environment)
     25      (normalize-lambda-list arglist t t)
     26    (multiple-value-bind (body local-decs) (parse-body forms env)
     27      (let ((whole-var (gensym "WHOLE"))
     28            (env-var (gensym "ENVIRONMENT")))
     29        (multiple-value-bind (bindings binding-decls)
     30            (%destructure-lambda-list lambda-list whole-var nil nil
     31                                      :cdr-p t
     32                                      :whole-p nil
     33                                      :use-whole-var t
     34                                      :default-initial-value nil)
     35          (when environment
     36            (setq bindings (nconc bindings (list `(,environment ,env-var)))))
     37          (when whole
     38            (setq bindings (nconc bindings (list `(,whole ,whole-var)))))
     39          (let ((fn `(nfunction ,name
     40                      (lambda (,contextvar ,whole-var ,env-var)
     41                        (declare (ignorable ,contextvar ,whole-var ,env-var))
     42                        (block ,name
     43                          (let* ,(nreverse bindings)
     44                            ,@(when binding-decls `((declare ,@binding-decls)))
     45                            ,@local-decs
     46                            ,@body)))))
     47                (theprogn ())
     48                (ysym (gensym)))
     49            `(let ((,ysym ,fn))
     50              ,(if (symbolp sym)
     51                   `(progn
     52                     (setf (gethash ',sym *nx1-alphatizers*) ,ysym)
     53                                        ;(proclaim '(inline ,sym))
     54                     (pushnew ',sym *nx1-compiler-special-forms*))
     55                   (dolist (x sym `(progn ,@(nreverse theprogn)))
     56                     (if (consp x)
     57                       (setq x (%car x))
     58                       (push `(pushnew ',x *nx1-compiler-special-forms*) theprogn))
     59                                        ;(push `(proclaim '(inline ,x)) theprogn)
     60                     (push `(setf (gethash ',x *nx1-alphatizers*) ,ysym) theprogn)))
     61              (record-source-file ',name 'function)
     62              ,ysym)))))))
    1963
    2064(defun nx1-typespec-for-typep (typespec env &key (whine t))
     
    67111      (nx-target-type (type-specifier (if new (specifier-type new) ctype))))))
    68112
    69 (defnx1 nx1-the the (&whole call typespec form &environment env)
     113(defnx1 nx1-the the context (&whole call typespec form &environment env)
    70114  (let* ((typespec (nx1-typespec-for-typep typespec env))
    71115         (*nx-form-type* typespec)
     
    108152       typespec
    109153       (let* ((*nx-form-type* typespec))
    110          (nx1-transformed-form transformed env))
     154         (nx1-transformed-form context transformed env))
    111155       (nx-declarations-typecheck env)))))
    112156
    113 (defnx1 nx1-struct-ref struct-ref (&whole whole structure offset)
     157(defnx1 nx1-struct-ref struct-ref context (&whole whole structure offset)
    114158  (if (not (fixnump (setq offset (nx-get-fixnum offset))))
    115     (nx1-treat-as-call whole)
     159    (nx1-treat-as-call context whole)
    116160    (make-acode (%nx1-operator struct-ref)
    117                 (nx1-form structure)
    118                 (nx1-form offset))))
    119 
    120 (defnx1 nx1-struct-set struct-set (&whole whole structure offset newval)
     161                (nx1-form :value structure)
     162                (nx1-form :value offset))))
     163
     164(defnx1 nx1-struct-set struct-set context (&whole whole structure offset newval)
    121165  (if (not (fixnump (setq offset (nx-get-fixnum offset))))
    122     (nx1-treat-as-call whole)
     166    (nx1-treat-as-call context whole)
    123167    (make-acode
    124168     (%nx1-operator struct-set)
    125      (nx1-form structure)
    126      (nx1-form offset)
    127      (nx1-form newval))))
    128 
    129 (defnx1 nx1-istruct-typep ((istruct-typep)) (&whole whole thing type &environment env)
     169     (nx1-form :value structure)
     170     (nx1-form :value offset)
     171     (nx1-form :value newval))))
     172
     173(defnx1 nx1-istruct-typep ((istruct-typep)) context (&whole whole thing type &environment env)
    130174  (if (and (nx-form-constant-p type env) (non-nil-symbol-p (nx-form-constant-value type env)))
    131     (make-acode (%nx1-operator istruct-typep)
    132                 (nx1-immediate :eq)
    133                 (nx1-form thing)
    134                 (nx1-form `(register-istruct-cell ,type)))
    135     (nx1-treat-as-call whole)))
    136 
    137 (defnx1 nx1-make-list make-list (&whole whole size &rest keys &environment env)
     175    (let* ((inner :value))
     176      (make-acode (%nx1-operator istruct-typep)
     177                  (nx1-immediate inner :eq)
     178                  (nx1-form inner thing)
     179                  (nx1-form inner `(register-istruct-cell ,type))))
     180    (nx1-treat-as-call context whole)))
     181
     182(defnx1 nx1-make-list make-list context (&whole whole size &rest keys &environment env)
    138183  (if (and keys
    139184             (or
    140185              (neq (list-length keys) 2)
    141186              (neq (nx-transform (%car keys) env) :initial-element)))
    142     (nx1-treat-as-call whole)
     187    (nx1-treat-as-call context whole)
    143188    (make-acode
    144189     (%nx1-operator make-list)
    145      (nx1-form size)
    146      (nx1-form (%cadr keys)))))
     190     (nx1-form :value size)
     191     (nx1-form :value (%cadr keys)))))
     192
     193(defun nx1-progn-body (context args)
     194  (if (null (cdr args))
     195    (nx1-form context (%car args))
     196    (make-acode (%nx1-operator progn)
     197                (collect ((forms))
     198                  (do* ()
     199                       ((null (cdr args))
     200                        (forms (nx1-form context (car args)))
     201                        (forms))
     202                    (forms (nx1-form nil (car args)))
     203                    (setq args (cdr args)))))))
    147204
    148205;;; New semantics: expansion functions are defined in current lexical environment
    149206;;; vice null environment.  May be meaningless ...
    150 (defnx1 nx1-macrolet macrolet (defs &body body)
     207(defnx1 nx1-macrolet macrolet context (defs &body body)
    151208  (let* ((old-env *nx-lexical-environment*)
    152209         (new-env (new-lexical-environment old-env)))
     
    167224        (multiple-value-bind (body decls) (parse-body body new-env)
    168225          (nx-process-declarations pending decls)
    169           (nx1-progn-body body))))))
     226          (nx1-progn-body context body))))))
    170227
    171228;;; Does SYMBOL-MACROLET allow declarations ?  Yes ...
    172 (defnx1 nx1-symbol-macrolet symbol-macrolet (defs &body forms)
     229(defnx1 nx1-symbol-macrolet symbol-macrolet context (defs &body forms)
    173230  (let* ((old-env *nx-lexical-environment*))
    174231    (with-nx-declarations (pending)
     
    187244                (setf (var-ea var) (cons :symbol-macro expansion)))))
    188245          (nx-effect-other-decls pending env)
    189           (nx1-env-body body old-env))))))
    190 
    191 (defnx1 nx1-progn progn (&body args)
    192   (nx1-progn-body args))
    193 
    194 (defnx1 nx1-with-c-frame with-c-frame (var &body body)
     246          (nx1-env-body context body old-env))))))
     247
     248(defnx1 nx1-progn progn context (&body args)
     249  (nx1-progn-body context args))
     250
     251(defnx1 nx1-with-c-frame with-c-frame context (var &body body)
    195252  (make-acode (%nx1-operator with-c-frame)
    196               (nx1-form `(let* ((,var (%foreign-stack-pointer)))
     253              (nx1-form context `(let* ((,var (%foreign-stack-pointer)))
    197254                          ,@body))))
    198255
    199 (defnx1 nx1-with-variable-c-frame with-variable-c-frame (size var &body body)
     256(defnx1 nx1-with-variable-c-frame with-variable-c-frame context (size var &body body)
    200257  (make-acode (%nx1-operator with-variable-c-frame)
    201               (nx1-form size)
    202               (nx1-form `(let* ((,var (%foreign-stack-pointer)))
    203                           ,@body))))
    204 
    205 
    206 (defun nx1-progn-body (args)
    207   (if (null (cdr args))
    208     (nx1-form (%car args))
    209     (make-acode (%nx1-operator progn) (nx1-formlist args))))
     258              (nx1-form :value size)
     259              (nx1-form context `(let* ((,var (%foreign-stack-pointer)))
     260                                  ,@body))))
     261
     262
     263
    210264
    211265(defnx1 nx1-unaryop ((%word-to-int) (uvsize)  (%reference-external-entry-point)
    212                      (%symbol->symptr))
     266                     (%symbol->symptr)) context
    213267        (arg)
    214268  (make-acode
    215    (%nx1-default-operator) (nx1-form arg)))
    216 
    217 (defnx1 nx1-nullaryop ((%current-tcr) (%interrupt-poll) (%foreign-stack-pointer) (%current-frame-ptr)) ()
     269   (%nx1-default-operator) (nx1-form :value arg)))
     270
     271(defnx1 nx1-nullaryop ((%current-tcr) (%interrupt-poll) (%foreign-stack-pointer) (%current-frame-ptr)) context ()
    218272  (make-acode (%nx1-default-operator)))
    219273
    220 (defnx1 nx1-fixnum-ref ((%fixnum-ref) (%fixnum-ref-natural)) (base &optional (offset 0))
     274(defnx1 nx1-fixnum-ref ((%fixnum-ref) (%fixnum-ref-natural)) context (base &optional (offset 0))
    221275  (make-acode (%nx1-default-operator)
    222               (nx1-form base)
    223               (nx1-form offset)))
    224 
    225 (defnx1 nx1-fixnum-ref-double-float ((%fixnum-ref-double-float)) (base &optional (index 0))
     276              (nx1-form :value base)
     277              (nx1-form :value offset)))
     278
     279(defnx1 nx1-fixnum-ref-double-float ((%fixnum-ref-double-float)) context (base &optional (index 0))
    226280  (make-acode (%nx1-operator typed-form)
    227281               'double-float
    228282               (make-acode (%nx1-operator %fixnum-ref-double-float)
    229                            (nx1-form base)
    230                            (nx1-form index))))
    231 
    232 (defnx1 nx2-fixnum-set-double-float ((%fixnum-set-double-float)) (base index-or-val &optional (val nil val-p))
     283                           (nx1-form :value base)
     284                           (nx1-form :value index))))
     285
     286(defnx1 nx2-fixnum-set-double-float ((%fixnum-set-double-float)) context (base index-or-val &optional (val nil val-p))
    233287  (unless val-p
    234288    (setq val index-or-val index-or-val 0))
     
    236290               'double-float
    237291               (make-acode (%nx1-operator %fixnum-set-double-float)
    238                            (nx1-form base)
    239                            (nx1-form index-or-val)
    240                            (nx1-form val))))
     292                           (nx1-form :value  base)
     293                           (nx1-form :value index-or-val)
     294                           (nx1-form :value val))))
    241295               
    242296
    243 (defnx1 nx1-type-unaryop ((typecode) (lisptag) (fulltag))
     297(defnx1 nx1-type-unaryop ((typecode) (lisptag) (fulltag)) context
    244298  (arg)
    245299  (let* ((operator
     
    249303            (( fulltag) (%nx1-operator fulltag)))))
    250304    (make-acode
    251      operator (nx1-form arg))))
     305     operator (nx1-form :value arg))))
    252306       
    253307
    254 (defnx1 nx1-code-char ((code-char)) (arg &environment env)
     308(defnx1 nx1-code-char ((code-char)) context (arg &environment env)
    255309  (make-acode (if (nx-form-typep arg '(unsigned-byte 8) env)
    256310                (%nx1-operator %code-char)
     
    258312                  (%nx1-operator %valid-code-char)
    259313                  (%nx1-operator code-char)))
    260               (nx1-form arg)))
    261 
    262 (defnx1 nx1-char-code ((char-code)) (arg &environment env)
     314              (nx1-form :value arg)))
     315
     316(defnx1 nx1-char-code ((char-code)) context (arg &environment env)
    263317  (make-acode (if (nx-form-typep arg 'character env)
    264318                (%nx1-operator %char-code)
    265319                (%nx1-operator char-code))
    266               (nx1-form arg)))
    267 
    268 (defnx1 nx1-cXr ((car) (cdr)) (arg &environment env)
     320              (nx1-form :value arg)))
     321
     322(defnx1 nx1-cXr ((car) (cdr)) context (arg &environment env)
    269323  (let* ((op (if (eq *nx-sfname* 'car) (%nx1-operator car) (%nx1-operator cdr)))
    270324         (inline-op (if (eq op (%nx1-operator car)) (%nx1-operator %car) (%nx1-operator %cdr))))
     
    272326                  inline-op
    273327                  op)
    274                 (nx1-prefer-areg arg env))))
    275 
    276 (defnx1 nx1-rplacX ((rplaca) (rplacd)) (pairform valform &environment env)
     328                (nx1-form :value arg env))))
     329
     330(defnx1 nx1-rplacX ((rplaca) (rplacd)) context (pairform valform &environment env)
    277331  (let* ((op (if (eq *nx-sfname* 'rplaca) (%nx1-operator rplaca) (%nx1-operator rplacd)))
    278332         (inline-op (if (eq op (%nx1-operator rplaca)) (%nx1-operator %rplaca) (%nx1-operator %rplacd))))
     
    283337                  inline-op
    284338                  op)
    285                 (nx1-prefer-areg pairform env)
    286                 (nx1-form valform))))
    287 
    288 (defnx1 nx1-set-cXr ((set-car) (set-cdr)) (pairform valform &environment env)
     339                (nx1-form :value pairform env)
     340                (nx1-form :value valform env))))
     341
     342(defnx1 nx1-set-cXr ((set-car) (set-cdr)) context (pairform valform &environment env)
    289343  (let* ((op (if (eq *nx-sfname* 'set-car) (%nx1-operator set-car) (%nx1-operator set-cdr)))
    290344         (inline-op (if (eq op (%nx1-operator set-car)) (%nx1-operator %rplaca) (%nx1-operator %rplacd)))
     
    294348                                     (nx-form-typep pairform 'cons env)))))
    295349         (acode (make-acode (if inline-p inline-op op)
    296                             (nx1-prefer-areg pairform env)
    297                             (nx1-form valform))))
     350                            (nx1-form :value pairform env)
     351                            (nx1-form :value valform))))
    298352    (if inline-p
    299353      (make-acode (if (eq op (%nx1-operator set-car)) (%nx1-operator %car) (%nx1-operator %cdr)) acode)
    300354      acode)))
    301355
    302 (defun nx1-cc-binaryop (op cc form1 form2)
    303   (make-acode op (nx1-immediate cc) (nx1-form form1) (nx1-form form2)))
    304 
    305 (defnx1 nx1-ccEQ-unaryop ((characterp)  (endp) (consp) (base-char-p)) (arg)
    306   (make-acode (%nx1-default-operator) (nx1-immediate :EQ) (nx1-form arg)))
    307 
    308 
    309 
    310 (defnx1 nx1-ccEQ-binaryop ( (%ptr-eql) (eq))
     356(defun nx1-cc-binaryop (context op cc form1 form2)
     357  (declare (ignorable context))
     358  (make-acode op
     359              (nx1-immediate :value cc)
     360              (nx1-form :value form1) (nx1-form :value form2)))
     361
     362(defnx1 nx1-ccEQ-unaryop ((characterp)  (endp) (consp) (base-char-p)) context (arg)
     363  (make-acode (%nx1-default-operator)
     364              (nx1-immediate :value :EQ)
     365              (nx1-form :value arg)))
     366
     367
     368
     369(defnx1 nx1-ccEQ-binaryop ( (%ptr-eql) (eq)) context
    311370        (form1 form2)
    312   (nx1-cc-binaryop (%nx1-default-operator) :eq form1 form2))
    313 
    314 
    315 (defnx1 nx1-ccNE-binaryop ((neq))
     371  (nx1-cc-binaryop context (%nx1-default-operator) :eq form1 form2))
     372
     373
     374(defnx1 nx1-ccNE-binaryop ((neq)) context
    316375        (form1 form2)
    317   (nx1-cc-binaryop (%nx1-default-operator) :ne form1 form2))
    318 
    319 (defnx1 nx1-logbitp ((logbitp)) (bitnum int &environment env)
     376  (nx1-cc-binaryop context (%nx1-default-operator) :ne form1 form2))
     377
     378(defnx1 nx1-logbitp ((logbitp)) context (bitnum int &environment env)
    320379  (if (and (nx-form-typep bitnum
    321380                          (target-word-size-case (32 '(integer 0 29))
    322381                                                 (64 '(integer 0 60))) env)
    323382           (nx-form-typep int 'fixnum env))
    324     (nx1-cc-binaryop (%nx1-operator %ilogbitp) :ne bitnum int)
    325     (make-acode (%nx1-operator logbitp) (nx1-form bitnum) (nx1-form int))))
     383    (nx1-cc-binaryop context (%nx1-operator %ilogbitp) :ne bitnum int)
     384    (make-acode (%nx1-operator logbitp)
     385                (nx1-form :value bitnum)
     386                (nx1-form :value int))))
    326387
    327388
    328389 
    329 (defnx1 nx1-ccGT-unaryop ((int>0-p)) (arg)
    330   (make-acode (%nx1-default-operator) (nx1-immediate :gt) (nx1-form arg)))
    331 
    332 (defnx1 nx1-macro-unaryop (multiple-value-list) (arg)
     390(defnx1 nx1-ccGT-unaryop ((int>0-p)) context (arg)
     391  (make-acode (%nx1-default-operator)
     392              (nx1-immediate :value :gt)
     393              (nx1-form :value arg)))
     394
     395(defnx1 nx1-macro-unaryop (multiple-value-list) context (arg)
    333396  (make-acode
    334    (%nx1-default-operator) (nx1-form arg)))
    335 
    336 (defnx1 nx1-atom ((atom)) (arg)
    337   (nx1-form `(not (consp ,arg))))
    338 
    339 (defnx1 nx1-locally locally (&body forms)
     397   (%nx1-default-operator) (nx1-form :value arg)))
     398
     399(defnx1 nx1-atom ((atom)) context (arg)
     400  (nx1-form context `(not (consp ,arg))))
     401
     402(defnx1 nx1-locally locally context (&body forms)
    340403  (with-nx-declarations (pending)
    341404    (let ((env *nx-lexical-environment*))
     
    343406        (nx-process-declarations pending decls)
    344407        (nx-effect-other-decls pending env)
    345          (setq body (nx1-progn-body body))
     408         (setq body (nx1-progn-body context body))
    346409         (if decls
    347410           (make-acode (%nx1-operator %decls-body) body *nx-new-p2decls*)
    348411           body)))))
    349412
    350 (defnx1 nx1-%new-ptr (%new-ptr) (size &optional clear-p)
    351   (make-acode (%nx1-operator %new-ptr) (nx1-form size) (nx1-form clear-p)))
     413(defnx1 nx1-%new-ptr (%new-ptr) context (size &optional clear-p)
     414  (make-acode (%nx1-operator %new-ptr)
     415              (nx1-form :value size)
     416              (nx1-form :value clear-p)))
    352417
    353418;;; This might also want to look at, e.g., the last form in a progn:
    354419;;;  (not (progn ... x)) => (progn ... (not x)), etc.
    355 (defnx1 nx1-negation ((not) (null)) (arg)
    356   (if (nx1-negate-form (setq arg (nx1-form arg)))
     420(defnx1 nx1-negation ((not) (null)) context (arg)
     421  (if (nx1-negate-form (setq arg (nx1-form context arg)))
    357422    arg
    358     (make-acode (%nx1-operator not) (nx1-immediate :eq) arg)))
     423    (make-acode (%nx1-operator not) (nx1-immediate context :eq) arg)))
    359424
    360425(defun nx1-negate-form (form)
     
    381446
    382447
    383 (defnx1 nx1-cxxr ((caar) (cadr) (cdar) (cddr)) (form)
     448(defnx1 nx1-cxxr ((caar) (cadr) (cdar) (cddr)) context (form)
    384449  (let* ((op *nx-sfname*))
    385450    (let* ((inner (case op
     
    389454                       ((cdar cddr) 'cdr)
    390455                       (t 'car))))
    391          (nx1-form `(,outer (,inner ,form))))))     
    392 
    393 (defnx1 nx1-%int-to-ptr ((%int-to-ptr)) (int)
     456         (nx1-form :value `(,outer (,inner ,form))))))     
     457
     458(defnx1 nx1-%int-to-ptr ((%int-to-ptr)) context (int)
    394459  (make-acode
    395460   (%nx1-operator %consmacptr%)
    396461   (make-acode (%nx1-operator %immediate-int-to-ptr)
    397                (nx1-form int))))
    398 
    399 (defnx1 nx1-%ptr-to-int ((%ptr-to-int)) (ptr)
     462               (nx1-form :value int))))
     463
     464(defnx1 nx1-%ptr-to-int ((%ptr-to-int)) context (ptr)
    400465  (make-acode
    401466   (%nx1-operator %immediate-ptr-to-int)
    402467   (make-acode (%nx1-operator %macptrptr%)
    403                (nx1-form ptr))))
    404 
    405 (defnx1 nx1-%null-ptr-p ((%null-ptr-p)) (ptr)
    406   (nx1-form `(%ptr-eql ,ptr (%int-to-ptr 0))))
     468               (nx1-form :value ptr))))
     469
     470(defnx1 nx1-%null-ptr-p ((%null-ptr-p)) context (ptr)
     471  (nx1-form :value `(%ptr-eql ,ptr (%int-to-ptr 0))))
    407472
    408473(defnx1 nx1-binop ( (%ilsl) (%ilsr) (%iasr)
    409                    (cons) (%temp-cons))
     474                   (cons) (%temp-cons)) context
    410475        (arg1 arg2)
    411   (make-acode (%nx1-default-operator) (nx1-form arg1) (nx1-form arg2)))
    412 
    413 
    414 
    415 (defnx1 nx1-%misc-ref ((%misc-ref)) (v i)
    416   (make-acode (%nx1-operator uvref) (nx1-form v) (nx1-form i)))
    417 
    418 
    419 
    420 
    421 (defnx1 nx1-schar ((schar)) (s i &environment env)
    422   (make-acode (%nx1-operator %sbchar) (nx1-form s env) (nx1-form i env)))
     476  (make-acode (%nx1-default-operator) (nx1-form :value arg1) (nx1-form :value arg2)))
     477
     478
     479
     480(defnx1 nx1-%misc-ref ((%misc-ref)) context (v i)
     481  (make-acode (%nx1-operator uvref) (nx1-form :value v) (nx1-form :value i)))
     482
     483
     484
     485
     486(defnx1 nx1-schar ((schar)) context (s i &environment env)
     487  (make-acode (%nx1-operator %sbchar) (nx1-form :value s env) (nx1-form :value i env)))
    423488
    424489
    425490;;; This has to be ultra-bizarre because %schar is a macro.
    426491;;; %schar shouldn't be a macro.
    427 (defnx1 nx1-%schar ((%schar)) (arg idx &environment env)
    428   (let* ((arg (nx-transform arg env))
    429          (idx (nx-transform idx env))
    430          (argvar (make-symbol "STRING"))
    431          (idxvar (make-symbol "INDEX")))
    432     (nx1-form `(let* ((,argvar ,arg)
    433                       (,idxvar ,idx))
    434                  (declare (optimize (speed 3) (safety 0)))
    435                  (declare (simple-base-string ,argvar))
    436                  (schar ,argvar ,idxvar)) env)))
     492(defnx1 nx1-%schar ((%schar)) context (arg idx &environment env)
     493        (let* ((arg (nx-transform arg env))
     494               (idx (nx-transform idx env))
     495               (argvar (make-symbol "STRING"))
     496               (idxvar (make-symbol "INDEX")))
     497          (nx1-form context
     498                    `(let* ((,argvar ,arg)
     499                            (,idxvar ,idx))
     500                      (declare (optimize (speed 3) (safety 0)))
     501                      (declare (simple-base-string ,argvar))
     502                      (schar ,argvar ,idxvar)) env)))
    437503       
    438 (defnx1 nx1-%scharcode ((%scharcode)) (arg idx)
    439   (make-acode (%nx1-operator %scharcode) (nx1-form arg)(nx1-form idx)))
    440 
    441 
    442 (defnx1 nx1-svref ((svref) (%svref)) (&environment env v i)
     504(defnx1 nx1-%scharcode ((%scharcode)) context (arg idx)
     505  (make-acode (%nx1-operator %scharcode) (nx1-form :value arg)(nx1-form :value idx)))
     506
     507
     508(defnx1 nx1-svref ((svref) (%svref)) context (&environment env v i)
    443509  (make-acode (if (nx-inhibit-safety-checking env)
    444510                (%nx1-operator %svref)
    445511                (%nx1-default-operator))
    446               (nx1-prefer-areg v env)
    447               (nx1-form i)))
    448 
    449 (defnx1 nx1-%slot-ref ((%slot-ref)) (instance idx)
     512              (nx1-form :value v env)
     513              (nx1-form :value i)))
     514
     515(defnx1 nx1-%slot-ref ((%slot-ref)) context (instance idx)
    450516  (make-acode (%nx1-default-operator)
    451               (nx1-form instance)
    452               (nx1-form idx)))
    453 
    454 
    455 (defnx1 nx1-%err-disp ((%err-disp)) (&rest args)
     517              (nx1-form :value instance)
     518              (nx1-form :value idx)))
     519
     520
     521(defnx1 nx1-%err-disp ((%err-disp)) context (&rest args)
    456522  (make-acode (%nx1-operator %err-disp)
    457523              (nx1-arglist args)))                       
    458524             
    459 (defnx1 nx1-macro-binop ((nth-value)) (arg1 arg2)
    460   (make-acode (%nx1-default-operator) (nx1-form arg1) (nx1-form arg2)))
    461 
    462 (defnx1 nx1-%typed-miscref ((%typed-miscref) (%typed-misc-ref)) (subtype uvector index)
     525(defnx1 nx1-macro-binop ((nth-value)) context (arg1 arg2)
     526  (make-acode (%nx1-default-operator) (nx1-form :value arg1) (nx1-form :value arg2)))
     527
     528(defnx1 nx1-%typed-miscref ((%typed-miscref) (%typed-misc-ref)) context (subtype uvector index)
    463529  (make-acode (%nx1-operator %typed-uvref)
    464                 (nx1-form subtype)
    465                 (nx1-form uvector)
    466                 (nx1-form index)))
    467 
    468 
    469 
    470 (defnx1 nx1-%typed-miscset ((%typed-miscset) (%typed-misc-set)) (subtype uvector index newvalue)
     530                (nx1-form :value subtype)
     531                (nx1-form :value uvector)
     532                (nx1-form :value index)))
     533
     534
     535
     536(defnx1 nx1-%typed-miscset ((%typed-miscset) (%typed-misc-set)) context (subtype uvector index newvalue)
    471537  (make-acode (%nx1-operator %typed-uvset)
    472                 (nx1-form subtype)
    473                 (nx1-form uvector)
    474                 (nx1-form index)
    475                 (nx1-form newvalue)))
    476 
    477 (defnx1 nx1-logior-2 ((logior-2)) (&whole w &environment env arg-1 arg-2)
    478   (nx-binary-boole-op w
     538                (nx1-form :value subtype)
     539                (nx1-form :value uvector)
     540                (nx1-form :value index)
     541                (nx1-form :value newvalue)))
     542
     543(defnx1 nx1-logior-2 ((logior-2)) context (&whole w &environment env arg-1 arg-2)
     544  (nx-binary-boole-op context
     545                      w
    479546                      env
    480547                      arg-1
     
    484551                      (%nx1-operator %natural-logior)))
    485552
    486 (defnx1 nx1-logxor-2 ((logxor-2)) (&whole w &environment env arg-1 arg-2)
    487   (nx-binary-boole-op w
     553(defnx1 nx1-logxor-2 ((logxor-2)) context (&whole w &environment env arg-1 arg-2)
     554  (nx-binary-boole-op context
     555                      w
    488556                      env
    489557                      arg-1
     
    493561                      (%nx1-operator %natural-logxor)))
    494562
    495 (defnx1 nx1-logand-2 ((logand-2)) (&environment env arg-1 arg-2)
     563(defnx1 nx1-logand-2 ((logand-2)) context (&environment env arg-1 arg-2)
    496564  (let* ((nat1 (nx-form-typep arg-1 *nx-target-natural-type* env))
    497565         (nat2 (nx-form-typep arg-2 *nx-target-natural-type* env)))
     
    501569                       *nx-target-fixnum-type*
    502570                       (make-acode (%nx1-operator %ilogand2)
    503                                    (nx1-form arg-1 env)
    504                                    (nx1-form arg-2 env))))
     571                                   (nx1-form :value arg-1 env)
     572                                   (nx1-form :value arg-2 env))))
    505573          ((and nat1 (typep arg-2 'integer))
    506574           (make-acode (%nx1-operator typed-form)
    507575                       *nx-target-natural-type*
    508576                       (make-acode (%nx1-operator %natural-logand)
    509                                    (nx1-form arg-1 env)
    510                                    (nx1-form (logand arg-2
     577                                   (nx1-form :value arg-1 env)
     578                                   (nx1-form :value (logand arg-2
    511579                                                     (1- (ash 1 (target-word-size-case
    512580                                                                 (32 32)
     
    517585                       *nx-target-natural-type*
    518586                       (make-acode (%nx1-operator %natural-logand)
    519                                    (nx1-form arg-2 env)
    520                                    (nx1-form (logand arg-1
     587                                   (nx1-form :value arg-2 env)
     588                                   (nx1-form :value (logand arg-1
    521589                                                     (1- (ash 1 (target-word-size-case
    522590                                                                 (32 32)
     
    527595                       *nx-target-natural-type*
    528596                       (make-acode (%nx1-operator %natural-logand)
    529                                    (nx1-form arg-1 env)
    530                                    (nx1-form arg-2 env))))
     597                                   (nx1-form :value arg-1 env)
     598                                   (nx1-form :value arg-2 env))))
    531599          (t
    532600           (make-acode (%nx1-operator typed-form)
    533601                       'integer
    534602                       (make-acode (%nx1-operator logand2)
    535                                    (nx1-form arg-1 env)
    536                                    (nx1-form arg-2 env)))))))
     603                                   (nx1-form :value arg-1 env)
     604                                   (nx1-form :value arg-2 env)))))))
    537605
    538606
     
    553621                     (require-u32)
    554622                     (require-s64)
    555                      (require-u64))
     623                     (require-u64)) context
    556624        (arg &environment env)
    557625
     
    576644                   (require-s64 '(signed-byte 64))
    577645                   (require-u64 '(unsigned-byte 64)))))
    578       (nx1-form `(the ,type ,arg)))
    579     (make-acode (%nx1-default-operator) (nx1-form arg))))
    580 
    581 (defnx1 nx1-%marker-marker ((%unbound-marker) (%slot-unbound-marker) (%illegal-marker)) ()
     646      (nx1-form context `(the ,type ,arg)))
     647    (make-acode (%nx1-default-operator) (nx1-form :value arg))))
     648
     649(defnx1 nx1-%marker-marker ((%unbound-marker) (%slot-unbound-marker) (%illegal-marker)) context ()
    582650  (make-acode (%nx1-default-operator)))
    583651
    584 (defnx1 nx1-throw (throw) (tag valuesform)
    585   (make-acode (%nx1-operator throw) (nx1-form tag) (nx1-form valuesform)))
     652(defnx1 nx1-throw (throw) context (tag valuesform)
     653  (make-acode (%nx1-operator throw) (nx1-form :value tag) (nx1-form :value valuesform)))
    586654
    587655
     
    600668;;; contain whatever randomness is floating around at the point of
    601669;;; application.)
    602 (defun nx1-destructure (lambda-list bindform cdr-p &whole-allowed-p forms &optional (body-env *nx-lexical-environment*))
     670(defun nx1-destructure (context lambda-list bindform cdr-p &whole-allowed-p forms &optional (body-env *nx-lexical-environment*))
    603671  (let* ((old-env body-env)
    604672         (*nx-bound-vars* *nx-bound-vars*)
    605          (bindform (nx1-form bindform)))
     673         (bindform (nx1-form :value bindform)))
    606674    (if (not (verify-lambda-list lambda-list t &whole-allowed-p))
    607675      (nx-error "Invalid lambda-list ~s" lambda-list)
     
    624692               auxen
    625693               whole
    626                (nx1-env-body body old-env)
     694               (nx1-env-body context body old-env)
    627695               *nx-new-p2decls*
    628696               cdr-p))))))))
     
    630698
    631699
    632 (defnx1 nx1-%setf-macptr ((%setf-macptr)) (ptr newval)
    633   (let* ((arg1 (nx1-form ptr))
    634          (arg2 (nx1-form newval)))
     700(defnx1 nx1-%setf-macptr ((%setf-macptr)) context (ptr newval)
     701  (let* ((arg1 (nx1-form :value ptr))
     702         (arg2 (nx1-form :value newval)))
    635703    (if (and (consp arg1) (eq (%car arg1) (%nx1-operator %consmacptr%)))
    636704      ;e.g. (%setf-macptr (%null-ptr) <foo>)
     
    640708      (make-acode (%nx1-operator %setf-macptr) arg1 arg2))))
    641709
    642 (defnx1 nx1-%setf-double-float ((%setf-double-float)) (double-node double-val)
    643   (make-acode (%nx1-operator %setf-double-float) (nx1-form double-node) (nx1-form double-val)))
    644 
    645 (defnx1 nx1-%setf-short-float ((%setf-short-float) (%setf-single-float)) (short-node short-val)
     710(defnx1 nx1-%setf-double-float ((%setf-double-float)) context (double-node double-val)
     711  (make-acode (%nx1-operator %setf-double-float) (nx1-form :value double-node) (nx1-form :value double-val)))
     712
     713(defnx1 nx1-%setf-short-float ((%setf-short-float) (%setf-single-float)) context (short-node short-val)
    646714  (target-word-size-case
    647715   (32
    648     (make-acode (%nx1-operator %setf-short-float) (nx1-form short-node) (nx1-form short-val)))
     716    (make-acode (%nx1-operator %setf-short-float) (nx1-form :value short-node) (nx1-form :value short-val)))
    649717   (64
    650718    (error "%SETF-SHORT-FLOAT makes no sense on 64-bit platforms."))))
    651719
    652720   
    653 (defnx1 nx1-%inc-ptr ((%inc-ptr)) (ptr &optional (increment 1))
     721(defnx1 nx1-%inc-ptr ((%inc-ptr)) context (ptr &optional (increment 1))
    654722  (make-acode (%nx1-operator %consmacptr%)
    655723              (make-acode (%nx1-operator %immediate-inc-ptr)
    656                           (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
    657                           (nx1-form increment))))
    658 
    659 (defnx1 nx1-svset ((svset) (%svset)) (&environment env vector index value)
     724                          (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptr))
     725                          (nx1-form :value increment))))
     726
     727(defnx1 nx1-svset ((svset) (%svset)) context (&environment env vector index value)
    660728  (make-acode (if (nx-inhibit-safety-checking env)
    661729                (%nx1-operator %svset)
    662730                (%nx1-default-operator))
    663               (nx1-prefer-areg vector env) (nx1-form index) (nx1-form value)))
    664 
    665 (defnx1 nx1-+ ((+-2)) (&environment env num1 num2)
    666   (let* ((f1 (nx1-form num1))
    667          (f2 (nx1-form num2)))
     731              (nx1-form :value vector env) (nx1-form :value index) (nx1-form :value value)))
     732
     733(defnx1 nx1-+ ((+-2)) context (&environment env num1 num2)
     734  (let* ((f1 (nx1-form :value num1))
     735         (f2 (nx1-form :value num2)))
    668736    (if (nx-binary-fixnum-op-p num1 num2 env t)
    669737      (let* ((fixadd (make-acode (%nx1-operator %i+) f1 f2))
     
    678746      (if (and (nx-form-typep num1 'double-float env)
    679747               (nx-form-typep num2 'double-float env))
    680         (nx1-form `(%double-float+-2 ,num1 ,num2))
     748        (nx1-form context `(%double-float+-2 ,num1 ,num2))
    681749        (if (and (nx-form-typep num1 'short-float env)
    682750                 (nx-form-typep num2 'short-float env))
    683           (nx1-form `(%short-float+-2 ,num1 ,num2))
     751          (nx1-form context `(%short-float+-2 ,num1 ,num2))
    684752          (if (nx-binary-natural-op-p num1 num2 env nil)
    685753            (make-acode (%nx1-operator typed-form)
     
    689757                        (make-acode (%nx1-operator add2) f1 f2))))))))
    690758 
    691 (defnx1 nx1-%double-float-x-2 ((%double-float+-2) (%double-float--2) (%double-float*-2) (%double-float/-2 ))
     759(defnx1 nx1-%double-float-x-2 ((%double-float+-2) (%double-float--2) (%double-float*-2) (%double-float/-2 )) context
    692760        (f0 f1)
    693761  (make-acode (%nx1-operator typed-form) 'double-float
    694               (make-acode (%nx1-default-operator) (nx1-form f0) (nx1-form f1))))
    695 
    696 
    697 (defnx1 nx1-%short-float-x-2 ((%short-float+-2) (%short-float--2) (%short-float*-2) (%short-float/-2 ))
     762              (make-acode (%nx1-default-operator) (nx1-form :value f0) (nx1-form :value f1))))
     763
     764
     765(defnx1 nx1-%short-float-x-2 ((%short-float+-2) (%short-float--2) (%short-float*-2) (%short-float/-2 )) context
    698766        (f0 f1)
    699767  (make-acode (%nx1-operator typed-form) 'short-float
    700               (make-acode (%nx1-default-operator) (nx1-form f0) (nx1-form f1))))
    701 
    702 
    703 (defnx1 nx1-*-2 ((*-2)) (&environment env num1 num2)
     768              (make-acode (%nx1-default-operator) (nx1-form :value f0) (nx1-form :value f1))))
     769
     770
     771(defnx1 nx1-*-2 ((*-2)) context (&environment env num1 num2)
    704772  (if (nx-binary-fixnum-op-p num1 num2 env)
    705     (make-acode (%nx1-operator %i*) (nx1-form num1 env) (nx1-form num2 env))
     773    (make-acode (%nx1-operator %i*) (nx1-form :value num1 env) (nx1-form :value num2 env))
    706774    (if (and (nx-form-typep num1 'double-float env)
    707775             (nx-form-typep num2 'double-float env))
    708       (nx1-form `(%double-float*-2 ,num1 ,num2))
     776      (nx1-form context `(%double-float*-2 ,num1 ,num2))
    709777      (if (and (nx-form-typep num1 'short-float env)
    710778               (nx-form-typep num2 'short-float env))
    711         (nx1-form `(%short-float*-2 ,num1 ,num2))
    712         (make-acode (%nx1-operator mul2) (nx1-form num1 env) (nx1-form num2 env))))))
    713 
    714 (defnx1 nx1-%negate ((%negate)) (num &environment env)
     779        (nx1-form context `(%short-float*-2 ,num1 ,num2))
     780        (make-acode (%nx1-operator mul2) (nx1-form :value num1 env) (nx1-form :value num2 env))))))
     781
     782(defnx1 nx1-%negate ((%negate)) context (num &environment env)
    715783  (if (nx-form-typep num 'fixnum env)
    716784    (if (subtypep *nx-form-type* 'fixnum)
    717       (make-acode (%nx1-operator %%ineg)(nx1-form num))
    718       (make-acode (%nx1-operator %ineg) (nx1-form num)))
    719     (let* ((acode (make-acode (%nx1-operator minus1) (nx1-form num env))))
     785      (make-acode (%nx1-operator %%ineg)(nx1-form :value num))
     786      (make-acode (%nx1-operator %ineg) (nx1-form :value num)))
     787    (let* ((acode (make-acode (%nx1-operator minus1) (nx1-form :value num env))))
    720788      (if (nx-form-typep num 'double-float env)
    721789        (make-acode (%nx1-operator typed-form)
     
    731799
    732800       
    733 (defnx1 nx1--2 ((--2)) (&environment env num0 num1)       
     801(defnx1 nx1--2 ((--2)) context (&environment env num0 num1)       
    734802  (if (nx-binary-fixnum-op-p num0 num1 env t)
    735     (let* ((f0 (nx1-form num0))
    736            (f1 (nx1-form num1))
     803    (let* ((f0 (nx1-form :value num0))
     804           (f1 (nx1-form :value num1))
    737805           (fixsub (make-acode (%nx1-operator %i-) f0 f1))
    738806           (small-enough (target-word-size-case
     
    746814    (if (and (nx-form-typep num0 'double-float env)
    747815             (nx-form-typep num1 'double-float env))
    748       (nx1-form `(%double-float--2 ,num0 ,num1))
     816      (nx1-form context `(%double-float--2 ,num0 ,num1))
    749817      (if (and (nx-form-typep num0 'short-float env)
    750818               (nx-form-typep num1 'short-float env))
    751         (nx1-form `(%short-float--2 ,num0 ,num1))
     819        (nx1-form context `(%short-float--2 ,num0 ,num1))
    752820        (if (nx-binary-natural-op-p num0 num1 env nil)
    753821          (make-acode (%nx1-operator %natural-)
    754                       (nx1-form num0)
    755                       (nx1-form num1))
     822                      (nx1-form :value num0)
     823                      (nx1-form :value num1))
    756824          (make-acode (%nx1-operator sub2)
    757                       (nx1-form num0)
    758                       (nx1-form num1)))))))
     825                      (nx1-form :value num0)
     826                      (nx1-form :value num1)))))))
    759827     
    760 (defnx1 nx1-/-2 ((/-2)) (num0 num1 &environment env)
     828(defnx1 nx1-/-2 ((/-2)) context (num0 num1 &environment env)
    761829  (if (and (nx-form-typep num0 'double-float env)
    762830           (nx-form-typep num1 'double-float env))
    763     (nx1-form `(%double-float/-2 ,num0 ,num1))
     831    (nx1-form context `(%double-float/-2 ,num0 ,num1))
    764832    (if (and (nx-form-typep num0 'short-float env)
    765833             (nx-form-typep num1 'short-float env))
    766       (nx1-form `(%short-float/-2 ,num0 ,num1))
    767       (make-acode (%nx1-operator div2) (nx1-form num0) (nx1-form num1)))))
    768 
    769 
    770 
    771 (defnx1 nx1-numcmp ((<-2) (>-2) (<=-2) (>=-2)) (&environment env num1 num2)
     834      (nx1-form context `(%short-float/-2 ,num0 ,num1))
     835      (make-acode (%nx1-operator div2) (nx1-form :value num0) (nx1-form :value num1)))))
     836
     837
     838
     839(defnx1 nx1-numcmp ((<-2) (>-2) (<=-2) (>=-2)) context (&environment env num1 num2)
    772840  (let* ((op *nx-sfname*)
    773841         (both-fixnums (nx-binary-fixnum-op-p num1 num2 env t))
     
    804872              :LE
    805873              :GT))))
    806        (nx1-form num1)
    807        (nx1-form num2))
     874       (nx1-form :value num1)
     875       (nx1-form :value num2))
    808876      (make-acode (%nx1-operator numcmp)
    809877                  (make-acode
     
    816884                         :LE
    817885                         :GT))))
    818                   (nx1-form num1)
    819                   (nx1-form num2)))))
    820 
    821 (defnx1 nx1-num= ((=-2) (/=-2)) (&environment env num1 num2 )
     886                  (nx1-form :value num1)
     887                  (nx1-form :value num2)))))
     888
     889(defnx1 nx1-num= ((=-2) (/=-2)) context (&environment env num1 num2 )
    822890  (let* ((op *nx-sfname*)
    823891         (2-fixnums (nx-binary-fixnum-op-p num1 num2 env t))
     
    844912          :EQ
    845913          :NE))
    846        (nx1-form num1)
    847        (nx1-form num2))
     914       (nx1-form :value num1)
     915       (nx1-form :value num2))
    848916      (if 2-rats
    849917        (let* ((form `(,(if 2-fixnums 'eq 'eql) ,num1 ,num2)))
    850           (nx1-form (if (eq op '=-2) form `(not ,form))))
     918          (nx1-form context (if (eq op '=-2) form `(not ,form))))
    851919        (if (or  2-dfloats 2-sfloats)
    852920          (make-acode
     
    859927              :EQ
    860928              :NE))
    861            (nx1-form num1)
    862            (nx1-form num2))
     929           (nx1-form :value num1)
     930           (nx1-form :value num2))
    863931          (make-acode (%nx1-operator numcmp)
    864932                      (make-acode
     
    867935                         :EQ
    868936                         :NE))
    869                       (nx1-form num1)
    870                       (nx1-form num2)))))))
     937                      (nx1-form :value num1)
     938                      (nx1-form :value num2)))))))
    871939             
    872940
    873 (defnx1 nx1-uvset ((uvset) (%misc-set)) (vector index value)
     941(defnx1 nx1-uvset ((uvset) (%misc-set)) context (vector index value)
    874942  (make-acode (%nx1-operator uvset)
    875               (nx1-form vector)
    876               (nx1-form index)
    877               (nx1-form value)))
    878 
    879 (defnx1 nx1-set-schar ((set-schar)) (s i v)
    880   (make-acode (%nx1-operator %set-sbchar) (nx1-form s) (nx1-form i) (nx1-form v)))
    881 
    882 
    883 
    884 (defnx1 nx1-%set-schar ((%set-schar)) (arg idx char &environment env)
     943              (nx1-form :value vector)
     944              (nx1-form :value index)
     945              (nx1-form :value value)))
     946
     947(defnx1 nx1-set-schar ((set-schar)) context (s i v)
     948  (make-acode (%nx1-operator %set-sbchar) (nx1-form :value s) (nx1-form :value i) (nx1-form :value v)))
     949
     950
     951
     952(defnx1 nx1-%set-schar ((%set-schar)) context (arg idx char &environment env)
    885953  (let* ((arg (nx-transform arg env))
    886954         (idx (nx-transform idx env))
     
    889957         (idxvar (make-symbol "IDX"))
    890958         (charvar (make-symbol "CHAR")))
    891     (nx1-form `(let* ((,argvar ,arg)
     959    (nx1-form context
     960              `(let* ((,argvar ,arg)
    892961                      (,idxvar ,idx)
    893962                      (,charvar ,char))
    894                  (declare (optimize (speed 3) (safety 0)))
    895                  (declare (simple-base-string ,argvar))
    896                  (setf (schar ,argvar ,idxvar) ,charvar))
     963                (declare (optimize (speed 3) (safety 0)))
     964                (declare (simple-base-string ,argvar))
     965                (setf (schar ,argvar ,idxvar) ,charvar))
    897966              env)))
    898967
    899 (defnx1 nx1-%set-scharcode ((%set-scharcode)) (s i v)
     968(defnx1 nx1-%set-scharcode ((%set-scharcode)) context (s i v)
    900969    (make-acode (%nx1-operator %set-scharcode)
    901                 (nx1-form s)
    902                 (nx1-form i)
    903                 (nx1-form v)))
     970                (nx1-form :value s)
     971                (nx1-form :value i)
     972                (nx1-form :value v)))
    904973             
    905974
    906 (defnx1 nx1-list-vector-values ((list) (vector) (values) (%temp-list)) (&rest args)
    907   (make-acode (%nx1-default-operator) (nx1-formlist args)))
    908 
    909 
    910 
    911 (defnx1 nx1-%gvector ( (%gvector)) (&rest args)
     975(defnx1 nx1-list-vector-values ((list) (vector) (values) (%temp-list)) context (&rest args)
     976  (make-acode (%nx1-default-operator) (nx1-formlist context args)))
     977
     978
     979
     980(defnx1 nx1-%gvector ( (%gvector)) context (&rest args)
    912981  (make-acode (%nx1-operator %gvector) (nx1-arglist args)))
    913982
    914 (defnx1 nx1-quote quote (form)
    915   (nx1-immediate form))
    916 
    917 (defnx1 nx1-list* ((list*)) (first &rest rest)
     983(defnx1 nx1-quote quote context (form)
     984  (nx1-immediate context form))
     985
     986(defnx1 nx1-list* ((list*)) context (first &rest rest)
    918987  (make-acode (%nx1-operator list*) (nx1-arglist (cons first rest) 1)))
    919988
    920989
    921990#|
    922 (defnx1 nx1-append ((append)) (&rest args)
     991(defnx1 nx1-append ((append)) context (&rest args)
    923992  (make-acode (%nx1-operator append) (nx1-arglist args 2)))
    924993
     
    926995|#
    927996
    928 (defnx1 nx1-or or (&whole whole &optional (firstform nil firstform-p) &rest moreforms)
     997(defnx1 nx1-or or context (&whole whole &optional (firstform nil firstform-p) &rest moreforms)
    929998  (if (not firstform-p)
    930     (nx1-form nil)
     999    (nx1-form context nil)
    9311000    (if (null moreforms)
    932       (nx1-form firstform)
     1001      (nx1-form context firstform)
    9331002      (progn
    934         (make-acode (%nx1-operator or) (nx1-formlist (%cdr whole)))))))
    935 
    936 (defun nx1-1d-vref (env arr dim0 &optional uvref-p)
     1003        (make-acode (%nx1-operator or) (nx1-formlist context (%cdr whole)))))))
     1004
     1005(defun nx1-1d-vref (context env arr dim0 &optional uvref-p)
    9371006  (let* ((simple-vector-p (nx-form-typep arr 'simple-vector env))
    9381007         (string-p (unless simple-vector-p
    9391008                     (if (nx-form-typep arr 'string env)
    9401009                       (or (nx-form-typep arr 'simple-string env)
    941                            (return-from nx1-1d-vref (nx1-form `(char ,arr ,dim0)))))))
     1010                           (return-from nx1-1d-vref (nx1-form context `(char ,arr ,dim0)))))))
    9421011         (simple-1d-array-p (unless (or simple-vector-p string-p)
    9431012                              (nx-form-typep arr '(simple-array * (*)) env)))
     
    9501019    (if (and simple-1d-array-p type-keyword)
    9511020      (make-acode (%nx1-operator %typed-uvref)
    952                   (nx1-immediate type-keyword)
    953                   (nx1-form arr)
    954                   (nx1-form dim0))
     1021                  (nx1-immediate :value type-keyword)
     1022                  (nx1-form :value arr)
     1023                  (nx1-form :value dim0))
    9551024      (let* ((op (cond (simple-1d-array-p (%nx1-operator uvref))
    9561025                       (string-p (%nx1-operator %sbchar))
     
    9591028                       (uvref-p (%nx1-operator uvref))
    9601029                       (t (%nx1-operator %aref1)))))
    961         (make-acode op (nx1-form arr) (nx1-form dim0))))))
     1030        (make-acode op (nx1-form :value arr) (nx1-form :value dim0))))))
    9621031 
    963 (defnx1 nx1-aref ((aref)) (&whole whole &environment env arr &optional (dim0 nil dim0-p)
     1032(defnx1 nx1-aref ((aref)) context (&whole whole &environment env arr &optional (dim0 nil dim0-p)
    9641033                                  &rest other-dims)
    9651034   (if (and dim0-p (null other-dims))
    966      (nx1-1d-vref env arr dim0)
    967      (nx1-treat-as-call whole)))
    968 
    969 (defnx1 nx1-uvref ((uvref)) (&environment env arr dim0)
    970   (nx1-1d-vref env arr dim0 t))
    971 
    972 (defnx1 nx1-%aref2 ((%aref2)) (&whole whole &environment env arr i j)
     1035     (nx1-1d-vref context env arr dim0)
     1036     (nx1-treat-as-call context whole)))
     1037
     1038(defnx1 nx1-uvref ((uvref)) context (&environment env arr dim0)
     1039  (nx1-1d-vref context env arr dim0 t))
     1040
     1041(defnx1 nx1-%aref2 ((%aref2)) context (&whole whole &environment env arr i j)
    9731042  ;; Bleah.  Breaks modularity.  Specialize later.
    9741043  (target-arch-case
    9751044   (:x8632
    976     (return-from nx1-%aref2 (nx1-treat-as-call whole))))
     1045    (return-from nx1-%aref2 (nx1-treat-as-call context whole))))
    9771046
    9781047  (let* ((arch (backend-target-arch *target-backend*))
     
    9911060             (dim1 (cadr dims)))
    9921061        (make-acode (%nx1-operator simple-typed-aref2)
    993                     (nx1-form type-keyword)
    994                     (nx1-form arr)
    995                     (nx1-form i)
    996                     (nx1-form j)
    997                     (nx1-form (if (typep dim0 'fixnum) dim0))
    998                     (nx1-form (if (typep dim1 'fixnum) dim1))))
     1062                    (nx1-form :value type-keyword)
     1063                    (nx1-form :value arr)
     1064                    (nx1-form :value i)
     1065                    (nx1-form :value j)
     1066                    (nx1-form :value (if (typep dim0 'fixnum) dim0))
     1067                    (nx1-form :value (if (typep dim1 'fixnum) dim1))))
    9991068      (make-acode (%nx1-operator general-aref2)
    1000                   (nx1-form arr)
    1001                   (nx1-form i)
    1002                   (nx1-form j)))))
    1003 
    1004 (defnx1 nx1-%aref3 ((%aref3)) (&whole whole &environment env arr i j k)
     1069                  (nx1-form :value arr)
     1070                  (nx1-form :value i)
     1071                  (nx1-form :value j)))))
     1072
     1073(defnx1 nx1-%aref3 ((%aref3)) context (&whole whole &environment env arr i j k)
    10051074  ;; Bleah.  Breaks modularity.  Specialize later.
    10061075  (target-arch-case
    10071076   (:x8632
    1008     (return-from nx1-%aref3 (nx1-treat-as-call whole))))
     1077    (return-from nx1-%aref3 (nx1-treat-as-call context whole))))
    10091078
    10101079  (let* ((arch (backend-target-arch *target-backend*))
     
    10241093             (dim2 (caddr dims)))
    10251094        (make-acode (%nx1-operator simple-typed-aref3)
    1026                     (nx1-form type-keyword)
    1027                     (nx1-form arr)
    1028                     (nx1-form i)
    1029                     (nx1-form j)
    1030                     (nx1-form k)
    1031                     (nx1-form (if (typep dim0 'fixnum) dim0))
    1032                     (nx1-form (if (typep dim1 'fixnum) dim1))
    1033                     (nx1-form (if (typep dim2 'fixnum) dim2))))
     1095                    (nx1-form :value type-keyword)
     1096                    (nx1-form :value arr)
     1097                    (nx1-form :value i)
     1098                    (nx1-form :value j)
     1099                    (nx1-form :value k)
     1100                    (nx1-form :value (if (typep dim0 'fixnum) dim0))
     1101                    (nx1-form :value (if (typep dim1 'fixnum) dim1))
     1102                    (nx1-form :value (if (typep dim2 'fixnum) dim2))))
    10341103      (make-acode (%nx1-operator general-aref3)
    1035                   (nx1-form arr)
    1036                   (nx1-form i)
    1037                   (nx1-form j)
    1038                   (nx1-form k)))))
    1039 
    1040 (defun nx1-1d-vset (arr newval dim0 env)
     1104                  (nx1-form :value arr)
     1105                  (nx1-form :value i)
     1106                  (nx1-form :value j)
     1107                  (nx1-form :value k)))))
     1108
     1109(defun nx1-1d-vset (context arr newval dim0 env)
    10411110  (let* ((simple-vector-p (nx-form-typep arr 'simple-vector env))
    10421111         (string-p (unless simple-vector-p
    10431112                     (if (nx-form-typep arr 'string env)
    10441113                       (or (nx-form-typep arr 'simple-string env)
    1045                            (return-from nx1-1d-vset (nx1-form `(set-char ,arr ,newval ,dim0)))))))
     1114                           (return-from nx1-1d-vset (nx1-form context `(set-char ,arr ,newval ,dim0)))))))
    10461115         (simple-1d-array-p (unless (or simple-vector-p string-p)
    10471116                              (nx-form-typep arr '(simple-array * (*)) env)))
     
    10531122         (if (and type-keyword simple-1d-array-p)
    10541123             (make-acode (%nx1-operator %typed-uvset)
    1055                          (nx1-immediate type-keyword)
    1056                          (nx1-form arr)
    1057                          (nx1-form newval)
    1058                          (nx1-form dim0))
     1124                         (nx1-immediate :value type-keyword)
     1125                         (nx1-form :value arr)
     1126                         (nx1-form :value newval)
     1127                         (nx1-form :value dim0))
    10591128             (let* ((op (cond (simple-1d-array-p (%nx1-operator uvset))
    10601129                              (string-p (%nx1-operator %set-sbchar))
     
    10641133                   (make-acode
    10651134                    op
    1066                     (nx1-form arr)
    1067                     (nx1-form newval)
    1068                     (nx1-form dim0))
    1069                    (nx1-form `(,(if string-p 'set-schar '%aset1) ,arr ,newval ,dim0)))))))
    1070 
    1071 (defnx1 nx1-aset ((aset)) (&whole whole
     1135                    (nx1-form :value arr)
     1136                    (nx1-form :value newval)
     1137                    (nx1-form :value dim0))
     1138                   (nx1-form context `(,(if string-p 'set-schar '%aset1) ,arr ,newval ,dim0)))))))
     1139
     1140(defnx1 nx1-aset ((aset)) context (&whole whole
    10721141                                  arr newval
    10731142                                  &optional (dim0 nil dim0-p)
     
    10751144                                  &rest other-dims)
    10761145   (if (and dim0-p (null other-dims))
    1077        (nx1-1d-vset arr newval dim0 env)
    1078        (nx1-treat-as-call whole)))
     1146       (nx1-1d-vset context arr newval dim0 env)
     1147       (nx1-treat-as-call context whole)))
    10791148           
    1080 (defnx1 nx1-%aset2 ((%aset2)) (&whole whole &environment env arr i j new)
     1149(defnx1 nx1-%aset2 ((%aset2)) context (&whole whole &environment env arr i j new)
    10811150  ;; Bleah.  Breaks modularity.  Specialize later.
    10821151  (target-arch-case
    10831152   (:x8632
    1084     (return-from nx1-%aset2 (nx1-treat-as-call whole))))
     1153    (return-from nx1-%aset2 (nx1-treat-as-call context whole))))
    10851154
    10861155  (let* ((arch (backend-target-arch *target-backend*))
     
    11001169             (dim1 (cadr dims)))
    11011170        (make-acode (%nx1-operator simple-typed-aset2)
    1102                     (nx1-form type-keyword)
    1103                     (nx1-form arr)
    1104                     (nx1-form i)
    1105                     (nx1-form j)
    1106                     (nx1-form new)
    1107                     (nx1-form (if (typep dim0 'fixnum) dim0))
    1108                     (nx1-form (if (typep dim1 'fixnum) dim1))))
     1171                    (nx1-form :value type-keyword)
     1172                    (nx1-form :value arr)
     1173                    (nx1-form :value i)
     1174                    (nx1-form :value j)
     1175                    (nx1-form :value new)
     1176                    (nx1-form :value (if (typep dim0 'fixnum) dim0))
     1177                    (nx1-form :value (if (typep dim1 'fixnum) dim1))))
    11091178            (make-acode (%nx1-operator general-aset2)
    1110                   (nx1-form arr)
    1111                   (nx1-form i)
    1112                   (nx1-form j)
    1113                   (nx1-form new)))))
    1114 
    1115 (defnx1 nx1-%aset3 ((%aset3)) (&whole whole &environment env arr i j k new)
     1179                  (nx1-form :value arr)
     1180                  (nx1-form :value i)
     1181                  (nx1-form :value j)
     1182                  (nx1-form :value new)))))
     1183
     1184(defnx1 nx1-%aset3 ((%aset3)) context (&whole whole &environment env arr i j k new)
    11161185  ;; Bleah.  Breaks modularity.  Specialize later.
    11171186  (target-arch-case
    11181187   (:x8632
    1119     (return-from nx1-%aset3 (nx1-treat-as-call whole))))
     1188    (return-from nx1-%aset3 (nx1-treat-as-call context whole))))
    11201189
    11211190  (let* ((arch (backend-target-arch *target-backend*))
     
    11361205             (dim2 (caddr dims)))
    11371206        (make-acode (%nx1-operator simple-typed-aset3)
    1138                     (nx1-form type-keyword)
    1139                     (nx1-form arr)
    1140                     (nx1-form i)
    1141                     (nx1-form j)
    1142                     (nx1-form k)
    1143                     (nx1-form new)
    1144                     (nx1-form (if (typep dim0 'fixnum) dim0))
    1145                     (nx1-form (if (typep dim1 'fixnum) dim1))
    1146                     (nx1-form (if (typep dim2 'fixnum) dim2))))
     1207                    (nx1-form :value type-keyword)
     1208                    (nx1-form :value arr)
     1209                    (nx1-form :value i)
     1210                    (nx1-form :value j)
     1211                    (nx1-form :value k)
     1212                    (nx1-form :value new)
     1213                    (nx1-form :value (if (typep dim0 'fixnum) dim0))
     1214                    (nx1-form :value (if (typep dim1 'fixnum) dim1))
     1215                    (nx1-form :value (if (typep dim2 'fixnum) dim2))))
    11471216            (make-acode (%nx1-operator general-aset3)
    1148                   (nx1-form arr)
    1149                   (nx1-form i)
    1150                   (nx1-form j)
    1151                   (nx1-form k)
    1152                   (nx1-form new)))))
    1153 
    1154 (defnx1 nx1-prog1 (prog1 multiple-value-prog1) (save &body args
    1155                                                      &aux (l (list (nx1-form save))))
    1156   (make-acode
    1157    (%nx1-default-operator)
    1158    (dolist (arg args (nreverse l))
    1159      (push (nx1-form arg) l))))
    1160 
    1161 (defnx1 nx1-if if (test true &optional false)
     1217                  (nx1-form :value arr)
     1218                  (nx1-form :value i)
     1219                  (nx1-form :value j)
     1220                  (nx1-form :value k)
     1221                  (nx1-form :value new)))))
     1222
     1223(defnx1 nx1-prog1 (prog1 multiple-value-prog1) context (save &body args)
     1224  (let* ((l (list (nx1-form :value save))))
     1225    (make-acode
     1226     (%nx1-default-operator)
     1227     (dolist (arg args (nreverse l))
     1228       (push (nx1-form nil arg) l)))))
     1229
     1230(defnx1 nx1-if if context (test true &optional false)
    11621231  (if (null true)
    11631232    (if (null false)
    1164       (return-from nx1-if (nx1-form `(progn ,test nil)))
     1233      (return-from nx1-if (nx1-form context `(progn ,test nil)))
    11651234      (psetq test `(not ,test) true false false true)))
    1166   (let ((test-form (nx1-form test))
     1235  (let ((test-form (nx1-form :value test))
    11671236        ;; Once hit a conditional, no more duplicate warnings
    11681237        (*compiler-warn-on-duplicate-definitions* nil))
    1169     (make-acode (%nx1-operator if) test-form (nx1-form true) (nx1-form false))))
    1170 
    1171 (defnx1 nx1-%debug-trap dbg (&optional arg)
    1172   (make-acode (%nx1-operator %debug-trap) (nx1-form arg)))
     1238    (make-acode (%nx1-operator if) test-form (nx1-form context true) (nx1-form context false))))
     1239
     1240(defnx1 nx1-%debug-trap dbg context (&optional arg)
     1241  (make-acode (%nx1-operator %debug-trap) (nx1-form :value arg)))
    11731242       
    1174 (defnx1 nx1-setq setq (&whole whole &rest args &environment env &aux res)
     1243(defnx1 nx1-setq setq context (&whole whole &rest args &environment env &aux res)
    11751244  (when (%ilogbitp 0 (length args))
    11761245    (nx-error "Odd number of forms in ~s ." whole))
     
    11861255      (multiple-value-bind (expansion win) (macroexpand-1 sym env)
    11871256        (if win
    1188             (push (nx1-form `(setf ,expansion ,val)) res)
     1257            (push (nx1-form context `(setf ,expansion ,val)) res)
    11891258            (multiple-value-bind (info inherited catchp)
    11901259                (nx-lex-info sym)
     
    11971266                                       (%ilsl $vbitreffed 1)
    11981267                                       (nx-var-bits catchp)))
    1199                      (nx1-form `(setf ,inherited ,val)))
     1268                     (nx1-form context `(setf ,inherited ,val)))
    12001269                   (let ((valtype (nx-form-type val env)))
    12011270                     (let ((*nx-form-type* declared-type))
    1202                        (setq val (nx1-typed-form val env)))
     1271                       (setq val (nx1-typed-form context val env)))
    12031272                     (if (and info (neq info :special))
    12041273                         (progn
     
    12561325;;; in a null lexical environment.
    12571326
    1258 (defnx1 nx1-load-time-value (load-time-value) (&environment env form &optional read-only-p)
     1327(defnx1 nx1-load-time-value (load-time-value) context (&environment env form &optional read-only-p)
    12591328  ;; Validate the "read-only-p" argument
    12601329  (if (and read-only-p (neq read-only-p t)) (require-type read-only-p '(member t nil)))
     
    12691338                          :target (backend-name *target-backend*))
    12701339      (setq *nx-warnings* (append *nx-warnings* warnings))
    1271       (nx1-immediate (list *nx-load-time-eval-token* `(funcall ,function))))
    1272     (nx1-immediate (eval form))))
    1273 
    1274 (defnx1 nx1-catch (catch) (operation &body body)
    1275   (make-acode (%nx1-operator catch) (nx1-form operation) (nx1-catch-body body)))
    1276 
    1277 (defnx1 nx1-%badarg ((%badarg)) (badthing right-type &environment env)
    1278   (make-acode (%nx1-operator %badarg2)
    1279               (nx1-form badthing)
    1280               (nx1-form (or (if (nx-form-constant-p right-type env) (%typespec-id (nx-form-constant-value right-type env)))
    1281                             right-type))))
    1282 
    1283 (defnx1 nx1-unwind-protect (unwind-protect) (protected-form &body cleanup-form)
    1284   (if cleanup-form
    1285     (make-acode (%nx1-operator unwind-protect)
    1286                 (nx1-catch-body (list protected-form))
    1287                 (nx1-progn-body cleanup-form))
    1288     (nx1-form protected-form)))
    1289 
    1290 (defnx1 nx1-progv progv (symbols values &body body)
    1291   (make-acode (%nx1-operator progv)
    1292               (nx1-form `(check-symbol-list ,symbols))
    1293               (nx1-form values)
    1294               (nx1-catch-body body)))
    1295 
    1296 (defun nx1-catch-body (body)
     1340      (nx1-immediate context (list *nx-load-time-eval-token* `(funcall ,function))))
     1341    (nx1-immediate context (eval form))))
     1342
     1343(defun nx1-catch-body (context body)
    12971344  (let* ((temp (new-lexical-environment *nx-lexical-environment*)))
    12981345    (setf (lexenv.variables temp) 'catch)
    12991346    (let* ((*nx-lexical-environment* (new-lexical-environment temp)))
    1300       (nx1-progn-body body))))
    1301 
    1302 
    1303 (defnx1 nx1-apply ((apply)) (&whole call fn arg &rest args &environment env)
    1304   (let ((last (%car (last (push arg args)))))
    1305     (if (and (nx-form-constant-p last env)
    1306              (null (nx-form-constant-value last env)))
    1307       (nx1-form (let ((new `(funcall ,fn ,@(butlast args))))
    1308                   (nx-note-source-transformation call new)
    1309                   new))
    1310       (nx1-apply-fn fn args t))))
    1311 
    1312 (defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (fn arg &rest args)
    1313   (nx1-apply-fn fn (cons arg args) 0))
    1314 
    1315 (defun nx1-apply-fn (fn args spread)
     1347      (nx1-progn-body context body))))
     1348
     1349(defnx1 nx1-catch (catch) context (operation &body body)
     1350  (make-acode (%nx1-operator catch) (nx1-form :value operation) (nx1-catch-body context body)))
     1351
     1352(defnx1 nx1-%badarg ((%badarg)) context (badthing right-type &environment env)
     1353  (make-acode (%nx1-operator %badarg2)
     1354              (nx1-form :value badthing)
     1355              (nx1-form :value (or (if (nx-form-constant-p right-type env) (%typespec-id (nx-form-constant-value right-type env)))
     1356                            right-type))))
     1357
     1358(defnx1 nx1-unwind-protect (unwind-protect) context (protected-form &body cleanup-form)
     1359  (if cleanup-form
     1360    (make-acode (%nx1-operator unwind-protect)
     1361                (nx1-catch-body context (list protected-form))
     1362                (nx1-progn-body context cleanup-form))
     1363    (nx1-form context protected-form)))
     1364
     1365(defnx1 nx1-progv progv context (symbols values &body body)
     1366  (make-acode (%nx1-operator progv)
     1367              (nx1-form :value `(check-symbol-list ,symbols))
     1368              (nx1-form :value values)
     1369              (nx1-catch-body context body)))
     1370
     1371
     1372(defun nx1-apply-fn (context fn args spread)
    13161373  (let* ((sym (nx1-func-name fn))
    13171374         (afunc (and (non-nil-symbol-p sym) (nth-value 1 (nx-lexical-finfo sym)))))
     
    13241381            sym nil
    13251382            args (cons (var-name *nx-next-method-var*) args)))
    1326     (nx1-typed-call (if (non-nil-symbol-p sym) sym (nx1-form fn)) args spread)))
    1327 
    1328 
    1329 (defnx1 nx1-%defun %defun (&whole w def &optional (doc nil doc-p) &environment env)
     1383    (nx1-typed-call context (if (non-nil-symbol-p sym) sym (nx1-form :value fn)) args spread)))
     1384
     1385
     1386(defnx1 nx1-apply ((apply)) context (&whole call fn arg &rest args &environment env)
     1387  (let ((last (%car (last (push arg args)))))
     1388    (if (and (nx-form-constant-p last env)
     1389             (null (nx-form-constant-value last env)))
     1390      (nx1-form context (let ((new `(funcall ,fn ,@(butlast args))))
     1391                  (nx-note-source-transformation call new)
     1392                  new))
     1393      (nx1-apply-fn context fn args t))))
     1394
     1395(defnx1 nx1-%apply-lexpr ((%apply-lexpr)) context (fn arg &rest args)
     1396  (nx1-apply-fn context fn (cons arg args) 0))
     1397
     1398
     1399
     1400
     1401(defnx1 nx1-%defun %defun context (&whole w def &optional (doc nil doc-p) &environment env)
    13301402  (declare (ignorable doc doc-p))
    1331   ; Pretty bogus.
     1403  ;; Pretty bogus.
    13321404  (if (and (consp def)
    13331405           (eq (%car def) 'nfunction)
     
    13351407           (or (symbolp (%cadr def)) (setf-function-name-p (%cadr def))))
    13361408    (note-function-info (%cadr def) (caddr def) env))
    1337   (nx1-treat-as-call w))
    1338 
    1339 (defnx1 nx1-function function (arg &aux fn afunc)
     1409  (nx1-treat-as-call context w))
     1410
     1411(defnx1 nx1-function function context (arg &aux fn afunc)
    13401412  (cond ((symbolp arg)
    13411413         (when (macro-function arg *nx-lexical-environment*)
     
    13491421               (when (%ilogbitp $fbitbounddownward (afunc-bits afunc))
    13501422                 (incf (afunc-fn-downward-refcount afunc))))
    1351              (nx1-symbol (%cddr fn)))
     1423             (nx1-symbol context (%cddr fn)))
    13521424           (progn
    13531425             (while (setq fn (assq arg *nx-synonyms*))
    13541426               (setq arg (%cdr fn)))
    1355              (nx1-form `(%function ',arg)))))
     1427             (nx1-form context `(%function ',arg)))))
    13561428        ((setf-function-name-p arg)
    1357          (nx1-form `(function ,(nx-need-function-name arg))))
     1429         (nx1-form context `(function ,(nx-need-function-name arg))))
    13581430        ((lambda-expression-p arg)
    13591431         (nx1-ref-inner-function nil arg))
     
    13611433         (nx-error "~S is not a function name or lambda expression" arg))))
    13621434
    1363 (defnx1 nx1-nfunction nfunction (name def)
     1435(defnx1 nx1-nfunction nfunction context (name def)
    13641436 (nx1-ref-inner-function name def))
    13651437
     
    13961468             afunc)))))
    13971469   
    1398 (defnx1 nx1-%function %function (form &aux symbol)
    1399   (let ((sym (nx1-form form)))
     1470(defnx1 nx1-%function %function context (form &aux symbol)
     1471  (let ((sym (nx1-form :value form)))
    14001472    (if (and (eq (car sym) (%nx1-operator immediate))
    14011473             (setq symbol (cadr sym))
     
    14071479          (nx1-whine :undefined-function symbol))
    14081480        (make-acode (%nx1-default-operator) symbol))
    1409       (make-acode (%nx1-operator call) (nx1-immediate '%function) (list nil (list sym))))))
    1410 
    1411 (defnx1 nx1-tagbody tagbody (&rest args)
     1481      (make-acode (%nx1-operator call) (nx1-immediate context '%function) (list nil (list sym))))))
     1482
     1483(defnx1 nx1-tagbody tagbody context (&rest args)
    14121484  (let* ((newtags nil)
    14131485         (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*))
     
    14401512             (%rplaca (%cdr (%cdr (%cdr (%cdr info)))) t)
    14411513             (cons (%nx1-operator tag-label) info))
    1442            (nx1-form form))
     1514           (nx1-form nil form))
    14431515         body))
    14441516      (if (eq 0 (%car counter))
     
    14511523            (when (%cadr tag)
    14521524              (push 
    1453                (nx1-form `(if (eql ,(var-name indexvar) ,(%cadr tag)) (go ,(%car tag))))
     1525               (nx1-form context `(if (eql ,(var-name indexvar) ,(%cadr tag)) (go ,(%car tag))))
    14541526               body)))
    14551527          (make-acode
     
    14691541               (make-acode
    14701542                (%nx1-operator catch)
    1471                 (nx1-form (var-name catchvar))
     1543                (nx1-form :value (var-name catchvar))
    14721544                (make-acode
    14731545                 (%nx1-operator local-tagbody)
     
    14801552
    14811553
    1482 (defnx1 nx1-go go (tag)
     1554(defnx1 nx1-go go context (tag)
    14831555  (multiple-value-bind (info closed)
    14841556                       (nx-tag-info tag)
     
    14921564
    14931565        (make-acode
    1494          (%nx1-operator throw) (nx1-symbol (var-name (cadddr info))) (nx1-form closed))))))
     1566         (%nx1-operator throw) (nx1-symbol :value (var-name (cadddr info))) (nx1-form :value closed))))))
    14951567
    14961568
     
    15121584    :hybrid-int-float :hybrid-float-int :hybrid-float-float))
    15131585
    1514 
    1515 (defnx1 nx1-ff-call ((%ff-call)) (address-expression &rest arg-specs-and-result-spec)
    1516    (nx1-ff-call-internal
    1517     address-expression arg-specs-and-result-spec
    1518     (ecase (backend-name *target-backend*)
    1519       ((:linuxppc32 :linuxarm :darwinarm :androidarm) (%nx1-operator eabi-ff-call))
    1520       ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1-operator poweropen-ff-call))
    1521       ((:darwinx8632 :linuxx8632 :win32 :solarisx8632 :freebsdx8632) (%nx1-operator i386-ff-call))
    1522       ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator ff-call)))))
    1523 
    1524 (defnx1 nx1-syscall ((%syscall)) (idx &rest arg-specs-and-result-spec)
    1525   (flet ((map-to-representation-types (list)
    1526            (collect ((out))
    1527              (do* ((l list (cddr l)))
    1528                   ((null (cdr l))
    1529                    (if l
    1530                      (progn
    1531                        (out (foreign-type-to-representation-type (car l)))
    1532                        (out))
    1533                      (error "Missing result type in ~s" list)))
    1534                (out (foreign-type-to-representation-type (car l)))
    1535                (out (cadr l))))))
    1536           (nx1-ff-call-internal
    1537            idx (map-to-representation-types arg-specs-and-result-spec)
    1538            (ecase (backend-name *target-backend*)
    1539              (:linuxppc32 (%nx1-operator eabi-syscall))
    1540              ((:darwinppc32 :darwinppc64 :linuxppc64)
    1541               (%nx1-operator poweropen-syscall))
    1542              ((:darwinx8632 :linuxx632 :win32) (%nx1-operator i386-syscall))
    1543              ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator syscall))))))
    1544 
    1545 (defun nx1-ff-call-internal (address-expression arg-specs-and-result-spec operator )
     1586(defun nx1-ff-call-internal (context address-expression arg-specs-and-result-spec operator )
     1587  (declare (ignorable context))
    15461588  (let* ((specs ())         
    15471589         (vals ())
     
    15861628                  (t t))
    15871629                (make-acode operator
    1588                             (nx1-form address-expression)
     1630                            (nx1-form :value address-expression)
    15891631                            (nreverse specs)
    1590                             (mapcar #'nx1-form (nreverse vals))
     1632                            (mapcar (lambda (val) (nx1-form :value val)) (nreverse vals))
    15911633                            result-spec
    15921634                            nil)
    15931635                nil)))
     1636
     1637(defnx1 nx1-ff-call ((%ff-call)) context (address-expression &rest arg-specs-and-result-spec)
     1638   (nx1-ff-call-internal
     1639    context address-expression arg-specs-and-result-spec
     1640    (ecase (backend-name *target-backend*)
     1641      ((:linuxppc32 :linuxarm :darwinarm :androidarm) (%nx1-operator eabi-ff-call))
     1642      ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1-operator poweropen-ff-call))
     1643      ((:darwinx8632 :linuxx8632 :win32 :solarisx8632 :freebsdx8632) (%nx1-operator i386-ff-call))
     1644      ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator ff-call)))))
     1645
     1646(defnx1 nx1-syscall ((%syscall)) context (idx &rest arg-specs-and-result-spec)
     1647  (flet ((map-to-representation-types (list)
     1648           (collect ((out))
     1649             (do* ((l list (cddr l)))
     1650                  ((null (cdr l))
     1651                   (if l
     1652                     (progn
     1653                       (out (foreign-type-to-representation-type (car l)))
     1654                       (out))
     1655                     (error "Missing result type in ~s" list)))
     1656               (out (foreign-type-to-representation-type (car l)))
     1657               (out (cadr l))))))
     1658          (nx1-ff-call-internal
     1659           context
     1660           idx (map-to-representation-types arg-specs-and-result-spec)
     1661           (ecase (backend-name *target-backend*)
     1662             (:linuxppc32 (%nx1-operator eabi-syscall))
     1663             ((:darwinppc32 :darwinppc64 :linuxppc64)
     1664              (%nx1-operator poweropen-syscall))
     1665             ((:darwinx8632 :linuxx632 :win32) (%nx1-operator i386-syscall))
     1666             ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator syscall))))))
     1667
     1668
    15941669 
    1595 (defnx1 nx1-block block (blockname &body forms)
     1670(defnx1 nx1-block block context (blockname &body forms)
    15961671  (let* ((*nx-blocks* *nx-blocks*)
    15971672         (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*))
    15981673         (*nx-bound-vars* *nx-bound-vars*)
    15991674         (tagvar (nx-new-temp-var (make-pending-declarations)))
    1600          (thisblock (cons (setq blockname (nx-need-sym blockname)) tagvar))
     1675         (thisblock (cons (setq blockname (nx-need-sym blockname)) (cons tagvar context)))
    16011676         (body nil))
    16021677    (push thisblock *nx-blocks*)
    1603     (setq body (nx1-progn-body forms))
     1678    (setq body (nx1-progn-body context forms))
    16041679    (%rplacd thisblock nil)
    16051680    (let ((tagbits (nx-var-bits tagvar)))
     
    16201695            (%nx1-operator let)
    16211696            (list tagvar)
    1622             (list (make-acode (%nx1-operator cons) (nx1-form nil) (nx1-form nil)))
     1697            (list (make-acode (%nx1-operator cons) (nx1-form :value nil) (nx1-form :value nil)))
    16231698            (make-acode
    16241699             (%nx1-operator catch)
     
    16271702            0)))))))
    16281703
    1629 (defnx1 nx1-return-from return-from (blockname &optional value)
     1704(defnx1 nx1-return-from return-from context (blockname &optional value)
    16301705  (multiple-value-bind (info closed)
    1631                        (nx-block-info (setq blockname (nx-need-sym blockname)))
     1706      (nx-block-info (setq blockname (nx-need-sym blockname)))
    16321707    (unless info (nx-error "Can't RETURN-FROM block : ~S." blockname))
    1633     (unless closed (nx-adjust-ref-count (cdr info)))
    1634     (make-acode
    1635      (if closed
    1636        (%nx1-operator throw)
    1637        (%nx1-operator local-return-from))
    1638      (if closed
    1639        (nx1-symbol (var-name (cdr info)))
    1640        info)
    1641      (nx1-form value))))
    1642 
    1643 (defnx1 nx1-funcall ((funcall)) (&whole call func &rest args &environment env)
     1708    (destructuring-bind (var . block-context) (cdr info)
     1709      (unless closed (nx-adjust-ref-count var))
     1710      (make-acode
     1711       (if closed
     1712         (%nx1-operator throw)
     1713         (%nx1-operator local-return-from))
     1714       (if closed
     1715         (nx1-symbol context (var-name var ))
     1716         info)
     1717     (nx1-form (if closed :value block-context) value)))))
     1718
     1719(defnx1 nx1-funcall ((funcall)) context (&whole call func &rest args &environment env)
    16441720  (let ((name (nx1-func-name func)))
    16451721    (if (or (null name)
    16461722            (and (symbolp name) (macro-function name env)))
    1647       (nx1-typed-call (nx1-form func) args nil)
     1723      (nx1-typed-call context (nx1-form :value func) args nil)
    16481724      (progn
    16491725        (when (consp name) ;; lambda expression
    16501726          (nx-note-source-transformation func name))
    16511727        ;; This picks up call-next-method evil.
    1652         (nx1-form (let ((new-form (cons name args)))
    1653                     (nx-note-source-transformation call new-form)
    1654                     new-form))))))
    1655 
    1656 (defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args)
     1728        (nx1-form context (let ((new-form (cons name args)))
     1729                            (nx-note-source-transformation call new-form)
     1730                            new-form))))))
     1731
     1732(defnx1 nx1-multiple-value-call multiple-value-call context (value-form &rest args)
    16571733  (make-acode (%nx1-default-operator)
    1658               (nx1-form value-form)
    1659               (nx1-formlist args)))
    1660 
    1661 (defnx1 nx1-compiler-let compiler-let (bindings &body forms)
     1734              (nx1-form :value value-form)
     1735              (nx1-formlist context args)))
     1736
     1737(defnx1 nx1-compiler-let compiler-let context (bindings &body forms)
    16621738  (let* ((vars nil)
    16631739         (varinits nil))
     
    16651741      (push (nx-pair-name pair) vars)
    16661742      (push (eval (nx-pair-initform pair)) varinits))
    1667    (progv (nreverse vars) (nreverse varinits) (nx1-catch-body forms))))
    1668 
    1669 (defnx1 nx1-fbind fbind (fnspecs &body body &environment old-env)
     1743   (progv (nreverse vars) (nreverse varinits) (nx1-catch-body context forms))))
     1744
     1745(defnx1 nx1-fbind fbind context (fnspecs &body body &environment old-env)
    16701746  (let* ((fnames nil)
    16711747         (vars nil)
     
    16741750      (destructuring-bind (fname initform) spec
    16751751        (push (setq fname (nx-need-function-name fname)) fnames)
    1676         (push (nx1-form initform) vals)))
     1752        (push (nx1-form :value initform) vals)))
    16771753    (let* ((new-env (new-lexical-environment old-env))
    16781754           (*nx-bound-vars* *nx-bound-vars*)
     
    16921768       vars
    16931769       vals
    1694        (nx1-env-body body old-env)
     1770       (nx1-env-body context body old-env)
    16951771       *nx-new-p2decls*))))
    16961772
     
    17001776    (nx1-whine :special-fbinding funcname)))
    17011777
    1702 (defnx1 nx1-flet flet (defs &body forms)
     1778(defnx1 nx1-flet flet context (defs &body forms)
    17031779  (with-nx-declarations (pending)
    17041780    (let* ((env *nx-lexical-environment*)
     
    17441820          (setq body (let* ((*nx-lexical-environment* new-env))
    17451821                       (nx1-dynamic-extent-functions vars new-env)
    1746                        (nx1-env-body body env)))
     1822                       (nx1-env-body context body env)))
    17471823          (dolist (pair pairs)
    17481824            (let ((afunc (cdr pair))
     
    17841860              (nx-set-var-bits varinfo (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits varinfo))))))))))
    17851861         
    1786 (defnx1 nx1-labels labels (defs &body forms)
     1862(defnx1 nx1-labels labels context (defs &body forms)
    17871863  (with-nx-declarations (pending)
    17881864    (let* ((env *nx-lexical-environment*)
     
    18271903        (nx-process-declarations pending decls)
    18281904        (nx-effect-other-decls pending env)
    1829         (setq body (nx1-env-body body old-env))
     1905        (setq body (nx1-env-body context body old-env))
    18301906        (nx-reconcile-inherited-vars funcrefs)
    18311907        (dolist (f funcrefs) (nx1-afunc-ref f))
     
    18391915
    18401916
    1841 (defnx1 nx1-set-bit ((%set-bit)) (ptr offset &optional (newval nil newval-p))
     1917(defnx1 nx1-set-bit ((%set-bit)) context (ptr offset &optional (newval nil newval-p))
    18421918  (unless newval-p (setq newval offset offset 0))
    18431919  (make-acode
    18441920   (%nx1-operator %set-bit)
    1845    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
    1846    (nx1-form offset)
    1847    (nx1-form newval)))
     1921   (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptr))
     1922   (nx1-form :value offset)
     1923   (nx1-form :value newval)))
    18481924               
    18491925(defnx1 nx1-set-xxx ((%set-ptr) (%set-long)  (%set-word) (%set-byte)
    1850                      (%set-unsigned-long) (%set-unsigned-word) (%set-unsigned-byte))
     1926                     (%set-unsigned-long) (%set-unsigned-word) (%set-unsigned-byte)) context
    18511927        (ptr offset &optional (newval nil new-val-p) &aux (op *nx-sfname*))
    18521928  (unless new-val-p (setq newval offset offset 0))
     
    18611937     (%set-unsigned-long (logior 32 4))
    18621938     (t 4))
    1863    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
    1864    (nx1-form offset)
    1865    (nx1-form newval)))
    1866 
    1867 (defnx1 nx1-set-64-xxx ((%%set-unsigned-longlong) (%%set-signed-longlong))
     1939   (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptr))
     1940   (nx1-form :value offset)
     1941   (nx1-form :value newval)))
     1942
     1943(defnx1 nx1-set-64-xxx ((%%set-unsigned-longlong) (%%set-signed-longlong)) context
    18681944        (&whole w ptr offset newval &aux (op *nx-sfname*))
    18691945  (target-word-size-case
    1870    (32 (nx1-treat-as-call w))
     1946   (32 (nx1-treat-as-call context w))
    18711947   (64
    18721948    (make-acode
     
    18751951       (%%set-signed-longlong 8)
    18761952       (t (logior 32 8)))
    1877      (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
    1878      (nx1-form offset)
    1879      (nx1-form newval)))))
    1880 
    1881 
    1882 (defnx1 nx1-get-bit ((%get-bit)) (ptrform &optional (offset 0))
     1953     (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptr))
     1954     (nx1-form :value offset)
     1955     (nx1-form :value newval)))))
     1956
     1957
     1958(defnx1 nx1-get-bit ((%get-bit)) context (ptrform &optional (offset 0))
    18831959  (make-acode
    18841960   (%nx1-operator typed-form)
     
    18861962   (make-acode
    18871963    (%nx1-operator %get-bit)
    1888     (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
    1889     (nx1-form offset))))
    1890 
    1891 (defnx1 nx1-get-64-xxx ((%%get-unsigned-longlong) (%%get-signed-longlong))
     1964    (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform))
     1965    (nx1-form :value offset))))
     1966
     1967(defnx1 nx1-get-64-xxx ((%%get-unsigned-longlong) (%%get-signed-longlong)) context
    18921968  (&whole w ptrform offsetform)
    18931969  (target-word-size-case
    1894    (32 (nx1-treat-as-call w))
     1970   (32 (nx1-treat-as-call context w))
    18951971   (64
    18961972    (let* ((flagbits (case *nx-sfname*
     
    19051981                 (%nx1-operator immediate-get-xxx)
    19061982                 flagbits
    1907                  (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
    1908                  (nx1-form offsetform)))))))
     1983                 (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform))
     1984                 (nx1-form :value  offsetform)))))))
    19091985
    19101986(defnx1 nx1-get-xxx ((%get-long)  (%get-full-long)  (%get-signed-long)
     
    19141990                     (%get-signed-word)
    19151991                     (%get-signed-byte)
    1916                      (%get-unsigned-long))
     1992                     (%get-unsigned-long)) context
    19171993  (ptrform &optional (offset 0))
    19181994  (let* ((sfname *nx-sfname*)
     
    19442020                 (%nx1-operator immediate-get-xxx)
    19452021                 flagbits
    1946                  (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
    1947                  (nx1-form offset)))))
    1948 
    1949 (defnx1 nx1-%get-ptr ((%get-ptr) ) (ptrform &optional (offset 0))
     2022                 (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform))
     2023                 (nx1-form :value offset)))))
     2024
     2025(defnx1 nx1-%get-ptr ((%get-ptr) ) context (ptrform &optional (offset 0))
    19502026  (make-acode
    19512027   (%nx1-operator %consmacptr%)
    19522028   (make-acode
    19532029    (%nx1-operator immediate-get-ptr)
    1954     (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
    1955     (nx1-form offset))))
     2030    (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform))
     2031    (nx1-form :value offset))))
    19562032
    19572033(defnx1 nx1-%get-float ((%get-single-float)
    1958                         (%get-double-float)) (ptrform &optional (offset 0))
     2034                        (%get-double-float)) context (ptrform &optional (offset 0))
    19592035  (make-acode
    19602036   (%nx1-operator typed-form)
     
    19642040   (make-acode
    19652041    (%nx1-default-operator)
    1966     (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
    1967     (nx1-form offset))))
     2042    (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform))
     2043    (nx1-form :value offset))))
    19682044
    19692045(defnx1 nx1-%set-float ((%set-single-float)
    1970                         (%set-double-float)) (ptrform offset &optional (newval nil newval-p))
     2046                        (%set-double-float)) context (ptrform offset &optional (newval nil newval-p))
    19712047  (unless newval-p
    19722048    (setq newval offset
     
    19792055     (make-acode
    19802056      (%nx1-default-operator)
    1981       (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
    1982       (nx1-form offset)
    1983       (nx1-form newval))))
    1984 
    1985 (defnx1 nx1-let let (pairs &body forms &environment old-env)
     2057      (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform))
     2058      (nx1-form :value offset)
     2059      (nx1-form :value newval))))
     2060
     2061(defnx1 nx1-let let context (pairs &body forms &environment old-env)
    19862062  (collect ((vars)
    19872063            (vals)
     
    20142090                   (progn
    20152091                     (nx-effect-other-decls pending *nx-lexical-environment*)
    2016                      (nx1-env-body body old-env))
     2092                     (nx1-env-body context body old-env))
    20172093                 *nx-new-p2decls*)))
    20182094          (nx1-check-var-bindings varbindings)
     
    20232099
    20242100;((lambda (lambda-list) . body) . args)
    2025 (defun nx1-lambda-bind (lambda-list args body &optional (body-environment *nx-lexical-environment*))
     2101(defun nx1-lambda-bind (context lambda-list args body &optional (body-environment *nx-lexical-environment*))
    20262102  (let* ((old-env body-environment)
    20272103         (arg-env *nx-lexical-environment*)
     
    20332109      (declare (ignore req opttail))
    20342110      (when (and ok (eq (%car resttail) '&lexpr))
    2035         (return-from nx1-lambda-bind (nx1-call (nx1-form `(lambda ,lambda-list ,@body)) args))))
     2111        (return-from nx1-lambda-bind (nx1-call context (nx1-form context `(lambda ,lambda-list ,@body)) args))))
    20362112    (let* ((*nx-lexical-environment* body-environment)
    20372113           (*nx-bound-vars* *nx-bound-vars*))
     
    20422118                               (nx-parse-simple-lambda-list pending lambda-list)
    20432119            (let* ((*nx-lexical-environment* arg-env))
    2044               (setq arglist (nx1-formlist args)))
     2120              (setq arglist (nx1-formlist context args)))
    20452121            (nx-effect-other-decls pending *nx-lexical-environment*)
    2046             (setq body (nx1-env-body body old-env))
     2122            (setq body (nx1-env-body context body old-env))
    20472123            (while req
    20482124              (when (null arglist)
     
    21522228
    21532229
    2154 (defnx1 nx1-lap-function (ppc-lap-function) (name bindings &body body)
     2230(defnx1 nx1-lap-function (ppc-lap-function) context (name bindings &body body)
    21552231  (declare (ftype (function (t t t)) %define-ppc-lap-function))
    21562232  (require "PPC-LAP" "ccl:compiler;ppc;ppc-lap")
     
    21592235                                  (dpb (length bindings) $lfbits-numreq 0))))
    21602236
    2161 (defnx1 nx1-x86-lap-function (x86-lap-function) (name bindings &body body)
     2237(defnx1 nx1-x86-lap-function (x86-lap-function) context (name bindings &body body)
    21622238  (declare (ftype (function (t t t)) %define-x86-lap-function))
    21632239  (require "X86-LAP")
     
    21662242                                    (dpb (length bindings) $lfbits-numreq 0))))
    21672243
    2168 (defnx1 nx1-arm-lap-function (arm-lap-function) (name bindings &body body)
     2244(defnx1 nx1-arm-lap-function (arm-lap-function) context (name bindings &body body)
    21692245  (declare (ftype (function (t t t)) %define-arm-lap-function))
    21702246  (require "ARM-LAP")
     
    21772253
    21782254
    2179 (defun nx1-env-body (body old-env &optional (typecheck (nx-declarations-typecheck *nx-lexical-environment*)))
    2180   (do* ((form (nx1-progn-body body))
     2255(defun nx1-env-body (context body old-env &optional (typecheck (nx-declarations-typecheck *nx-lexical-environment*)))
     2256  (do* ((form (nx1-progn-body context body))
    21812257        (typechecks nil)
    21822258        (env *nx-lexical-environment* (lexenv.parent-env env)))
     
    21982274              (unless (eq type t)
    21992275                (let ((old-bits (nx-var-bits var)))
    2200                   (push (nx1-form `(the ,type ,sym)) typechecks)
     2276                  (push (nx1-form :value `(the ,type ,sym)) typechecks)
    22012277                  (when (%izerop (logior
    22022278                                  (%ilogand2 old-bits
     
    22102286
    22112287
    2212 (defnx1 nx1-let* (let*) (varspecs &body forms)
     2288(defnx1 nx1-let* (let*) context (varspecs &body forms)
    22132289  (let* ((vars nil)
    22142290         (vals nil)
     
    22352311                 (setq vars (nreverse vars))
    22362312                 (setq vals (nreverse vals))
    2237                  (nx1-env-body body old-env)
     2313                 (nx1-env-body context body old-env)
    22382314                 *nx-new-p2decls*)))
    22392315          (nx1-check-var-bindings var-bound-vars)
     
    22412317          result)))))
    22422318
    2243 (defnx1 nx1-multiple-value-bind multiple-value-bind
     2319(defnx1 nx1-multiple-value-bind multiple-value-bind context
    22442320        (varspecs bindform &body forms)
    22452321  (if (= (length varspecs) 1)
    2246     (nx1-form `(let* ((,(car varspecs) ,bindform)) ,@forms))
     2322    (nx1-form context `(let* ((,(car varspecs) ,bindform)) ,@forms))
    22472323    (let* ((vars nil)
    22482324           (*nx-bound-vars* *nx-bound-vars*)
    22492325           (old-env *nx-lexical-environment*)
    2250            (mvform (nx1-form bindform)))
     2326           (mvform (nx1-form :value bindform)))
    22512327      (with-nx-declarations (pending)
    22522328        (multiple-value-bind (body decls)
     
    22602336           (nreverse vars)
    22612337           mvform
    2262            (nx1-env-body body old-env)
     2338           (nx1-env-body context body old-env)
    22632339           *nx-new-p2decls*))))))
    22642340
     
    22662342;;; This isn't intended to be user-visible; there isn't a whole lot of
    22672343;;; sanity-checking applied to the subtag.
    2268 (defnx1 nx1-%alloc-misc ((%alloc-misc)) (element-count subtag &optional (init nil init-p))
     2344(defnx1 nx1-%alloc-misc ((%alloc-misc)) context (element-count subtag &optional (init nil init-p))
    22692345  (if init-p                            ; ensure that "init" is evaluated before miscobj is created.
    22702346    (make-acode (%nx1-operator %make-uvector)
    2271                 (nx1-form element-count)
    2272                 (nx1-form subtag)
    2273                 (nx1-form init))
     2347                (nx1-form :value element-count)
     2348                (nx1-form :value subtag)
     2349                (nx1-form :value init))
    22742350    (make-acode (%nx1-operator %make-uvector)
    2275                 (nx1-form element-count)
    2276                 (nx1-form subtag))))
    2277 
    2278 (defnx1 nx1-%lisp-word-ref (%lisp-word-ref) (base offset)
     2351                (nx1-form :value element-count)
     2352                (nx1-form :value subtag))))
     2353
     2354(defnx1 nx1-%lisp-word-ref (%lisp-word-ref) context (base offset)
    22792355  (make-acode (%nx1-operator %lisp-word-ref)
    2280               (nx1-form base)
    2281               (nx1-form offset)))
    2282 
    2283 (defnx1 nx1-%single-to-double ((%single-to-double)) (arg)
     2356              (nx1-form :value base)
     2357              (nx1-form :value offset)))
     2358
     2359(defnx1 nx1-%single-to-double ((%single-to-double)) context (arg)
    22842360  (make-acode (%nx1-operator %single-to-double)
    2285               (nx1-form arg)))
    2286 
    2287 (defnx1 nx1-%double-to-single ((%double-to-single)) (arg)
     2361              (nx1-form :value arg)))
     2362
     2363(defnx1 nx1-%double-to-single ((%double-to-single)) context (arg)
    22882364  (make-acode (%nx1-operator %double-to-single)
    2289               (nx1-form arg)))
    2290 
    2291 (defnx1 nx1-%fixnum-to-double ((%fixnum-to-double)) (arg)
     2365              (nx1-form :value arg)))
     2366
     2367(defnx1 nx1-%fixnum-to-double ((%fixnum-to-double)) context (arg)
    22922368  (make-acode (%nx1-operator %fixnum-to-double)
    2293               (nx1-form arg)))
    2294 
    2295 (defnx1 nx1-%fixnum-to-single ((%fixnum-to-single)) (arg)
     2369              (nx1-form :value arg)))
     2370
     2371(defnx1 nx1-%fixnum-to-single ((%fixnum-to-single)) context (arg)
    22962372  (make-acode (%nx1-operator %fixnum-to-single)
    2297               (nx1-form arg)))
    2298 
    2299 (defnx1 nx1-%double-float ((%double-float)) (&whole whole arg &optional (result nil result-p))
     2373              (nx1-form :value arg)))
     2374
     2375(defnx1 nx1-%double-float ((%double-float)) context (&whole whole arg &optional (result nil result-p))
    23002376  (declare (ignore result))
    23012377  (if result-p
    2302     (nx1-treat-as-call whole)
    2303     (make-acode (%nx1-operator %double-float) (nx1-form arg))))
    2304 
    2305 (defnx1 nx1-%short-float ((%short-float)) (&whole whole arg &optional (result nil result-p))
     2378    (nx1-treat-as-call context whole)
     2379    (make-acode (%nx1-operator %double-float) (nx1-form :value arg))))
     2380
     2381(defnx1 nx1-%short-float ((%short-float)) context (&whole whole arg &optional (result nil result-p))
    23062382  (declare (ignore result))       
    23072383  (if result-p
    2308     (nx1-treat-as-call whole)
    2309     (make-acode (%nx1-operator %single-float) (nx1-form arg))))
    2310 
    2311 
    2312 (defnx1 nx1-symvector ((%symptr->symvector) (%symvector->symptr)) (arg)
    2313   (make-acode (%nx1-default-operator) (nx1-form arg)))
    2314 
    2315 (defnx1 nx1-%ilognot (%ilognot) (n)
     2384    (nx1-treat-as-call context whole)
     2385    (make-acode (%nx1-operator %single-float) (nx1-form :value arg))))
     2386
     2387
     2388(defnx1 nx1-symvector ((%symptr->symvector) (%symvector->symptr)) context (arg)
     2389  (make-acode (%nx1-default-operator) (nx1-form :value arg)))
     2390
     2391(defnx1 nx1-%ilognot (%ilognot) context (n)
    23162392  ;; Bootstrapping nonsense.
    23172393  (if (aref (backend-p2-dispatch *target-backend*)
     
    23202396                'fixnum
    23212397                (make-acode (%nx1-operator %ilognot)
    2322                             (nx1-form n)))
    2323     (nx1-form (macroexpand `(%ilognot ,n)))))
     2398                            (nx1-form :value n)))
     2399    (nx1-form context (macroexpand `(%ilognot ,n)))))
    23242400
    23252401   
    2326 (defnx1 nx1-ash (ash) (&whole call &environment env num amt)
     2402(defnx1 nx1-ash (ash) context (&whole call &environment env num amt)
    23272403  (flet ((defer-to-backend ()
    23282404             ;; Bootstrapping nonsense
     
    23332409                           (make-acode
    23342410                            (%nx1-operator ash)
    2335                             (nx1-form num)
    2336                             (nx1-form amt)))
    2337                (nx1-treat-as-call call))))
     2411                            (nx1-form :value num)
     2412                            (nx1-form :value amt)))
     2413               (nx1-treat-as-call context call))))
    23382414    (let* ((unsigned-natural-type *nx-target-natural-type*)
    23392415           (max (target-word-size-case (32 32) (64 64)))
     
    23412417                     (32 29)
    23422418                     (64 60))))
    2343       (cond ((eq amt 0) (nx1-form `(require-type ,num 'integer) env))
     2419      (cond ((eq amt 0) (nx1-form context `(require-type ,num 'integer) env))
    23442420            ((and (fixnump amt)
    23452421                  (< amt 0))
     
    23482424                           (make-acode (%nx1-operator fixnum)
    23492425                                       (- amt))
    2350                            (nx1-form num))
     2426                           (nx1-form :value num))
    23512427               (if (nx-form-typep num unsigned-natural-type env)
    23522428                 (if (< (- amt) max)
    23532429                   (make-acode (%nx1-operator natural-shift-right)
    2354                                (nx1-form num)
     2430                               (nx1-form :value num)
    23552431                               (make-acode (%nx1-operator fixnum)
    23562432                                           (- amt)))
    2357                    (nx1-form `(progn (require-type ,num 'integer) 0) env))
     2433                   (nx1-form context `(progn (require-type ,num 'integer) 0) env))
    23582434                 (defer-to-backend))))
    23592435            ((and (fixnump amt)
     
    23632439                           (nx-trust-declarations env)
    23642440                           (subtypep *nx-form-type* 'fixnum))))
    2365              (nx1-form `(%ilsl ,amt ,num)))
     2441             (nx1-form context `(%ilsl ,amt ,num)))
    23662442            ((and (fixnump amt)
    23672443                  (< 0 amt max)
     
    23702446                  (subtypep *nx-form-type* unsigned-natural-type))
    23712447             (make-acode (%nx1-operator natural-shift-left)
    2372                          (nx1-form num)
    2373                          (nx1-form amt)))
     2448                         (nx1-form :value num)
     2449                         (nx1-form :value amt)))
    23742450            ((fixnump num)
    23752451             (let* ((field-width (1+ (integer-length num)))
     
    23772453                    (max-shift (- (1+ maxbits) field-width)))
    23782454               (if (nx-form-typep amt `(mod ,(1+ max-shift)) env)
    2379                  (nx1-form `(%ilsl ,amt ,num))
     2455                 (nx1-form context `(%ilsl ,amt ,num))
    23802456                 (defer-to-backend))))
    23812457            (t (defer-to-backend))))))
     
    23862462 (nx-error "Bad argument format in ~S ." args))
    23872463
    2388 (defnx1 nx1-eval-when eval-when (when &body body)
    2389   (nx1-progn-body (if (or (memq 'eval when) (memq :execute when)) body)))
    2390 
    2391 (defnx1 nx1-misplaced (declare) (&rest args)
     2464(defnx1 nx1-eval-when eval-when context (when &body body)
     2465  (nx1-progn-body context (if (or (memq 'eval when) (memq :execute when)) body)))
     2466
     2467(defnx1 nx1-misplaced (declare) context (&rest args)
    23922468  (nx-error "~S not expected in ~S." *nx-sfname* (cons *nx-sfname* args)))
    23932469
Note: See TracChangeset for help on using the changeset viewer.