Index: /trunk/source/compiler/nx0.lisp =================================================================== --- /trunk/source/compiler/nx0.lisp (revision 15039) +++ /trunk/source/compiler/nx0.lisp (revision 15040) @@ -275,4 +275,18 @@ def) + +;;; Note that all lexical variables bound at this time are live across +;;; a non-tail call by setting a bit in each such var. This may not +;;; be exactt (for many reasons), but it may help the register allocator: +;;; if a variable is unlikely to be live across a call, there's less +;;; reason to keep it in a register that's preserved across calls. + +(defun nx-note-bound-vars-live-across-call () + (dolist (var *nx-bound-vars*) + (let* ((local-bits (var-local-bits var))) + (declare (fixnum local-bits)) + (unless (logbitp $vbitspecial (nx-var-bits var)) + (setf (var-local-bits var) (logior (ash 1 $vlocalbitiveacrosscall) local-bits)))))) + (defsetf compiler-macro-function set-compiler-macro-function) @@ -409,12 +423,5 @@ -(defun nx1-typed-var-initform (pending sym form &optional (env *nx-lexical-environment*)) - (let* ((type t) - (*nx-form-type* (if (nx-trust-declarations env) - (dolist (decl (pending-declarations-vdecls pending) type) - (when (and (eq (car decl) sym) (eq (cadr decl) 'type)) - (setq type (nx1-type-intersect sym (nx-target-type type) (cddr decl))))) - t))) - (nx1-typed-form form env))) + ; Guess. @@ -1295,19 +1302,12 @@ -(defun nx-block-info (blockname &optional (afunc *nx-current-function*) &aux - blocks - parent - (toplevel (eq afunc *nx-current-function*)) - blockinfo) - (when afunc - (setq - blocks (if toplevel *nx-blocks* (afunc-blocks afunc)) - blockinfo (assq blockname blocks) - parent (afunc-parent afunc)) - (if blockinfo - (values blockinfo nil) - (when parent - (when (setq blockinfo (nx-block-info blockname parent)) - (values blockinfo t)))))) +(defun nx-block-info (blockname) + (do* ((toplevel t nil) + (afunc *nx-current-function*(afunc-parent afunc))) + ((null afunc) (values nil nil)) + (let* ((info (assq blockname (if toplevel *nx-blocks* (afunc-blocks afunc))))) + (if info + (return-from nx-block-info (values info (not toplevel))))))) + (defun nx-tag-info (tagname &optional (afunc *nx-current-function*) &aux @@ -1504,5 +1504,5 @@ nil nil - (nx1-env-body body old-env) + (nx1-env-body :value body old-env) *nx-new-p2decls*)))) (when (eq (car l) '&method) @@ -1524,5 +1524,5 @@ (nx-parse-simple-lambda-list pending ll) (nx-effect-other-decls pending *nx-lexical-environment*) - (setq body (nx1-env-body body old-env)) + (setq body (nx1-env-body :return body old-env)) (nx1-punt-bindings (%car auxen) (%cdr auxen)) (when methvar @@ -1660,5 +1660,5 @@ (when (consp var) (setq sym (pop var) initform (pop var) spvar (%car var))) - (push (if no-acode initform (nx1-form initform)) optinits) + (push (if no-acode initform (nx1-form :value initform)) optinits) (push (if (symbolp sym) (nx-new-structured-var pending sym) @@ -1698,5 +1698,5 @@ (setq kvar (%car sym)) (setq kkey (make-keyword kvar)))) - (setq kinit (if no-acode (%cadr sym) (nx1-form (%cadr sym)))) + (setq kinit (if no-acode (%cadr sym) (nx1-form :value (%cadr sym)))) (setq ksupp (%caddr sym)))) (push (if (symbolp kvar) @@ -1719,5 +1719,5 @@ (let ((auxvar (nx-pair-name pair)) (auxval (nx-pair-initform pair))) - (push (if no-acode auxval (nx1-form auxval)) auxvals) + (push (if no-acode auxval (nx1-form :value auxval)) auxvals) (push (nx-new-var pending auxvar) auxvars))) (values @@ -1734,117 +1734,15 @@ (list (%nx1-operator lambda-list) whole req opt rest keys auxen))) -(defun nx1-form (form &optional (*nx-lexical-environment* *nx-lexical-environment*)) - (let* ((*nx-form-type* (if (and (consp form) (eq (car form) 'the)) - (nx-target-type (cadr form)) - t))) - (nx1-typed-form form *nx-lexical-environment*))) - -(defun nx1-typed-form (original env) - (with-program-error-handler - (lambda (c) - (let ((replacement (runtime-program-error-form c))) - (nx-note-source-transformation original replacement) - (nx1-transformed-form (nx-transform replacement env) env))) - (multiple-value-bind (form changed source) (nx-transform original env) - (declare (ignore changed)) - ;; Bind this for cases where the transformed form is an atom, so it doesn't remember the source it came from. - (let ((*nx-current-note* (or source *nx-current-note*))) - (nx1-transformed-form form env))))) - -(defun nx1-transformed-form (form env) - (let* ((*nx-current-note* (or (nx-source-note form) *nx-current-note*)) - (*nx-current-code-note* (and *nx-current-code-note* - (or (nx-ensure-code-note form *nx-current-code-note*) - (compiler-bug "No source note for ~s" form)))) - (acode (if (consp form) - (nx1-combination form env) - (let* ((symbolp (non-nil-symbol-p form)) - (constant-value (unless symbolp form)) - (constant-symbol-p nil)) - (if symbolp - (multiple-value-setq (constant-value constant-symbol-p) - (nx-transform-defined-constant form env))) - (if (and symbolp (not constant-symbol-p)) - (nx1-symbol form env) - (nx1-immediate (nx-unquote constant-value))))))) - (unless (acode-note acode) ;; leave it with most specific note - (cond (*nx-current-code-note* - (setf (acode-note acode) *nx-current-code-note*)) - (*record-pc-mapping* - (setf (acode-note acode) (nx-source-note form))))) - acode)) - -(defun nx1-prefer-areg (form env) - (nx1-form form env)) - -(defun nx1-target-fixnump (form) - (when (typep form 'integer) - (let* ((target (backend-target-arch *target-backend*))) - (and - (>= form (arch::target-most-negative-fixnum target)) - (<= form (arch::target-most-positive-fixnum target)))))) - - -(defun nx1-immediate (form) + +(defun nx1-immediate (context form) + (declare (ignorable context)) (cond ((eq form t) (make-acode (%nx1-operator t))) - ((null form) (make-acode (%nx1-operator nil))) - ((nx1-target-fixnump form) - (make-acode (%nx1-operator fixnum) form)) - (t (make-acode (%nx1-operator immediate) form)))) - -(defun nx2-constant-form-value (form) - (setq form (nx-untyped-form form)) - (and (or (nx-null form) - (nx-t form) - (and (acode-p form) - (or (eq (acode-operator form) (%nx1-operator immediate)) - (eq (acode-operator form) (%nx1-operator fixnum)) - (eq (acode-operator form) (%nx1-operator simple-function))))) - form)) - -(defun nx-natural-constant-p (form) - (setq form (nx-untyped-form form)) - (if (consp form) - (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum)) - (eq (acode-operator form) (%nx1-operator immediate))) - (cadr form)))) - (and (typep val *nx-target-natural-type*) val)))) - -(defun nx-u32-constant-p (form) - (setq form (nx-untyped-form form)) - (if (consp form) - (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum)) - (eq (acode-operator form) (%nx1-operator immediate))) - (cadr form)))) - (and (typep val '(unsigned-byte 32)) val)))) - -(defun nx-u31-constant-p (form) - (setq form (nx-untyped-form form)) - (if (consp form) - (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum)) - (eq (acode-operator form) (%nx1-operator immediate))) - (cadr form)))) - (and (typep val '(unsigned-byte 31)) val)))) - - -;;; Reference-count vcell, fcell refs. -(defun nx1-note-vcell-ref (sym) - (let* ((there (assq sym *nx1-vcells*)) - (count (expt 4 *nx-loop-nesting-level*))) - (if there - (%rplacd there (%i+ (%cdr there) count)) - (push (cons sym count) *nx1-vcells*))) - sym) - -(defun nx1-note-fcell-ref (sym) - (let* ((there (assq sym *nx1-fcells*)) - (count (expt 4 *nx-loop-nesting-level*))) - (if there - (%rplacd there (%i+ (%cdr there) count)) - (push (cons sym count) *nx1-fcells*)) - sym)) - -; Note that "simple lexical refs" may not be; that's the whole problem ... -(defun nx1-symbol (form &optional (env *nx-lexical-environment*)) + ((null form) (make-acode (%nx1-operator nil))) + ((nx1-target-fixnump form) + (make-acode (%nx1-operator fixnum) form)) + (t (make-acode (%nx1-operator immediate) form)))) + +;;; Note that "simple lexical refs" may not be; that's the whole problem ... +(defun nx1-symbol (context form &optional (env *nx-lexical-environment*)) (let* ((type (nx-declared-type form)) (form @@ -1856,10 +1754,11 @@ (nx-set-var-bits more (%ilogior (%ilsl $vbitreffed 1) (nx-var-bits more))) (if (eq type t) - (nx1-form inherited-p) - (nx1-form `(the ,(prog1 type (setq type t)) ,inherited-p)))) + (nx1-form context inherited-p) + (nx1-form context `(the ,(prog1 type (setq type t)) ,inherited-p)))) (progn (when (not inherited-p) (nx-set-var-bits info (%ilogior2 (%ilsl $vbitreffed 1) (nx-var-bits info)))) - (nx-adjust-ref-count info) + (when context + (nx-adjust-ref-count info)) (nx-make-lexical-reference info))) (make-acode @@ -1882,4 +1781,144 @@ (make-acode (%nx1-operator typed-form) type form)))) +(defun nx1-combination (context form env) + (destructuring-bind (sym &rest args) form + (if (symbolp sym) + (let* ((*nx-sfname* sym) special) + (if (and (setq special (gethash sym *nx1-alphatizers*)) + (or (not (functionp (fboundp sym))) + (memq sym '(apply funcall ;; see bug #285 + %defun ;; see bug #295 + )) + (< (safety-optimize-quantity env) 3)) + ;;(not (nx-lexical-finfo sym env)) + (not (nx-declared-notinline-p sym *nx-lexical-environment*))) + (funcall special context form env) ; pass environment arg ... + (progn + (nx1-typed-call context sym args)))) + (if (lambda-expression-p sym) + (nx1-lambda-bind context (%cadr sym) args (%cddr sym)) + (nx-error "In the form ~S, ~S is not a symbol or lambda expression." form sym))))) + +(defun nx1-transformed-form (context form env) + (let* ((*nx-current-note* (or (nx-source-note form) *nx-current-note*)) + (*nx-current-code-note* (and *nx-current-code-note* + (or (nx-ensure-code-note form *nx-current-code-note*) + (compiler-bug "No source note for ~s" form)))) + (acode (if (consp form) + (nx1-combination context form env) + (let* ((symbolp (non-nil-symbol-p form)) + (constant-value (unless symbolp form)) + (constant-symbol-p nil)) + (if symbolp + (multiple-value-setq (constant-value constant-symbol-p) + (nx-transform-defined-constant form env))) + (if (and symbolp (not constant-symbol-p)) + (nx1-symbol context form env) + (nx1-immediate context (nx-unquote constant-value))))))) + (unless (acode-note acode) ;; leave it with most specific note + (cond (*nx-current-code-note* + (setf (acode-note acode) *nx-current-code-note*)) + (*record-pc-mapping* + (setf (acode-note acode) (nx-source-note form))))) + acode)) + +(defun nx1-typed-form (context original env) + (with-program-error-handler + (lambda (c) + (let ((replacement (runtime-program-error-form c))) + (nx-note-source-transformation original replacement) + (nx1-transformed-form context (nx-transform replacement env) env))) + (multiple-value-bind (form changed source) (nx-transform original env) + (declare (ignore changed)) + ;; Bind this for cases where the transformed form is an atom, so it doesn't remember the source it came from. + (let ((*nx-current-note* (or source *nx-current-note*))) + (nx1-transformed-form context form env))))) + +(defun nx1-form (context form &optional (*nx-lexical-environment* *nx-lexical-environment*)) + #-bootstrapped + (unless (member context '(nil :return :value)) + (break "bad context ~s" context)) + (let* ((*nx-form-type* (if (and (consp form) (eq (car form) 'the)) + (nx-target-type (cadr form)) + t))) + (nx1-typed-form context form *nx-lexical-environment*))) + +(defun nx1-typed-var-initform (pending sym form &optional (env *nx-lexical-environment*)) + (let* ((type t) + (*nx-form-type* (if (nx-trust-declarations env) + (dolist (decl (pending-declarations-vdecls pending) type) + (when (and (eq (car decl) sym) (eq (cadr decl) 'type)) + (setq type (nx1-type-intersect sym (nx-target-type type) (cddr decl))))) + t))) + (nx1-typed-form :value form env))) + + + + + +(defun nx1-target-fixnump (form) + (when (typep form 'integer) + (let* ((target (backend-target-arch *target-backend*))) + (and + (>= form (arch::target-most-negative-fixnum target)) + (<= form (arch::target-most-positive-fixnum target)))))) + + + + +(defun nx2-constant-form-value (form) + (setq form (nx-untyped-form form)) + (and (or (nx-null form) + (nx-t form) + (and (acode-p form) + (or (eq (acode-operator form) (%nx1-operator immediate)) + (eq (acode-operator form) (%nx1-operator fixnum)) + (eq (acode-operator form) (%nx1-operator simple-function))))) + form)) + +(defun nx-natural-constant-p (form) + (setq form (nx-untyped-form form)) + (if (consp form) + (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum)) + (eq (acode-operator form) (%nx1-operator immediate))) + (cadr form)))) + (and (typep val *nx-target-natural-type*) val)))) + +(defun nx-u32-constant-p (form) + (setq form (nx-untyped-form form)) + (if (consp form) + (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum)) + (eq (acode-operator form) (%nx1-operator immediate))) + (cadr form)))) + (and (typep val '(unsigned-byte 32)) val)))) + +(defun nx-u31-constant-p (form) + (setq form (nx-untyped-form form)) + (if (consp form) + (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum)) + (eq (acode-operator form) (%nx1-operator immediate))) + (cadr form)))) + (and (typep val '(unsigned-byte 31)) val)))) + + +;;; Reference-count vcell, fcell refs. +(defun nx1-note-vcell-ref (sym) + (let* ((there (assq sym *nx1-vcells*)) + (count (expt 4 *nx-loop-nesting-level*))) + (if there + (%rplacd there (%i+ (%cdr there) count)) + (push (cons sym count) *nx1-vcells*))) + sym) + +(defun nx1-note-fcell-ref (sym) + (let* ((there (assq sym *nx1-fcells*)) + (count (expt 4 *nx-loop-nesting-level*))) + (if there + (%rplacd there (%i+ (%cdr there) count)) + (push (cons sym count) *nx1-fcells*)) + sym)) + + + (defun nx1-check-special-ref (form auxinfo) (or (eq auxinfo :special) @@ -1944,27 +1983,56 @@ -(defun nx1-combination (form env) - (destructuring-bind (sym &rest args) form - (if (symbolp sym) - (let* ((*nx-sfname* sym) special) - (if (and (setq special (gethash sym *nx1-alphatizers*)) - (or (not (functionp (fboundp sym))) - (memq sym '(apply funcall ;; see bug #285 - %defun ;; see bug #295 - )) - (< (safety-optimize-quantity env) 3)) - ;;(not (nx-lexical-finfo sym env)) - (not (nx-declared-notinline-p sym *nx-lexical-environment*))) - (funcall special form env) ; pass environment arg ... - (progn - (nx1-typed-call sym args)))) - (if (lambda-expression-p sym) - (nx1-lambda-bind (%cadr sym) args (%cddr sym)) - (nx-error "In the form ~S, ~S is not a symbol or lambda expression." form sym))))) - -(defun nx1-treat-as-call (args) - (nx1-typed-call (car args) (%cdr args))) - -(defun nx1-typed-call (fn args &optional spread-p) +;;; If "sym" is an expression (not a symbol which names a function), +;;; the caller has already alphatized it. +(defun nx1-call (context sym args &optional spread-p global-only inhibit-inline) + (nx1-verify-length args 0 nil) + (when (and (acode-p sym) (eq (acode-operator sym) (%nx1-operator immediate))) + (multiple-value-bind (valid name) (valid-function-name-p (%cadr sym)) + (when valid + (setq global-only t sym name)))) + (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*)))) + (if (nx-self-call-p sym global-only) + ;; Should check for downward functions here as well. + (multiple-value-bind (deftype reason) + (nx1-check-call-args *nx-current-function* args spread-p) + (when deftype + (nx1-whine deftype sym reason args spread-p)) + (if (eq context :return) + ;; Could check policy, note things that interfere with + ;; tail call, and try to better estimate whether or not + ;; this will be a real tail call. + (setf (afunc-bits *nx-current-function*) + (logior (ash 1 $fbittailcallsself) (afunc-bits *nx-current-function*))) + (nx-note-bound-vars-live-across-call)) + (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p)) + (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only) + (or (and (not inhibit-inline) + (nx1-expand-inline-call context lambda-form containing-env token args spread-p *nx-lexical-environment*)) + (multiple-value-bind (info afunc) (if (and (symbolp sym) (not global-only)) (nx-lexical-finfo sym)) + (when (eq 'macro (car info)) + (nx-error "Can't call macro function ~s" sym)) + (nx-record-xref-info :direct-calls sym) + (if (and afunc (%ilogbitp $fbitruntimedef (afunc-bits afunc))) + (let ((sym (var-name (afunc-lfun afunc)))) + (nx1-form + context + (if spread-p + `(,(if (eql spread-p 0) 'applyv 'apply) ,sym ,args) + `(funcall ,sym ,@args)))) + (let* ((val (nx1-call-form context sym afunc args spread-p))) + (when afunc + (let ((callers (afunc-callers afunc)) + (self *nx-current-function*)) + (unless (or (eq self afunc) (memq self callers)) + (setf (afunc-callers afunc) (cons self callers))))) + (if (and (null afunc) (memq sym *nx-never-tail-call*)) + (make-acode (%nx1-operator values) (list val)) + val))))))))) + + +(defun nx1-treat-as-call (context args) + (nx1-typed-call context (car args) (%cdr args))) + +(defun nx1-typed-call (context fn args &optional spread-p) (let ((global-only nil) (errors-p nil) @@ -1978,5 +2046,5 @@ (nx1-check-typed-call fn args spread-p global-only))) (setq result-type (nx1-type-intersect fn *nx-form-type* result-type)) - (let ((form (nx1-call fn args spread-p global-only errors-p))) + (let ((form (nx1-call context fn args spread-p global-only errors-p))) (if (eq result-type t) form @@ -2274,5 +2342,7 @@ (arch::builtin-function-name-offset name)) -(defun nx1-call-form (global-name afunc arglist spread-p &optional (env *nx-lexical-environment*)) +(defun nx1-call-form (context global-name afunc arglist spread-p &optional (env *nx-lexical-environment*)) + (unless (eq context :return) + (nx-note-bound-vars-live-across-call)) (if afunc (make-acode (%nx1-operator lexical-function-call) afunc (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*))) spread-p) @@ -2291,49 +2361,12 @@ (make-acode (%nx1-operator call) (if (symbolp global-name) - (nx1-immediate (nx1-note-fcell-ref global-name)) + (nx1-immediate context (if context (nx1-note-fcell-ref global-name) global-name)) global-name) (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*))) spread-p))))) -;;; If "sym" is an expression (not a symbol which names a function), -;;; the caller has already alphatized it. -(defun nx1-call (sym args &optional spread-p global-only inhibit-inline) - (nx1-verify-length args 0 nil) - (when (and (acode-p sym) (eq (acode-operator sym) (%nx1-operator immediate))) - (multiple-value-bind (valid name) (valid-function-name-p (%cadr sym)) - (when valid - (setq global-only t sym name)))) - (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*)))) - (if (nx-self-call-p sym global-only) - ;; Should check for downward functions here as well. - (multiple-value-bind (deftype reason) - (nx1-check-call-args *nx-current-function* args spread-p) - (when deftype - (nx1-whine deftype sym reason args spread-p)) - (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p)) - (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only) - (or (and (not inhibit-inline) - (nx1-expand-inline-call lambda-form containing-env token args spread-p *nx-lexical-environment*)) - (multiple-value-bind (info afunc) (if (and (symbolp sym) (not global-only)) (nx-lexical-finfo sym)) - (when (eq 'macro (car info)) - (nx-error "Can't call macro function ~s" sym)) - (nx-record-xref-info :direct-calls sym) - (if (and afunc (%ilogbitp $fbitruntimedef (afunc-bits afunc))) - (let ((sym (var-name (afunc-lfun afunc)))) - (nx1-form - (if spread-p - `(,(if (eql spread-p 0) 'applyv 'apply) ,sym ,args) - `(funcall ,sym ,@args)))) - (let* ((val (nx1-call-form sym afunc args spread-p))) - (when afunc - (let ((callers (afunc-callers afunc)) - (self *nx-current-function*)) - (unless (or (eq self afunc) (memq self callers)) - (setf (afunc-callers afunc) (cons self callers))))) - (if (and (null afunc) (memq sym *nx-never-tail-call*)) - (make-acode (%nx1-operator values) (list val)) - val))))))))) - -(defun nx1-expand-inline-call (lambda-form env token args spread-p old-env) + + +(defun nx1-expand-inline-call (context lambda-form env token args spread-p old-env) (if (and (or (null spread-p) (eq (length args) 1))) (if (and token (not (memq token *nx-inline-expansions*))) @@ -2350,6 +2383,6 @@ (debug . ,(debug-optimize-quantity old-env)))) (if spread-p - (nx1-destructure lambda-list (car args) nil nil body new-env) - (nx1-lambda-bind lambda-list args body new-env))))))) + (nx1-destructure context lambda-list (car args) nil nil body new-env) + (nx1-lambda-bind context lambda-list args body new-env))))))) ; note that regforms are reversed: arg_z is always in the car @@ -2363,13 +2396,13 @@ (dotimes (i nstkargs (nreverse stkforms)) (declare (fixnum i)) - (push (nx1-form (%car args)) stkforms) + (push (nx1-form :value (%car args)) stkforms) (setq args (%cdr args))) (dolist (arg args regforms) - (push (nx1-form arg) regforms))))) - -(defun nx1-formlist (args) + (push (nx1-form :value arg) regforms))))) + +(defun nx1-formlist (context args) (let* ((a nil)) (dolist (arg args) - (push (nx1-form arg) a)) + (push (nx1-form (if context :value) arg) a)) (nreverse a))) @@ -2779,5 +2812,5 @@ (subtypep *nx-form-type* *nx-target-natural-type*))))) -(defun nx-binary-boole-op (whole env arg-1 arg-2 fixop intop naturalop) +(defun nx-binary-boole-op (context whole env arg-1 arg-2 fixop intop naturalop) (let* ((use-fixop (nx-binary-fixnum-op-p arg-1 arg-2 env t)) (use-naturalop (nx-binary-natural-op-p arg-1 arg-2 env))) @@ -2787,7 +2820,7 @@ (if use-naturalop *nx-target-natural-type* 'integer)) (make-acode (if use-fixop fixop (if use-naturalop naturalop intop)) - (nx1-form arg-1) - (nx1-form arg-2))) - (nx1-treat-as-call whole)))) + (nx1-form :value arg-1) + (nx1-form :value arg-2))) + (nx1-treat-as-call context whole)))) (defun nx-global-p (sym &optional (env *nx-lexical-environment*)) Index: /trunk/source/compiler/nx1.lisp =================================================================== --- /trunk/source/compiler/nx1.lisp (revision 15039) +++ /trunk/source/compiler/nx1.lisp (revision 15040) @@ -17,4 +17,48 @@ (in-package "CCL") + + +(defmacro defnx1 (name sym contextvar arglist &body forms &environment env) + (unless (verify-lambda-list arglist t t t) + (error "Invalid lambda list ~s" arglist)) + (multiple-value-bind (lambda-list whole environment) + (normalize-lambda-list arglist t t) + (multiple-value-bind (body local-decs) (parse-body forms env) + (let ((whole-var (gensym "WHOLE")) + (env-var (gensym "ENVIRONMENT"))) + (multiple-value-bind (bindings binding-decls) + (%destructure-lambda-list lambda-list whole-var nil nil + :cdr-p t + :whole-p nil + :use-whole-var t + :default-initial-value nil) + (when environment + (setq bindings (nconc bindings (list `(,environment ,env-var))))) + (when whole + (setq bindings (nconc bindings (list `(,whole ,whole-var))))) + (let ((fn `(nfunction ,name + (lambda (,contextvar ,whole-var ,env-var) + (declare (ignorable ,contextvar ,whole-var ,env-var)) + (block ,name + (let* ,(nreverse bindings) + ,@(when binding-decls `((declare ,@binding-decls))) + ,@local-decs + ,@body))))) + (theprogn ()) + (ysym (gensym))) + `(let ((,ysym ,fn)) + ,(if (symbolp sym) + `(progn + (setf (gethash ',sym *nx1-alphatizers*) ,ysym) + ;(proclaim '(inline ,sym)) + (pushnew ',sym *nx1-compiler-special-forms*)) + (dolist (x sym `(progn ,@(nreverse theprogn))) + (if (consp x) + (setq x (%car x)) + (push `(pushnew ',x *nx1-compiler-special-forms*) theprogn)) + ;(push `(proclaim '(inline ,x)) theprogn) + (push `(setf (gethash ',x *nx1-alphatizers*) ,ysym) theprogn))) + (record-source-file ',name 'function) + ,ysym))))))) (defun nx1-typespec-for-typep (typespec env &key (whine t)) @@ -67,5 +111,5 @@ (nx-target-type (type-specifier (if new (specifier-type new) ctype)))))) -(defnx1 nx1-the the (&whole call typespec form &environment env) +(defnx1 nx1-the the context (&whole call typespec form &environment env) (let* ((typespec (nx1-typespec-for-typep typespec env)) (*nx-form-type* typespec) @@ -108,45 +152,58 @@ typespec (let* ((*nx-form-type* typespec)) - (nx1-transformed-form transformed env)) + (nx1-transformed-form context transformed env)) (nx-declarations-typecheck env))))) -(defnx1 nx1-struct-ref struct-ref (&whole whole structure offset) +(defnx1 nx1-struct-ref struct-ref context (&whole whole structure offset) (if (not (fixnump (setq offset (nx-get-fixnum offset)))) - (nx1-treat-as-call whole) + (nx1-treat-as-call context whole) (make-acode (%nx1-operator struct-ref) - (nx1-form structure) - (nx1-form offset)))) - -(defnx1 nx1-struct-set struct-set (&whole whole structure offset newval) + (nx1-form :value structure) + (nx1-form :value offset)))) + +(defnx1 nx1-struct-set struct-set context (&whole whole structure offset newval) (if (not (fixnump (setq offset (nx-get-fixnum offset)))) - (nx1-treat-as-call whole) + (nx1-treat-as-call context whole) (make-acode (%nx1-operator struct-set) - (nx1-form structure) - (nx1-form offset) - (nx1-form newval)))) - -(defnx1 nx1-istruct-typep ((istruct-typep)) (&whole whole thing type &environment env) + (nx1-form :value structure) + (nx1-form :value offset) + (nx1-form :value newval)))) + +(defnx1 nx1-istruct-typep ((istruct-typep)) context (&whole whole thing type &environment env) (if (and (nx-form-constant-p type env) (non-nil-symbol-p (nx-form-constant-value type env))) - (make-acode (%nx1-operator istruct-typep) - (nx1-immediate :eq) - (nx1-form thing) - (nx1-form `(register-istruct-cell ,type))) - (nx1-treat-as-call whole))) - -(defnx1 nx1-make-list make-list (&whole whole size &rest keys &environment env) + (let* ((inner :value)) + (make-acode (%nx1-operator istruct-typep) + (nx1-immediate inner :eq) + (nx1-form inner thing) + (nx1-form inner `(register-istruct-cell ,type)))) + (nx1-treat-as-call context whole))) + +(defnx1 nx1-make-list make-list context (&whole whole size &rest keys &environment env) (if (and keys (or (neq (list-length keys) 2) (neq (nx-transform (%car keys) env) :initial-element))) - (nx1-treat-as-call whole) + (nx1-treat-as-call context whole) (make-acode (%nx1-operator make-list) - (nx1-form size) - (nx1-form (%cadr keys))))) + (nx1-form :value size) + (nx1-form :value (%cadr keys))))) + +(defun nx1-progn-body (context args) + (if (null (cdr args)) + (nx1-form context (%car args)) + (make-acode (%nx1-operator progn) + (collect ((forms)) + (do* () + ((null (cdr args)) + (forms (nx1-form context (car args))) + (forms)) + (forms (nx1-form nil (car args))) + (setq args (cdr args))))))) ;;; New semantics: expansion functions are defined in current lexical environment ;;; vice null environment. May be meaningless ... -(defnx1 nx1-macrolet macrolet (defs &body body) +(defnx1 nx1-macrolet macrolet context (defs &body body) (let* ((old-env *nx-lexical-environment*) (new-env (new-lexical-environment old-env))) @@ -167,8 +224,8 @@ (multiple-value-bind (body decls) (parse-body body new-env) (nx-process-declarations pending decls) - (nx1-progn-body body)))))) + (nx1-progn-body context body)))))) ;;; Does SYMBOL-MACROLET allow declarations ? Yes ... -(defnx1 nx1-symbol-macrolet symbol-macrolet (defs &body forms) +(defnx1 nx1-symbol-macrolet symbol-macrolet context (defs &body forms) (let* ((old-env *nx-lexical-environment*)) (with-nx-declarations (pending) @@ -187,48 +244,45 @@ (setf (var-ea var) (cons :symbol-macro expansion))))) (nx-effect-other-decls pending env) - (nx1-env-body body old-env)))))) - -(defnx1 nx1-progn progn (&body args) - (nx1-progn-body args)) - -(defnx1 nx1-with-c-frame with-c-frame (var &body body) + (nx1-env-body context body old-env)))))) + +(defnx1 nx1-progn progn context (&body args) + (nx1-progn-body context args)) + +(defnx1 nx1-with-c-frame with-c-frame context (var &body body) (make-acode (%nx1-operator with-c-frame) - (nx1-form `(let* ((,var (%foreign-stack-pointer))) + (nx1-form context `(let* ((,var (%foreign-stack-pointer))) ,@body)))) -(defnx1 nx1-with-variable-c-frame with-variable-c-frame (size var &body body) +(defnx1 nx1-with-variable-c-frame with-variable-c-frame context (size var &body body) (make-acode (%nx1-operator with-variable-c-frame) - (nx1-form size) - (nx1-form `(let* ((,var (%foreign-stack-pointer))) - ,@body)))) - - -(defun nx1-progn-body (args) - (if (null (cdr args)) - (nx1-form (%car args)) - (make-acode (%nx1-operator progn) (nx1-formlist args)))) + (nx1-form :value size) + (nx1-form context `(let* ((,var (%foreign-stack-pointer))) + ,@body)))) + + + (defnx1 nx1-unaryop ((%word-to-int) (uvsize) (%reference-external-entry-point) - (%symbol->symptr)) + (%symbol->symptr)) context (arg) (make-acode - (%nx1-default-operator) (nx1-form arg))) - -(defnx1 nx1-nullaryop ((%current-tcr) (%interrupt-poll) (%foreign-stack-pointer) (%current-frame-ptr)) () + (%nx1-default-operator) (nx1-form :value arg))) + +(defnx1 nx1-nullaryop ((%current-tcr) (%interrupt-poll) (%foreign-stack-pointer) (%current-frame-ptr)) context () (make-acode (%nx1-default-operator))) -(defnx1 nx1-fixnum-ref ((%fixnum-ref) (%fixnum-ref-natural)) (base &optional (offset 0)) +(defnx1 nx1-fixnum-ref ((%fixnum-ref) (%fixnum-ref-natural)) context (base &optional (offset 0)) (make-acode (%nx1-default-operator) - (nx1-form base) - (nx1-form offset))) - -(defnx1 nx1-fixnum-ref-double-float ((%fixnum-ref-double-float)) (base &optional (index 0)) + (nx1-form :value base) + (nx1-form :value offset))) + +(defnx1 nx1-fixnum-ref-double-float ((%fixnum-ref-double-float)) context (base &optional (index 0)) (make-acode (%nx1-operator typed-form) 'double-float (make-acode (%nx1-operator %fixnum-ref-double-float) - (nx1-form base) - (nx1-form index)))) - -(defnx1 nx2-fixnum-set-double-float ((%fixnum-set-double-float)) (base index-or-val &optional (val nil val-p)) + (nx1-form :value base) + (nx1-form :value index)))) + +(defnx1 nx2-fixnum-set-double-float ((%fixnum-set-double-float)) context (base index-or-val &optional (val nil val-p)) (unless val-p (setq val index-or-val index-or-val 0)) @@ -236,10 +290,10 @@ 'double-float (make-acode (%nx1-operator %fixnum-set-double-float) - (nx1-form base) - (nx1-form index-or-val) - (nx1-form val)))) + (nx1-form :value base) + (nx1-form :value index-or-val) + (nx1-form :value val)))) -(defnx1 nx1-type-unaryop ((typecode) (lisptag) (fulltag)) +(defnx1 nx1-type-unaryop ((typecode) (lisptag) (fulltag)) context (arg) (let* ((operator @@ -249,8 +303,8 @@ (( fulltag) (%nx1-operator fulltag))))) (make-acode - operator (nx1-form arg)))) + operator (nx1-form :value arg)))) -(defnx1 nx1-code-char ((code-char)) (arg &environment env) +(defnx1 nx1-code-char ((code-char)) context (arg &environment env) (make-acode (if (nx-form-typep arg '(unsigned-byte 8) env) (%nx1-operator %code-char) @@ -258,13 +312,13 @@ (%nx1-operator %valid-code-char) (%nx1-operator code-char))) - (nx1-form arg))) - -(defnx1 nx1-char-code ((char-code)) (arg &environment env) + (nx1-form :value arg))) + +(defnx1 nx1-char-code ((char-code)) context (arg &environment env) (make-acode (if (nx-form-typep arg 'character env) (%nx1-operator %char-code) (%nx1-operator char-code)) - (nx1-form arg))) - -(defnx1 nx1-cXr ((car) (cdr)) (arg &environment env) + (nx1-form :value arg))) + +(defnx1 nx1-cXr ((car) (cdr)) context (arg &environment env) (let* ((op (if (eq *nx-sfname* 'car) (%nx1-operator car) (%nx1-operator cdr))) (inline-op (if (eq op (%nx1-operator car)) (%nx1-operator %car) (%nx1-operator %cdr)))) @@ -272,7 +326,7 @@ inline-op op) - (nx1-prefer-areg arg env)))) - -(defnx1 nx1-rplacX ((rplaca) (rplacd)) (pairform valform &environment env) + (nx1-form :value arg env)))) + +(defnx1 nx1-rplacX ((rplaca) (rplacd)) context (pairform valform &environment env) (let* ((op (if (eq *nx-sfname* 'rplaca) (%nx1-operator rplaca) (%nx1-operator rplacd))) (inline-op (if (eq op (%nx1-operator rplaca)) (%nx1-operator %rplaca) (%nx1-operator %rplacd)))) @@ -283,8 +337,8 @@ inline-op op) - (nx1-prefer-areg pairform env) - (nx1-form valform)))) - -(defnx1 nx1-set-cXr ((set-car) (set-cdr)) (pairform valform &environment env) + (nx1-form :value pairform env) + (nx1-form :value valform env)))) + +(defnx1 nx1-set-cXr ((set-car) (set-cdr)) context (pairform valform &environment env) (let* ((op (if (eq *nx-sfname* 'set-car) (%nx1-operator set-car) (%nx1-operator set-cdr))) (inline-op (if (eq op (%nx1-operator set-car)) (%nx1-operator %rplaca) (%nx1-operator %rplacd))) @@ -294,48 +348,57 @@ (nx-form-typep pairform 'cons env))))) (acode (make-acode (if inline-p inline-op op) - (nx1-prefer-areg pairform env) - (nx1-form valform)))) + (nx1-form :value pairform env) + (nx1-form :value valform)))) (if inline-p (make-acode (if (eq op (%nx1-operator set-car)) (%nx1-operator %car) (%nx1-operator %cdr)) acode) acode))) -(defun nx1-cc-binaryop (op cc form1 form2) - (make-acode op (nx1-immediate cc) (nx1-form form1) (nx1-form form2))) - -(defnx1 nx1-ccEQ-unaryop ((characterp) (endp) (consp) (base-char-p)) (arg) - (make-acode (%nx1-default-operator) (nx1-immediate :EQ) (nx1-form arg))) - - - -(defnx1 nx1-ccEQ-binaryop ( (%ptr-eql) (eq)) +(defun nx1-cc-binaryop (context op cc form1 form2) + (declare (ignorable context)) + (make-acode op + (nx1-immediate :value cc) + (nx1-form :value form1) (nx1-form :value form2))) + +(defnx1 nx1-ccEQ-unaryop ((characterp) (endp) (consp) (base-char-p)) context (arg) + (make-acode (%nx1-default-operator) + (nx1-immediate :value :EQ) + (nx1-form :value arg))) + + + +(defnx1 nx1-ccEQ-binaryop ( (%ptr-eql) (eq)) context (form1 form2) - (nx1-cc-binaryop (%nx1-default-operator) :eq form1 form2)) - - -(defnx1 nx1-ccNE-binaryop ((neq)) + (nx1-cc-binaryop context (%nx1-default-operator) :eq form1 form2)) + + +(defnx1 nx1-ccNE-binaryop ((neq)) context (form1 form2) - (nx1-cc-binaryop (%nx1-default-operator) :ne form1 form2)) - -(defnx1 nx1-logbitp ((logbitp)) (bitnum int &environment env) + (nx1-cc-binaryop context (%nx1-default-operator) :ne form1 form2)) + +(defnx1 nx1-logbitp ((logbitp)) context (bitnum int &environment env) (if (and (nx-form-typep bitnum (target-word-size-case (32 '(integer 0 29)) (64 '(integer 0 60))) env) (nx-form-typep int 'fixnum env)) - (nx1-cc-binaryop (%nx1-operator %ilogbitp) :ne bitnum int) - (make-acode (%nx1-operator logbitp) (nx1-form bitnum) (nx1-form int)))) + (nx1-cc-binaryop context (%nx1-operator %ilogbitp) :ne bitnum int) + (make-acode (%nx1-operator logbitp) + (nx1-form :value bitnum) + (nx1-form :value int)))) -(defnx1 nx1-ccGT-unaryop ((int>0-p)) (arg) - (make-acode (%nx1-default-operator) (nx1-immediate :gt) (nx1-form arg))) - -(defnx1 nx1-macro-unaryop (multiple-value-list) (arg) +(defnx1 nx1-ccGT-unaryop ((int>0-p)) context (arg) + (make-acode (%nx1-default-operator) + (nx1-immediate :value :gt) + (nx1-form :value arg))) + +(defnx1 nx1-macro-unaryop (multiple-value-list) context (arg) (make-acode - (%nx1-default-operator) (nx1-form arg))) - -(defnx1 nx1-atom ((atom)) (arg) - (nx1-form `(not (consp ,arg)))) - -(defnx1 nx1-locally locally (&body forms) + (%nx1-default-operator) (nx1-form :value arg))) + +(defnx1 nx1-atom ((atom)) context (arg) + (nx1-form context `(not (consp ,arg)))) + +(defnx1 nx1-locally locally context (&body forms) (with-nx-declarations (pending) (let ((env *nx-lexical-environment*)) @@ -343,18 +406,20 @@ (nx-process-declarations pending decls) (nx-effect-other-decls pending env) - (setq body (nx1-progn-body body)) + (setq body (nx1-progn-body context body)) (if decls (make-acode (%nx1-operator %decls-body) body *nx-new-p2decls*) body))))) -(defnx1 nx1-%new-ptr (%new-ptr) (size &optional clear-p) - (make-acode (%nx1-operator %new-ptr) (nx1-form size) (nx1-form clear-p))) +(defnx1 nx1-%new-ptr (%new-ptr) context (size &optional clear-p) + (make-acode (%nx1-operator %new-ptr) + (nx1-form :value size) + (nx1-form :value clear-p))) ;;; This might also want to look at, e.g., the last form in a progn: ;;; (not (progn ... x)) => (progn ... (not x)), etc. -(defnx1 nx1-negation ((not) (null)) (arg) - (if (nx1-negate-form (setq arg (nx1-form arg))) +(defnx1 nx1-negation ((not) (null)) context (arg) + (if (nx1-negate-form (setq arg (nx1-form context arg))) arg - (make-acode (%nx1-operator not) (nx1-immediate :eq) arg))) + (make-acode (%nx1-operator not) (nx1-immediate context :eq) arg))) (defun nx1-negate-form (form) @@ -381,5 +446,5 @@ -(defnx1 nx1-cxxr ((caar) (cadr) (cdar) (cddr)) (form) +(defnx1 nx1-cxxr ((caar) (cadr) (cdar) (cddr)) context (form) (let* ((op *nx-sfname*)) (let* ((inner (case op @@ -389,92 +454,94 @@ ((cdar cddr) 'cdr) (t 'car)))) - (nx1-form `(,outer (,inner ,form)))))) - -(defnx1 nx1-%int-to-ptr ((%int-to-ptr)) (int) + (nx1-form :value `(,outer (,inner ,form)))))) + +(defnx1 nx1-%int-to-ptr ((%int-to-ptr)) context (int) (make-acode (%nx1-operator %consmacptr%) (make-acode (%nx1-operator %immediate-int-to-ptr) - (nx1-form int)))) - -(defnx1 nx1-%ptr-to-int ((%ptr-to-int)) (ptr) + (nx1-form :value int)))) + +(defnx1 nx1-%ptr-to-int ((%ptr-to-int)) context (ptr) (make-acode (%nx1-operator %immediate-ptr-to-int) (make-acode (%nx1-operator %macptrptr%) - (nx1-form ptr)))) - -(defnx1 nx1-%null-ptr-p ((%null-ptr-p)) (ptr) - (nx1-form `(%ptr-eql ,ptr (%int-to-ptr 0)))) + (nx1-form :value ptr)))) + +(defnx1 nx1-%null-ptr-p ((%null-ptr-p)) context (ptr) + (nx1-form :value `(%ptr-eql ,ptr (%int-to-ptr 0)))) (defnx1 nx1-binop ( (%ilsl) (%ilsr) (%iasr) - (cons) (%temp-cons)) + (cons) (%temp-cons)) context (arg1 arg2) - (make-acode (%nx1-default-operator) (nx1-form arg1) (nx1-form arg2))) - - - -(defnx1 nx1-%misc-ref ((%misc-ref)) (v i) - (make-acode (%nx1-operator uvref) (nx1-form v) (nx1-form i))) - - - - -(defnx1 nx1-schar ((schar)) (s i &environment env) - (make-acode (%nx1-operator %sbchar) (nx1-form s env) (nx1-form i env))) + (make-acode (%nx1-default-operator) (nx1-form :value arg1) (nx1-form :value arg2))) + + + +(defnx1 nx1-%misc-ref ((%misc-ref)) context (v i) + (make-acode (%nx1-operator uvref) (nx1-form :value v) (nx1-form :value i))) + + + + +(defnx1 nx1-schar ((schar)) context (s i &environment env) + (make-acode (%nx1-operator %sbchar) (nx1-form :value s env) (nx1-form :value i env))) ;;; This has to be ultra-bizarre because %schar is a macro. ;;; %schar shouldn't be a macro. -(defnx1 nx1-%schar ((%schar)) (arg idx &environment env) - (let* ((arg (nx-transform arg env)) - (idx (nx-transform idx env)) - (argvar (make-symbol "STRING")) - (idxvar (make-symbol "INDEX"))) - (nx1-form `(let* ((,argvar ,arg) - (,idxvar ,idx)) - (declare (optimize (speed 3) (safety 0))) - (declare (simple-base-string ,argvar)) - (schar ,argvar ,idxvar)) env))) +(defnx1 nx1-%schar ((%schar)) context (arg idx &environment env) + (let* ((arg (nx-transform arg env)) + (idx (nx-transform idx env)) + (argvar (make-symbol "STRING")) + (idxvar (make-symbol "INDEX"))) + (nx1-form context + `(let* ((,argvar ,arg) + (,idxvar ,idx)) + (declare (optimize (speed 3) (safety 0))) + (declare (simple-base-string ,argvar)) + (schar ,argvar ,idxvar)) env))) -(defnx1 nx1-%scharcode ((%scharcode)) (arg idx) - (make-acode (%nx1-operator %scharcode) (nx1-form arg)(nx1-form idx))) - - -(defnx1 nx1-svref ((svref) (%svref)) (&environment env v i) +(defnx1 nx1-%scharcode ((%scharcode)) context (arg idx) + (make-acode (%nx1-operator %scharcode) (nx1-form :value arg)(nx1-form :value idx))) + + +(defnx1 nx1-svref ((svref) (%svref)) context (&environment env v i) (make-acode (if (nx-inhibit-safety-checking env) (%nx1-operator %svref) (%nx1-default-operator)) - (nx1-prefer-areg v env) - (nx1-form i))) - -(defnx1 nx1-%slot-ref ((%slot-ref)) (instance idx) + (nx1-form :value v env) + (nx1-form :value i))) + +(defnx1 nx1-%slot-ref ((%slot-ref)) context (instance idx) (make-acode (%nx1-default-operator) - (nx1-form instance) - (nx1-form idx))) - - -(defnx1 nx1-%err-disp ((%err-disp)) (&rest args) + (nx1-form :value instance) + (nx1-form :value idx))) + + +(defnx1 nx1-%err-disp ((%err-disp)) context (&rest args) (make-acode (%nx1-operator %err-disp) (nx1-arglist args))) -(defnx1 nx1-macro-binop ((nth-value)) (arg1 arg2) - (make-acode (%nx1-default-operator) (nx1-form arg1) (nx1-form arg2))) - -(defnx1 nx1-%typed-miscref ((%typed-miscref) (%typed-misc-ref)) (subtype uvector index) +(defnx1 nx1-macro-binop ((nth-value)) context (arg1 arg2) + (make-acode (%nx1-default-operator) (nx1-form :value arg1) (nx1-form :value arg2))) + +(defnx1 nx1-%typed-miscref ((%typed-miscref) (%typed-misc-ref)) context (subtype uvector index) (make-acode (%nx1-operator %typed-uvref) - (nx1-form subtype) - (nx1-form uvector) - (nx1-form index))) - - - -(defnx1 nx1-%typed-miscset ((%typed-miscset) (%typed-misc-set)) (subtype uvector index newvalue) + (nx1-form :value subtype) + (nx1-form :value uvector) + (nx1-form :value index))) + + + +(defnx1 nx1-%typed-miscset ((%typed-miscset) (%typed-misc-set)) context (subtype uvector index newvalue) (make-acode (%nx1-operator %typed-uvset) - (nx1-form subtype) - (nx1-form uvector) - (nx1-form index) - (nx1-form newvalue))) - -(defnx1 nx1-logior-2 ((logior-2)) (&whole w &environment env arg-1 arg-2) - (nx-binary-boole-op w + (nx1-form :value subtype) + (nx1-form :value uvector) + (nx1-form :value index) + (nx1-form :value newvalue))) + +(defnx1 nx1-logior-2 ((logior-2)) context (&whole w &environment env arg-1 arg-2) + (nx-binary-boole-op context + w env arg-1 @@ -484,6 +551,7 @@ (%nx1-operator %natural-logior))) -(defnx1 nx1-logxor-2 ((logxor-2)) (&whole w &environment env arg-1 arg-2) - (nx-binary-boole-op w +(defnx1 nx1-logxor-2 ((logxor-2)) context (&whole w &environment env arg-1 arg-2) + (nx-binary-boole-op context + w env arg-1 @@ -493,5 +561,5 @@ (%nx1-operator %natural-logxor))) -(defnx1 nx1-logand-2 ((logand-2)) (&environment env arg-1 arg-2) +(defnx1 nx1-logand-2 ((logand-2)) context (&environment env arg-1 arg-2) (let* ((nat1 (nx-form-typep arg-1 *nx-target-natural-type* env)) (nat2 (nx-form-typep arg-2 *nx-target-natural-type* env))) @@ -501,12 +569,12 @@ *nx-target-fixnum-type* (make-acode (%nx1-operator %ilogand2) - (nx1-form arg-1 env) - (nx1-form arg-2 env)))) + (nx1-form :value arg-1 env) + (nx1-form :value arg-2 env)))) ((and nat1 (typep arg-2 'integer)) (make-acode (%nx1-operator typed-form) *nx-target-natural-type* (make-acode (%nx1-operator %natural-logand) - (nx1-form arg-1 env) - (nx1-form (logand arg-2 + (nx1-form :value arg-1 env) + (nx1-form :value (logand arg-2 (1- (ash 1 (target-word-size-case (32 32) @@ -517,6 +585,6 @@ *nx-target-natural-type* (make-acode (%nx1-operator %natural-logand) - (nx1-form arg-2 env) - (nx1-form (logand arg-1 + (nx1-form :value arg-2 env) + (nx1-form :value (logand arg-1 (1- (ash 1 (target-word-size-case (32 32) @@ -527,12 +595,12 @@ *nx-target-natural-type* (make-acode (%nx1-operator %natural-logand) - (nx1-form arg-1 env) - (nx1-form arg-2 env)))) + (nx1-form :value arg-1 env) + (nx1-form :value arg-2 env)))) (t (make-acode (%nx1-operator typed-form) 'integer (make-acode (%nx1-operator logand2) - (nx1-form arg-1 env) - (nx1-form arg-2 env))))))) + (nx1-form :value arg-1 env) + (nx1-form :value arg-2 env))))))) @@ -553,5 +621,5 @@ (require-u32) (require-s64) - (require-u64)) + (require-u64)) context (arg &environment env) @@ -576,12 +644,12 @@ (require-s64 '(signed-byte 64)) (require-u64 '(unsigned-byte 64))))) - (nx1-form `(the ,type ,arg))) - (make-acode (%nx1-default-operator) (nx1-form arg)))) - -(defnx1 nx1-%marker-marker ((%unbound-marker) (%slot-unbound-marker) (%illegal-marker)) () + (nx1-form context `(the ,type ,arg))) + (make-acode (%nx1-default-operator) (nx1-form :value arg)))) + +(defnx1 nx1-%marker-marker ((%unbound-marker) (%slot-unbound-marker) (%illegal-marker)) context () (make-acode (%nx1-default-operator))) -(defnx1 nx1-throw (throw) (tag valuesform) - (make-acode (%nx1-operator throw) (nx1-form tag) (nx1-form valuesform))) +(defnx1 nx1-throw (throw) context (tag valuesform) + (make-acode (%nx1-operator throw) (nx1-form :value tag) (nx1-form :value valuesform))) @@ -600,8 +668,8 @@ ;;; contain whatever randomness is floating around at the point of ;;; application.) -(defun nx1-destructure (lambda-list bindform cdr-p &whole-allowed-p forms &optional (body-env *nx-lexical-environment*)) +(defun nx1-destructure (context lambda-list bindform cdr-p &whole-allowed-p forms &optional (body-env *nx-lexical-environment*)) (let* ((old-env body-env) (*nx-bound-vars* *nx-bound-vars*) - (bindform (nx1-form bindform))) + (bindform (nx1-form :value bindform))) (if (not (verify-lambda-list lambda-list t &whole-allowed-p)) (nx-error "Invalid lambda-list ~s" lambda-list) @@ -624,5 +692,5 @@ auxen whole - (nx1-env-body body old-env) + (nx1-env-body context body old-env) *nx-new-p2decls* cdr-p)))))))) @@ -630,7 +698,7 @@ -(defnx1 nx1-%setf-macptr ((%setf-macptr)) (ptr newval) - (let* ((arg1 (nx1-form ptr)) - (arg2 (nx1-form newval))) +(defnx1 nx1-%setf-macptr ((%setf-macptr)) context (ptr newval) + (let* ((arg1 (nx1-form :value ptr)) + (arg2 (nx1-form :value newval))) (if (and (consp arg1) (eq (%car arg1) (%nx1-operator %consmacptr%))) ;e.g. (%setf-macptr (%null-ptr) ) @@ -640,30 +708,30 @@ (make-acode (%nx1-operator %setf-macptr) arg1 arg2)))) -(defnx1 nx1-%setf-double-float ((%setf-double-float)) (double-node double-val) - (make-acode (%nx1-operator %setf-double-float) (nx1-form double-node) (nx1-form double-val))) - -(defnx1 nx1-%setf-short-float ((%setf-short-float) (%setf-single-float)) (short-node short-val) +(defnx1 nx1-%setf-double-float ((%setf-double-float)) context (double-node double-val) + (make-acode (%nx1-operator %setf-double-float) (nx1-form :value double-node) (nx1-form :value double-val))) + +(defnx1 nx1-%setf-short-float ((%setf-short-float) (%setf-single-float)) context (short-node short-val) (target-word-size-case (32 - (make-acode (%nx1-operator %setf-short-float) (nx1-form short-node) (nx1-form short-val))) + (make-acode (%nx1-operator %setf-short-float) (nx1-form :value short-node) (nx1-form :value short-val))) (64 (error "%SETF-SHORT-FLOAT makes no sense on 64-bit platforms.")))) -(defnx1 nx1-%inc-ptr ((%inc-ptr)) (ptr &optional (increment 1)) +(defnx1 nx1-%inc-ptr ((%inc-ptr)) context (ptr &optional (increment 1)) (make-acode (%nx1-operator %consmacptr%) (make-acode (%nx1-operator %immediate-inc-ptr) - (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr)) - (nx1-form increment)))) - -(defnx1 nx1-svset ((svset) (%svset)) (&environment env vector index value) + (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptr)) + (nx1-form :value increment)))) + +(defnx1 nx1-svset ((svset) (%svset)) context (&environment env vector index value) (make-acode (if (nx-inhibit-safety-checking env) (%nx1-operator %svset) (%nx1-default-operator)) - (nx1-prefer-areg vector env) (nx1-form index) (nx1-form value))) - -(defnx1 nx1-+ ((+-2)) (&environment env num1 num2) - (let* ((f1 (nx1-form num1)) - (f2 (nx1-form num2))) + (nx1-form :value vector env) (nx1-form :value index) (nx1-form :value value))) + +(defnx1 nx1-+ ((+-2)) context (&environment env num1 num2) + (let* ((f1 (nx1-form :value num1)) + (f2 (nx1-form :value num2))) (if (nx-binary-fixnum-op-p num1 num2 env t) (let* ((fixadd (make-acode (%nx1-operator %i+) f1 f2)) @@ -678,8 +746,8 @@ (if (and (nx-form-typep num1 'double-float env) (nx-form-typep num2 'double-float env)) - (nx1-form `(%double-float+-2 ,num1 ,num2)) + (nx1-form context `(%double-float+-2 ,num1 ,num2)) (if (and (nx-form-typep num1 'short-float env) (nx-form-typep num2 'short-float env)) - (nx1-form `(%short-float+-2 ,num1 ,num2)) + (nx1-form context `(%short-float+-2 ,num1 ,num2)) (if (nx-binary-natural-op-p num1 num2 env nil) (make-acode (%nx1-operator typed-form) @@ -689,33 +757,33 @@ (make-acode (%nx1-operator add2) f1 f2)))))))) -(defnx1 nx1-%double-float-x-2 ((%double-float+-2) (%double-float--2) (%double-float*-2) (%double-float/-2 )) +(defnx1 nx1-%double-float-x-2 ((%double-float+-2) (%double-float--2) (%double-float*-2) (%double-float/-2 )) context (f0 f1) (make-acode (%nx1-operator typed-form) 'double-float - (make-acode (%nx1-default-operator) (nx1-form f0) (nx1-form f1)))) - - -(defnx1 nx1-%short-float-x-2 ((%short-float+-2) (%short-float--2) (%short-float*-2) (%short-float/-2 )) + (make-acode (%nx1-default-operator) (nx1-form :value f0) (nx1-form :value f1)))) + + +(defnx1 nx1-%short-float-x-2 ((%short-float+-2) (%short-float--2) (%short-float*-2) (%short-float/-2 )) context (f0 f1) (make-acode (%nx1-operator typed-form) 'short-float - (make-acode (%nx1-default-operator) (nx1-form f0) (nx1-form f1)))) - - -(defnx1 nx1-*-2 ((*-2)) (&environment env num1 num2) + (make-acode (%nx1-default-operator) (nx1-form :value f0) (nx1-form :value f1)))) + + +(defnx1 nx1-*-2 ((*-2)) context (&environment env num1 num2) (if (nx-binary-fixnum-op-p num1 num2 env) - (make-acode (%nx1-operator %i*) (nx1-form num1 env) (nx1-form num2 env)) + (make-acode (%nx1-operator %i*) (nx1-form :value num1 env) (nx1-form :value num2 env)) (if (and (nx-form-typep num1 'double-float env) (nx-form-typep num2 'double-float env)) - (nx1-form `(%double-float*-2 ,num1 ,num2)) + (nx1-form context `(%double-float*-2 ,num1 ,num2)) (if (and (nx-form-typep num1 'short-float env) (nx-form-typep num2 'short-float env)) - (nx1-form `(%short-float*-2 ,num1 ,num2)) - (make-acode (%nx1-operator mul2) (nx1-form num1 env) (nx1-form num2 env)))))) - -(defnx1 nx1-%negate ((%negate)) (num &environment env) + (nx1-form context `(%short-float*-2 ,num1 ,num2)) + (make-acode (%nx1-operator mul2) (nx1-form :value num1 env) (nx1-form :value num2 env)))))) + +(defnx1 nx1-%negate ((%negate)) context (num &environment env) (if (nx-form-typep num 'fixnum env) (if (subtypep *nx-form-type* 'fixnum) - (make-acode (%nx1-operator %%ineg)(nx1-form num)) - (make-acode (%nx1-operator %ineg) (nx1-form num))) - (let* ((acode (make-acode (%nx1-operator minus1) (nx1-form num env)))) + (make-acode (%nx1-operator %%ineg)(nx1-form :value num)) + (make-acode (%nx1-operator %ineg) (nx1-form :value num))) + (let* ((acode (make-acode (%nx1-operator minus1) (nx1-form :value num env)))) (if (nx-form-typep num 'double-float env) (make-acode (%nx1-operator typed-form) @@ -731,8 +799,8 @@ -(defnx1 nx1--2 ((--2)) (&environment env num0 num1) +(defnx1 nx1--2 ((--2)) context (&environment env num0 num1) (if (nx-binary-fixnum-op-p num0 num1 env t) - (let* ((f0 (nx1-form num0)) - (f1 (nx1-form num1)) + (let* ((f0 (nx1-form :value num0)) + (f1 (nx1-form :value num1)) (fixsub (make-acode (%nx1-operator %i-) f0 f1)) (small-enough (target-word-size-case @@ -746,28 +814,28 @@ (if (and (nx-form-typep num0 'double-float env) (nx-form-typep num1 'double-float env)) - (nx1-form `(%double-float--2 ,num0 ,num1)) + (nx1-form context `(%double-float--2 ,num0 ,num1)) (if (and (nx-form-typep num0 'short-float env) (nx-form-typep num1 'short-float env)) - (nx1-form `(%short-float--2 ,num0 ,num1)) + (nx1-form context `(%short-float--2 ,num0 ,num1)) (if (nx-binary-natural-op-p num0 num1 env nil) (make-acode (%nx1-operator %natural-) - (nx1-form num0) - (nx1-form num1)) + (nx1-form :value num0) + (nx1-form :value num1)) (make-acode (%nx1-operator sub2) - (nx1-form num0) - (nx1-form num1))))))) + (nx1-form :value num0) + (nx1-form :value num1))))))) -(defnx1 nx1-/-2 ((/-2)) (num0 num1 &environment env) +(defnx1 nx1-/-2 ((/-2)) context (num0 num1 &environment env) (if (and (nx-form-typep num0 'double-float env) (nx-form-typep num1 'double-float env)) - (nx1-form `(%double-float/-2 ,num0 ,num1)) + (nx1-form context `(%double-float/-2 ,num0 ,num1)) (if (and (nx-form-typep num0 'short-float env) (nx-form-typep num1 'short-float env)) - (nx1-form `(%short-float/-2 ,num0 ,num1)) - (make-acode (%nx1-operator div2) (nx1-form num0) (nx1-form num1))))) - - - -(defnx1 nx1-numcmp ((<-2) (>-2) (<=-2) (>=-2)) (&environment env num1 num2) + (nx1-form context `(%short-float/-2 ,num0 ,num1)) + (make-acode (%nx1-operator div2) (nx1-form :value num0) (nx1-form :value num1))))) + + + +(defnx1 nx1-numcmp ((<-2) (>-2) (<=-2) (>=-2)) context (&environment env num1 num2) (let* ((op *nx-sfname*) (both-fixnums (nx-binary-fixnum-op-p num1 num2 env t)) @@ -804,6 +872,6 @@ :LE :GT)))) - (nx1-form num1) - (nx1-form num2)) + (nx1-form :value num1) + (nx1-form :value num2)) (make-acode (%nx1-operator numcmp) (make-acode @@ -816,8 +884,8 @@ :LE :GT)))) - (nx1-form num1) - (nx1-form num2))))) - -(defnx1 nx1-num= ((=-2) (/=-2)) (&environment env num1 num2 ) + (nx1-form :value num1) + (nx1-form :value num2))))) + +(defnx1 nx1-num= ((=-2) (/=-2)) context (&environment env num1 num2 ) (let* ((op *nx-sfname*) (2-fixnums (nx-binary-fixnum-op-p num1 num2 env t)) @@ -844,9 +912,9 @@ :EQ :NE)) - (nx1-form num1) - (nx1-form num2)) + (nx1-form :value num1) + (nx1-form :value num2)) (if 2-rats (let* ((form `(,(if 2-fixnums 'eq 'eql) ,num1 ,num2))) - (nx1-form (if (eq op '=-2) form `(not ,form)))) + (nx1-form context (if (eq op '=-2) form `(not ,form)))) (if (or 2-dfloats 2-sfloats) (make-acode @@ -859,6 +927,6 @@ :EQ :NE)) - (nx1-form num1) - (nx1-form num2)) + (nx1-form :value num1) + (nx1-form :value num2)) (make-acode (%nx1-operator numcmp) (make-acode @@ -867,20 +935,20 @@ :EQ :NE)) - (nx1-form num1) - (nx1-form num2))))))) + (nx1-form :value num1) + (nx1-form :value num2))))))) -(defnx1 nx1-uvset ((uvset) (%misc-set)) (vector index value) +(defnx1 nx1-uvset ((uvset) (%misc-set)) context (vector index value) (make-acode (%nx1-operator uvset) - (nx1-form vector) - (nx1-form index) - (nx1-form value))) - -(defnx1 nx1-set-schar ((set-schar)) (s i v) - (make-acode (%nx1-operator %set-sbchar) (nx1-form s) (nx1-form i) (nx1-form v))) - - - -(defnx1 nx1-%set-schar ((%set-schar)) (arg idx char &environment env) + (nx1-form :value vector) + (nx1-form :value index) + (nx1-form :value value))) + +(defnx1 nx1-set-schar ((set-schar)) context (s i v) + (make-acode (%nx1-operator %set-sbchar) (nx1-form :value s) (nx1-form :value i) (nx1-form :value v))) + + + +(defnx1 nx1-%set-schar ((%set-schar)) context (arg idx char &environment env) (let* ((arg (nx-transform arg env)) (idx (nx-transform idx env)) @@ -889,36 +957,37 @@ (idxvar (make-symbol "IDX")) (charvar (make-symbol "CHAR"))) - (nx1-form `(let* ((,argvar ,arg) + (nx1-form context + `(let* ((,argvar ,arg) (,idxvar ,idx) (,charvar ,char)) - (declare (optimize (speed 3) (safety 0))) - (declare (simple-base-string ,argvar)) - (setf (schar ,argvar ,idxvar) ,charvar)) + (declare (optimize (speed 3) (safety 0))) + (declare (simple-base-string ,argvar)) + (setf (schar ,argvar ,idxvar) ,charvar)) env))) -(defnx1 nx1-%set-scharcode ((%set-scharcode)) (s i v) +(defnx1 nx1-%set-scharcode ((%set-scharcode)) context (s i v) (make-acode (%nx1-operator %set-scharcode) - (nx1-form s) - (nx1-form i) - (nx1-form v))) + (nx1-form :value s) + (nx1-form :value i) + (nx1-form :value v))) -(defnx1 nx1-list-vector-values ((list) (vector) (values) (%temp-list)) (&rest args) - (make-acode (%nx1-default-operator) (nx1-formlist args))) - - - -(defnx1 nx1-%gvector ( (%gvector)) (&rest args) +(defnx1 nx1-list-vector-values ((list) (vector) (values) (%temp-list)) context (&rest args) + (make-acode (%nx1-default-operator) (nx1-formlist context args))) + + + +(defnx1 nx1-%gvector ( (%gvector)) context (&rest args) (make-acode (%nx1-operator %gvector) (nx1-arglist args))) -(defnx1 nx1-quote quote (form) - (nx1-immediate form)) - -(defnx1 nx1-list* ((list*)) (first &rest rest) +(defnx1 nx1-quote quote context (form) + (nx1-immediate context form)) + +(defnx1 nx1-list* ((list*)) context (first &rest rest) (make-acode (%nx1-operator list*) (nx1-arglist (cons first rest) 1))) #| -(defnx1 nx1-append ((append)) (&rest args) +(defnx1 nx1-append ((append)) context (&rest args) (make-acode (%nx1-operator append) (nx1-arglist args 2))) @@ -926,18 +995,18 @@ |# -(defnx1 nx1-or or (&whole whole &optional (firstform nil firstform-p) &rest moreforms) +(defnx1 nx1-or or context (&whole whole &optional (firstform nil firstform-p) &rest moreforms) (if (not firstform-p) - (nx1-form nil) + (nx1-form context nil) (if (null moreforms) - (nx1-form firstform) + (nx1-form context firstform) (progn - (make-acode (%nx1-operator or) (nx1-formlist (%cdr whole))))))) - -(defun nx1-1d-vref (env arr dim0 &optional uvref-p) + (make-acode (%nx1-operator or) (nx1-formlist context (%cdr whole))))))) + +(defun nx1-1d-vref (context env arr dim0 &optional uvref-p) (let* ((simple-vector-p (nx-form-typep arr 'simple-vector env)) (string-p (unless simple-vector-p (if (nx-form-typep arr 'string env) (or (nx-form-typep arr 'simple-string env) - (return-from nx1-1d-vref (nx1-form `(char ,arr ,dim0))))))) + (return-from nx1-1d-vref (nx1-form context `(char ,arr ,dim0))))))) (simple-1d-array-p (unless (or simple-vector-p string-p) (nx-form-typep arr '(simple-array * (*)) env))) @@ -950,7 +1019,7 @@ (if (and simple-1d-array-p type-keyword) (make-acode (%nx1-operator %typed-uvref) - (nx1-immediate type-keyword) - (nx1-form arr) - (nx1-form dim0)) + (nx1-immediate :value type-keyword) + (nx1-form :value arr) + (nx1-form :value dim0)) (let* ((op (cond (simple-1d-array-p (%nx1-operator uvref)) (string-p (%nx1-operator %sbchar)) @@ -959,20 +1028,20 @@ (uvref-p (%nx1-operator uvref)) (t (%nx1-operator %aref1))))) - (make-acode op (nx1-form arr) (nx1-form dim0)))))) + (make-acode op (nx1-form :value arr) (nx1-form :value dim0)))))) -(defnx1 nx1-aref ((aref)) (&whole whole &environment env arr &optional (dim0 nil dim0-p) +(defnx1 nx1-aref ((aref)) context (&whole whole &environment env arr &optional (dim0 nil dim0-p) &rest other-dims) (if (and dim0-p (null other-dims)) - (nx1-1d-vref env arr dim0) - (nx1-treat-as-call whole))) - -(defnx1 nx1-uvref ((uvref)) (&environment env arr dim0) - (nx1-1d-vref env arr dim0 t)) - -(defnx1 nx1-%aref2 ((%aref2)) (&whole whole &environment env arr i j) + (nx1-1d-vref context env arr dim0) + (nx1-treat-as-call context whole))) + +(defnx1 nx1-uvref ((uvref)) context (&environment env arr dim0) + (nx1-1d-vref context env arr dim0 t)) + +(defnx1 nx1-%aref2 ((%aref2)) context (&whole whole &environment env arr i j) ;; Bleah. Breaks modularity. Specialize later. (target-arch-case (:x8632 - (return-from nx1-%aref2 (nx1-treat-as-call whole)))) + (return-from nx1-%aref2 (nx1-treat-as-call context whole)))) (let* ((arch (backend-target-arch *target-backend*)) @@ -991,20 +1060,20 @@ (dim1 (cadr dims))) (make-acode (%nx1-operator simple-typed-aref2) - (nx1-form type-keyword) - (nx1-form arr) - (nx1-form i) - (nx1-form j) - (nx1-form (if (typep dim0 'fixnum) dim0)) - (nx1-form (if (typep dim1 'fixnum) dim1)))) + (nx1-form :value type-keyword) + (nx1-form :value arr) + (nx1-form :value i) + (nx1-form :value j) + (nx1-form :value (if (typep dim0 'fixnum) dim0)) + (nx1-form :value (if (typep dim1 'fixnum) dim1)))) (make-acode (%nx1-operator general-aref2) - (nx1-form arr) - (nx1-form i) - (nx1-form j))))) - -(defnx1 nx1-%aref3 ((%aref3)) (&whole whole &environment env arr i j k) + (nx1-form :value arr) + (nx1-form :value i) + (nx1-form :value j))))) + +(defnx1 nx1-%aref3 ((%aref3)) context (&whole whole &environment env arr i j k) ;; Bleah. Breaks modularity. Specialize later. (target-arch-case (:x8632 - (return-from nx1-%aref3 (nx1-treat-as-call whole)))) + (return-from nx1-%aref3 (nx1-treat-as-call context whole)))) (let* ((arch (backend-target-arch *target-backend*)) @@ -1024,24 +1093,24 @@ (dim2 (caddr dims))) (make-acode (%nx1-operator simple-typed-aref3) - (nx1-form type-keyword) - (nx1-form arr) - (nx1-form i) - (nx1-form j) - (nx1-form k) - (nx1-form (if (typep dim0 'fixnum) dim0)) - (nx1-form (if (typep dim1 'fixnum) dim1)) - (nx1-form (if (typep dim2 'fixnum) dim2)))) + (nx1-form :value type-keyword) + (nx1-form :value arr) + (nx1-form :value i) + (nx1-form :value j) + (nx1-form :value k) + (nx1-form :value (if (typep dim0 'fixnum) dim0)) + (nx1-form :value (if (typep dim1 'fixnum) dim1)) + (nx1-form :value (if (typep dim2 'fixnum) dim2)))) (make-acode (%nx1-operator general-aref3) - (nx1-form arr) - (nx1-form i) - (nx1-form j) - (nx1-form k))))) - -(defun nx1-1d-vset (arr newval dim0 env) + (nx1-form :value arr) + (nx1-form :value i) + (nx1-form :value j) + (nx1-form :value k))))) + +(defun nx1-1d-vset (context arr newval dim0 env) (let* ((simple-vector-p (nx-form-typep arr 'simple-vector env)) (string-p (unless simple-vector-p (if (nx-form-typep arr 'string env) (or (nx-form-typep arr 'simple-string env) - (return-from nx1-1d-vset (nx1-form `(set-char ,arr ,newval ,dim0))))))) + (return-from nx1-1d-vset (nx1-form context `(set-char ,arr ,newval ,dim0))))))) (simple-1d-array-p (unless (or simple-vector-p string-p) (nx-form-typep arr '(simple-array * (*)) env))) @@ -1053,8 +1122,8 @@ (if (and type-keyword simple-1d-array-p) (make-acode (%nx1-operator %typed-uvset) - (nx1-immediate type-keyword) - (nx1-form arr) - (nx1-form newval) - (nx1-form dim0)) + (nx1-immediate :value type-keyword) + (nx1-form :value arr) + (nx1-form :value newval) + (nx1-form :value dim0)) (let* ((op (cond (simple-1d-array-p (%nx1-operator uvset)) (string-p (%nx1-operator %set-sbchar)) @@ -1064,10 +1133,10 @@ (make-acode op - (nx1-form arr) - (nx1-form newval) - (nx1-form dim0)) - (nx1-form `(,(if string-p 'set-schar '%aset1) ,arr ,newval ,dim0))))))) - -(defnx1 nx1-aset ((aset)) (&whole whole + (nx1-form :value arr) + (nx1-form :value newval) + (nx1-form :value dim0)) + (nx1-form context `(,(if string-p 'set-schar '%aset1) ,arr ,newval ,dim0))))))) + +(defnx1 nx1-aset ((aset)) context (&whole whole arr newval &optional (dim0 nil dim0-p) @@ -1075,12 +1144,12 @@ &rest other-dims) (if (and dim0-p (null other-dims)) - (nx1-1d-vset arr newval dim0 env) - (nx1-treat-as-call whole))) + (nx1-1d-vset context arr newval dim0 env) + (nx1-treat-as-call context whole))) -(defnx1 nx1-%aset2 ((%aset2)) (&whole whole &environment env arr i j new) +(defnx1 nx1-%aset2 ((%aset2)) context (&whole whole &environment env arr i j new) ;; Bleah. Breaks modularity. Specialize later. (target-arch-case (:x8632 - (return-from nx1-%aset2 (nx1-treat-as-call whole)))) + (return-from nx1-%aset2 (nx1-treat-as-call context whole)))) (let* ((arch (backend-target-arch *target-backend*)) @@ -1100,22 +1169,22 @@ (dim1 (cadr dims))) (make-acode (%nx1-operator simple-typed-aset2) - (nx1-form type-keyword) - (nx1-form arr) - (nx1-form i) - (nx1-form j) - (nx1-form new) - (nx1-form (if (typep dim0 'fixnum) dim0)) - (nx1-form (if (typep dim1 'fixnum) dim1)))) + (nx1-form :value type-keyword) + (nx1-form :value arr) + (nx1-form :value i) + (nx1-form :value j) + (nx1-form :value new) + (nx1-form :value (if (typep dim0 'fixnum) dim0)) + (nx1-form :value (if (typep dim1 'fixnum) dim1)))) (make-acode (%nx1-operator general-aset2) - (nx1-form arr) - (nx1-form i) - (nx1-form j) - (nx1-form new))))) - -(defnx1 nx1-%aset3 ((%aset3)) (&whole whole &environment env arr i j k new) + (nx1-form :value arr) + (nx1-form :value i) + (nx1-form :value j) + (nx1-form :value new))))) + +(defnx1 nx1-%aset3 ((%aset3)) context (&whole whole &environment env arr i j k new) ;; Bleah. Breaks modularity. Specialize later. (target-arch-case (:x8632 - (return-from nx1-%aset3 (nx1-treat-as-call whole)))) + (return-from nx1-%aset3 (nx1-treat-as-call context whole)))) (let* ((arch (backend-target-arch *target-backend*)) @@ -1136,41 +1205,41 @@ (dim2 (caddr dims))) (make-acode (%nx1-operator simple-typed-aset3) - (nx1-form type-keyword) - (nx1-form arr) - (nx1-form i) - (nx1-form j) - (nx1-form k) - (nx1-form new) - (nx1-form (if (typep dim0 'fixnum) dim0)) - (nx1-form (if (typep dim1 'fixnum) dim1)) - (nx1-form (if (typep dim2 'fixnum) dim2)))) + (nx1-form :value type-keyword) + (nx1-form :value arr) + (nx1-form :value i) + (nx1-form :value j) + (nx1-form :value k) + (nx1-form :value new) + (nx1-form :value (if (typep dim0 'fixnum) dim0)) + (nx1-form :value (if (typep dim1 'fixnum) dim1)) + (nx1-form :value (if (typep dim2 'fixnum) dim2)))) (make-acode (%nx1-operator general-aset3) - (nx1-form arr) - (nx1-form i) - (nx1-form j) - (nx1-form k) - (nx1-form new))))) - -(defnx1 nx1-prog1 (prog1 multiple-value-prog1) (save &body args - &aux (l (list (nx1-form save)))) - (make-acode - (%nx1-default-operator) - (dolist (arg args (nreverse l)) - (push (nx1-form arg) l)))) - -(defnx1 nx1-if if (test true &optional false) + (nx1-form :value arr) + (nx1-form :value i) + (nx1-form :value j) + (nx1-form :value k) + (nx1-form :value new))))) + +(defnx1 nx1-prog1 (prog1 multiple-value-prog1) context (save &body args) + (let* ((l (list (nx1-form :value save)))) + (make-acode + (%nx1-default-operator) + (dolist (arg args (nreverse l)) + (push (nx1-form nil arg) l))))) + +(defnx1 nx1-if if context (test true &optional false) (if (null true) (if (null false) - (return-from nx1-if (nx1-form `(progn ,test nil))) + (return-from nx1-if (nx1-form context `(progn ,test nil))) (psetq test `(not ,test) true false false true))) - (let ((test-form (nx1-form test)) + (let ((test-form (nx1-form :value test)) ;; Once hit a conditional, no more duplicate warnings (*compiler-warn-on-duplicate-definitions* nil)) - (make-acode (%nx1-operator if) test-form (nx1-form true) (nx1-form false)))) - -(defnx1 nx1-%debug-trap dbg (&optional arg) - (make-acode (%nx1-operator %debug-trap) (nx1-form arg))) + (make-acode (%nx1-operator if) test-form (nx1-form context true) (nx1-form context false)))) + +(defnx1 nx1-%debug-trap dbg context (&optional arg) + (make-acode (%nx1-operator %debug-trap) (nx1-form :value arg))) -(defnx1 nx1-setq setq (&whole whole &rest args &environment env &aux res) +(defnx1 nx1-setq setq context (&whole whole &rest args &environment env &aux res) (when (%ilogbitp 0 (length args)) (nx-error "Odd number of forms in ~s ." whole)) @@ -1186,5 +1255,5 @@ (multiple-value-bind (expansion win) (macroexpand-1 sym env) (if win - (push (nx1-form `(setf ,expansion ,val)) res) + (push (nx1-form context `(setf ,expansion ,val)) res) (multiple-value-bind (info inherited catchp) (nx-lex-info sym) @@ -1197,8 +1266,8 @@ (%ilsl $vbitreffed 1) (nx-var-bits catchp))) - (nx1-form `(setf ,inherited ,val))) + (nx1-form context `(setf ,inherited ,val))) (let ((valtype (nx-form-type val env))) (let ((*nx-form-type* declared-type)) - (setq val (nx1-typed-form val env))) + (setq val (nx1-typed-form context val env))) (if (and info (neq info :special)) (progn @@ -1256,5 +1325,5 @@ ;;; in a null lexical environment. -(defnx1 nx1-load-time-value (load-time-value) (&environment env form &optional read-only-p) +(defnx1 nx1-load-time-value (load-time-value) context (&environment env form &optional read-only-p) ;; Validate the "read-only-p" argument (if (and read-only-p (neq read-only-p t)) (require-type read-only-p '(member t nil))) @@ -1269,49 +1338,37 @@ :target (backend-name *target-backend*)) (setq *nx-warnings* (append *nx-warnings* warnings)) - (nx1-immediate (list *nx-load-time-eval-token* `(funcall ,function)))) - (nx1-immediate (eval form)))) - -(defnx1 nx1-catch (catch) (operation &body body) - (make-acode (%nx1-operator catch) (nx1-form operation) (nx1-catch-body body))) - -(defnx1 nx1-%badarg ((%badarg)) (badthing right-type &environment env) - (make-acode (%nx1-operator %badarg2) - (nx1-form badthing) - (nx1-form (or (if (nx-form-constant-p right-type env) (%typespec-id (nx-form-constant-value right-type env))) - right-type)))) - -(defnx1 nx1-unwind-protect (unwind-protect) (protected-form &body cleanup-form) - (if cleanup-form - (make-acode (%nx1-operator unwind-protect) - (nx1-catch-body (list protected-form)) - (nx1-progn-body cleanup-form)) - (nx1-form protected-form))) - -(defnx1 nx1-progv progv (symbols values &body body) - (make-acode (%nx1-operator progv) - (nx1-form `(check-symbol-list ,symbols)) - (nx1-form values) - (nx1-catch-body body))) - -(defun nx1-catch-body (body) + (nx1-immediate context (list *nx-load-time-eval-token* `(funcall ,function)))) + (nx1-immediate context (eval form)))) + +(defun nx1-catch-body (context body) (let* ((temp (new-lexical-environment *nx-lexical-environment*))) (setf (lexenv.variables temp) 'catch) (let* ((*nx-lexical-environment* (new-lexical-environment temp))) - (nx1-progn-body body)))) - - -(defnx1 nx1-apply ((apply)) (&whole call fn arg &rest args &environment env) - (let ((last (%car (last (push arg args))))) - (if (and (nx-form-constant-p last env) - (null (nx-form-constant-value last env))) - (nx1-form (let ((new `(funcall ,fn ,@(butlast args)))) - (nx-note-source-transformation call new) - new)) - (nx1-apply-fn fn args t)))) - -(defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (fn arg &rest args) - (nx1-apply-fn fn (cons arg args) 0)) - -(defun nx1-apply-fn (fn args spread) + (nx1-progn-body context body)))) + +(defnx1 nx1-catch (catch) context (operation &body body) + (make-acode (%nx1-operator catch) (nx1-form :value operation) (nx1-catch-body context body))) + +(defnx1 nx1-%badarg ((%badarg)) context (badthing right-type &environment env) + (make-acode (%nx1-operator %badarg2) + (nx1-form :value badthing) + (nx1-form :value (or (if (nx-form-constant-p right-type env) (%typespec-id (nx-form-constant-value right-type env))) + right-type)))) + +(defnx1 nx1-unwind-protect (unwind-protect) context (protected-form &body cleanup-form) + (if cleanup-form + (make-acode (%nx1-operator unwind-protect) + (nx1-catch-body context (list protected-form)) + (nx1-progn-body context cleanup-form)) + (nx1-form context protected-form))) + +(defnx1 nx1-progv progv context (symbols values &body body) + (make-acode (%nx1-operator progv) + (nx1-form :value `(check-symbol-list ,symbols)) + (nx1-form :value values) + (nx1-catch-body context body))) + + +(defun nx1-apply-fn (context fn args spread) (let* ((sym (nx1-func-name fn)) (afunc (and (non-nil-symbol-p sym) (nth-value 1 (nx-lexical-finfo sym))))) @@ -1324,10 +1381,25 @@ sym nil args (cons (var-name *nx-next-method-var*) args))) - (nx1-typed-call (if (non-nil-symbol-p sym) sym (nx1-form fn)) args spread))) - - -(defnx1 nx1-%defun %defun (&whole w def &optional (doc nil doc-p) &environment env) + (nx1-typed-call context (if (non-nil-symbol-p sym) sym (nx1-form :value fn)) args spread))) + + +(defnx1 nx1-apply ((apply)) context (&whole call fn arg &rest args &environment env) + (let ((last (%car (last (push arg args))))) + (if (and (nx-form-constant-p last env) + (null (nx-form-constant-value last env))) + (nx1-form context (let ((new `(funcall ,fn ,@(butlast args)))) + (nx-note-source-transformation call new) + new)) + (nx1-apply-fn context fn args t)))) + +(defnx1 nx1-%apply-lexpr ((%apply-lexpr)) context (fn arg &rest args) + (nx1-apply-fn context fn (cons arg args) 0)) + + + + +(defnx1 nx1-%defun %defun context (&whole w def &optional (doc nil doc-p) &environment env) (declare (ignorable doc doc-p)) - ; Pretty bogus. + ;; Pretty bogus. (if (and (consp def) (eq (%car def) 'nfunction) @@ -1335,7 +1407,7 @@ (or (symbolp (%cadr def)) (setf-function-name-p (%cadr def)))) (note-function-info (%cadr def) (caddr def) env)) - (nx1-treat-as-call w)) - -(defnx1 nx1-function function (arg &aux fn afunc) + (nx1-treat-as-call context w)) + +(defnx1 nx1-function function context (arg &aux fn afunc) (cond ((symbolp arg) (when (macro-function arg *nx-lexical-environment*) @@ -1349,11 +1421,11 @@ (when (%ilogbitp $fbitbounddownward (afunc-bits afunc)) (incf (afunc-fn-downward-refcount afunc)))) - (nx1-symbol (%cddr fn))) + (nx1-symbol context (%cddr fn))) (progn (while (setq fn (assq arg *nx-synonyms*)) (setq arg (%cdr fn))) - (nx1-form `(%function ',arg))))) + (nx1-form context `(%function ',arg))))) ((setf-function-name-p arg) - (nx1-form `(function ,(nx-need-function-name arg)))) + (nx1-form context `(function ,(nx-need-function-name arg)))) ((lambda-expression-p arg) (nx1-ref-inner-function nil arg)) @@ -1361,5 +1433,5 @@ (nx-error "~S is not a function name or lambda expression" arg)))) -(defnx1 nx1-nfunction nfunction (name def) +(defnx1 nx1-nfunction nfunction context (name def) (nx1-ref-inner-function name def)) @@ -1396,6 +1468,6 @@ afunc))))) -(defnx1 nx1-%function %function (form &aux symbol) - (let ((sym (nx1-form form))) +(defnx1 nx1-%function %function context (form &aux symbol) + (let ((sym (nx1-form :value form))) (if (and (eq (car sym) (%nx1-operator immediate)) (setq symbol (cadr sym)) @@ -1407,7 +1479,7 @@ (nx1-whine :undefined-function symbol)) (make-acode (%nx1-default-operator) symbol)) - (make-acode (%nx1-operator call) (nx1-immediate '%function) (list nil (list sym)))))) - -(defnx1 nx1-tagbody tagbody (&rest args) + (make-acode (%nx1-operator call) (nx1-immediate context '%function) (list nil (list sym)))))) + +(defnx1 nx1-tagbody tagbody context (&rest args) (let* ((newtags nil) (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*)) @@ -1440,5 +1512,5 @@ (%rplaca (%cdr (%cdr (%cdr (%cdr info)))) t) (cons (%nx1-operator tag-label) info)) - (nx1-form form)) + (nx1-form nil form)) body)) (if (eq 0 (%car counter)) @@ -1451,5 +1523,5 @@ (when (%cadr tag) (push - (nx1-form `(if (eql ,(var-name indexvar) ,(%cadr tag)) (go ,(%car tag)))) + (nx1-form context `(if (eql ,(var-name indexvar) ,(%cadr tag)) (go ,(%car tag)))) body))) (make-acode @@ -1469,5 +1541,5 @@ (make-acode (%nx1-operator catch) - (nx1-form (var-name catchvar)) + (nx1-form :value (var-name catchvar)) (make-acode (%nx1-operator local-tagbody) @@ -1480,5 +1552,5 @@ -(defnx1 nx1-go go (tag) +(defnx1 nx1-go go context (tag) (multiple-value-bind (info closed) (nx-tag-info tag) @@ -1492,5 +1564,5 @@ (make-acode - (%nx1-operator throw) (nx1-symbol (var-name (cadddr info))) (nx1-form closed)))))) + (%nx1-operator throw) (nx1-symbol :value (var-name (cadddr info))) (nx1-form :value closed)))))) @@ -1512,36 +1584,6 @@ :hybrid-int-float :hybrid-float-int :hybrid-float-float)) - -(defnx1 nx1-ff-call ((%ff-call)) (address-expression &rest arg-specs-and-result-spec) - (nx1-ff-call-internal - address-expression arg-specs-and-result-spec - (ecase (backend-name *target-backend*) - ((:linuxppc32 :linuxarm :darwinarm :androidarm) (%nx1-operator eabi-ff-call)) - ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1-operator poweropen-ff-call)) - ((:darwinx8632 :linuxx8632 :win32 :solarisx8632 :freebsdx8632) (%nx1-operator i386-ff-call)) - ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator ff-call))))) - -(defnx1 nx1-syscall ((%syscall)) (idx &rest arg-specs-and-result-spec) - (flet ((map-to-representation-types (list) - (collect ((out)) - (do* ((l list (cddr l))) - ((null (cdr l)) - (if l - (progn - (out (foreign-type-to-representation-type (car l))) - (out)) - (error "Missing result type in ~s" list))) - (out (foreign-type-to-representation-type (car l))) - (out (cadr l)))))) - (nx1-ff-call-internal - idx (map-to-representation-types arg-specs-and-result-spec) - (ecase (backend-name *target-backend*) - (:linuxppc32 (%nx1-operator eabi-syscall)) - ((:darwinppc32 :darwinppc64 :linuxppc64) - (%nx1-operator poweropen-syscall)) - ((:darwinx8632 :linuxx632 :win32) (%nx1-operator i386-syscall)) - ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator syscall)))))) - -(defun nx1-ff-call-internal (address-expression arg-specs-and-result-spec operator ) +(defun nx1-ff-call-internal (context address-expression arg-specs-and-result-spec operator ) + (declare (ignorable context)) (let* ((specs ()) (vals ()) @@ -1586,20 +1628,53 @@ (t t)) (make-acode operator - (nx1-form address-expression) + (nx1-form :value address-expression) (nreverse specs) - (mapcar #'nx1-form (nreverse vals)) + (mapcar (lambda (val) (nx1-form :value val)) (nreverse vals)) result-spec nil) nil))) + +(defnx1 nx1-ff-call ((%ff-call)) context (address-expression &rest arg-specs-and-result-spec) + (nx1-ff-call-internal + context address-expression arg-specs-and-result-spec + (ecase (backend-name *target-backend*) + ((:linuxppc32 :linuxarm :darwinarm :androidarm) (%nx1-operator eabi-ff-call)) + ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1-operator poweropen-ff-call)) + ((:darwinx8632 :linuxx8632 :win32 :solarisx8632 :freebsdx8632) (%nx1-operator i386-ff-call)) + ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator ff-call))))) + +(defnx1 nx1-syscall ((%syscall)) context (idx &rest arg-specs-and-result-spec) + (flet ((map-to-representation-types (list) + (collect ((out)) + (do* ((l list (cddr l))) + ((null (cdr l)) + (if l + (progn + (out (foreign-type-to-representation-type (car l))) + (out)) + (error "Missing result type in ~s" list))) + (out (foreign-type-to-representation-type (car l))) + (out (cadr l)))))) + (nx1-ff-call-internal + context + idx (map-to-representation-types arg-specs-and-result-spec) + (ecase (backend-name *target-backend*) + (:linuxppc32 (%nx1-operator eabi-syscall)) + ((:darwinppc32 :darwinppc64 :linuxppc64) + (%nx1-operator poweropen-syscall)) + ((:darwinx8632 :linuxx632 :win32) (%nx1-operator i386-syscall)) + ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator syscall)))))) + + -(defnx1 nx1-block block (blockname &body forms) +(defnx1 nx1-block block context (blockname &body forms) (let* ((*nx-blocks* *nx-blocks*) (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*)) (*nx-bound-vars* *nx-bound-vars*) (tagvar (nx-new-temp-var (make-pending-declarations))) - (thisblock (cons (setq blockname (nx-need-sym blockname)) tagvar)) + (thisblock (cons (setq blockname (nx-need-sym blockname)) (cons tagvar context))) (body nil)) (push thisblock *nx-blocks*) - (setq body (nx1-progn-body forms)) + (setq body (nx1-progn-body context forms)) (%rplacd thisblock nil) (let ((tagbits (nx-var-bits tagvar))) @@ -1620,5 +1695,5 @@ (%nx1-operator let) (list tagvar) - (list (make-acode (%nx1-operator cons) (nx1-form nil) (nx1-form nil))) + (list (make-acode (%nx1-operator cons) (nx1-form :value nil) (nx1-form :value nil))) (make-acode (%nx1-operator catch) @@ -1627,37 +1702,38 @@ 0))))))) -(defnx1 nx1-return-from return-from (blockname &optional value) +(defnx1 nx1-return-from return-from context (blockname &optional value) (multiple-value-bind (info closed) - (nx-block-info (setq blockname (nx-need-sym blockname))) + (nx-block-info (setq blockname (nx-need-sym blockname))) (unless info (nx-error "Can't RETURN-FROM block : ~S." blockname)) - (unless closed (nx-adjust-ref-count (cdr info))) - (make-acode - (if closed - (%nx1-operator throw) - (%nx1-operator local-return-from)) - (if closed - (nx1-symbol (var-name (cdr info))) - info) - (nx1-form value)))) - -(defnx1 nx1-funcall ((funcall)) (&whole call func &rest args &environment env) + (destructuring-bind (var . block-context) (cdr info) + (unless closed (nx-adjust-ref-count var)) + (make-acode + (if closed + (%nx1-operator throw) + (%nx1-operator local-return-from)) + (if closed + (nx1-symbol context (var-name var )) + info) + (nx1-form (if closed :value block-context) value))))) + +(defnx1 nx1-funcall ((funcall)) context (&whole call func &rest args &environment env) (let ((name (nx1-func-name func))) (if (or (null name) (and (symbolp name) (macro-function name env))) - (nx1-typed-call (nx1-form func) args nil) + (nx1-typed-call context (nx1-form :value func) args nil) (progn (when (consp name) ;; lambda expression (nx-note-source-transformation func name)) ;; This picks up call-next-method evil. - (nx1-form (let ((new-form (cons name args))) - (nx-note-source-transformation call new-form) - new-form)))))) - -(defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args) + (nx1-form context (let ((new-form (cons name args))) + (nx-note-source-transformation call new-form) + new-form)))))) + +(defnx1 nx1-multiple-value-call multiple-value-call context (value-form &rest args) (make-acode (%nx1-default-operator) - (nx1-form value-form) - (nx1-formlist args))) - -(defnx1 nx1-compiler-let compiler-let (bindings &body forms) + (nx1-form :value value-form) + (nx1-formlist context args))) + +(defnx1 nx1-compiler-let compiler-let context (bindings &body forms) (let* ((vars nil) (varinits nil)) @@ -1665,7 +1741,7 @@ (push (nx-pair-name pair) vars) (push (eval (nx-pair-initform pair)) varinits)) - (progv (nreverse vars) (nreverse varinits) (nx1-catch-body forms)))) - -(defnx1 nx1-fbind fbind (fnspecs &body body &environment old-env) + (progv (nreverse vars) (nreverse varinits) (nx1-catch-body context forms)))) + +(defnx1 nx1-fbind fbind context (fnspecs &body body &environment old-env) (let* ((fnames nil) (vars nil) @@ -1674,5 +1750,5 @@ (destructuring-bind (fname initform) spec (push (setq fname (nx-need-function-name fname)) fnames) - (push (nx1-form initform) vals))) + (push (nx1-form :value initform) vals))) (let* ((new-env (new-lexical-environment old-env)) (*nx-bound-vars* *nx-bound-vars*) @@ -1692,5 +1768,5 @@ vars vals - (nx1-env-body body old-env) + (nx1-env-body context body old-env) *nx-new-p2decls*)))) @@ -1700,5 +1776,5 @@ (nx1-whine :special-fbinding funcname))) -(defnx1 nx1-flet flet (defs &body forms) +(defnx1 nx1-flet flet context (defs &body forms) (with-nx-declarations (pending) (let* ((env *nx-lexical-environment*) @@ -1744,5 +1820,5 @@ (setq body (let* ((*nx-lexical-environment* new-env)) (nx1-dynamic-extent-functions vars new-env) - (nx1-env-body body env))) + (nx1-env-body context body env))) (dolist (pair pairs) (let ((afunc (cdr pair)) @@ -1784,5 +1860,5 @@ (nx-set-var-bits varinfo (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits varinfo)))))))))) -(defnx1 nx1-labels labels (defs &body forms) +(defnx1 nx1-labels labels context (defs &body forms) (with-nx-declarations (pending) (let* ((env *nx-lexical-environment*) @@ -1827,5 +1903,5 @@ (nx-process-declarations pending decls) (nx-effect-other-decls pending env) - (setq body (nx1-env-body body old-env)) + (setq body (nx1-env-body context body old-env)) (nx-reconcile-inherited-vars funcrefs) (dolist (f funcrefs) (nx1-afunc-ref f)) @@ -1839,14 +1915,14 @@ -(defnx1 nx1-set-bit ((%set-bit)) (ptr offset &optional (newval nil newval-p)) +(defnx1 nx1-set-bit ((%set-bit)) context (ptr offset &optional (newval nil newval-p)) (unless newval-p (setq newval offset offset 0)) (make-acode (%nx1-operator %set-bit) - (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr)) - (nx1-form offset) - (nx1-form newval))) + (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptr)) + (nx1-form :value offset) + (nx1-form :value newval))) (defnx1 nx1-set-xxx ((%set-ptr) (%set-long) (%set-word) (%set-byte) - (%set-unsigned-long) (%set-unsigned-word) (%set-unsigned-byte)) + (%set-unsigned-long) (%set-unsigned-word) (%set-unsigned-byte)) context (ptr offset &optional (newval nil new-val-p) &aux (op *nx-sfname*)) (unless new-val-p (setq newval offset offset 0)) @@ -1861,12 +1937,12 @@ (%set-unsigned-long (logior 32 4)) (t 4)) - (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr)) - (nx1-form offset) - (nx1-form newval))) - -(defnx1 nx1-set-64-xxx ((%%set-unsigned-longlong) (%%set-signed-longlong)) + (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptr)) + (nx1-form :value offset) + (nx1-form :value newval))) + +(defnx1 nx1-set-64-xxx ((%%set-unsigned-longlong) (%%set-signed-longlong)) context (&whole w ptr offset newval &aux (op *nx-sfname*)) (target-word-size-case - (32 (nx1-treat-as-call w)) + (32 (nx1-treat-as-call context w)) (64 (make-acode @@ -1875,10 +1951,10 @@ (%%set-signed-longlong 8) (t (logior 32 8))) - (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr)) - (nx1-form offset) - (nx1-form newval))))) - - -(defnx1 nx1-get-bit ((%get-bit)) (ptrform &optional (offset 0)) + (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptr)) + (nx1-form :value offset) + (nx1-form :value newval))))) + + +(defnx1 nx1-get-bit ((%get-bit)) context (ptrform &optional (offset 0)) (make-acode (%nx1-operator typed-form) @@ -1886,11 +1962,11 @@ (make-acode (%nx1-operator %get-bit) - (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) - (nx1-form offset)))) - -(defnx1 nx1-get-64-xxx ((%%get-unsigned-longlong) (%%get-signed-longlong)) + (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform)) + (nx1-form :value offset)))) + +(defnx1 nx1-get-64-xxx ((%%get-unsigned-longlong) (%%get-signed-longlong)) context (&whole w ptrform offsetform) (target-word-size-case - (32 (nx1-treat-as-call w)) + (32 (nx1-treat-as-call context w)) (64 (let* ((flagbits (case *nx-sfname* @@ -1905,6 +1981,6 @@ (%nx1-operator immediate-get-xxx) flagbits - (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) - (nx1-form offsetform))))))) + (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform)) + (nx1-form :value offsetform))))))) (defnx1 nx1-get-xxx ((%get-long) (%get-full-long) (%get-signed-long) @@ -1914,5 +1990,5 @@ (%get-signed-word) (%get-signed-byte) - (%get-unsigned-long)) + (%get-unsigned-long)) context (ptrform &optional (offset 0)) (let* ((sfname *nx-sfname*) @@ -1944,17 +2020,17 @@ (%nx1-operator immediate-get-xxx) flagbits - (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) - (nx1-form offset))))) - -(defnx1 nx1-%get-ptr ((%get-ptr) ) (ptrform &optional (offset 0)) + (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform)) + (nx1-form :value offset))))) + +(defnx1 nx1-%get-ptr ((%get-ptr) ) context (ptrform &optional (offset 0)) (make-acode (%nx1-operator %consmacptr%) (make-acode (%nx1-operator immediate-get-ptr) - (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) - (nx1-form offset)))) + (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform)) + (nx1-form :value offset)))) (defnx1 nx1-%get-float ((%get-single-float) - (%get-double-float)) (ptrform &optional (offset 0)) + (%get-double-float)) context (ptrform &optional (offset 0)) (make-acode (%nx1-operator typed-form) @@ -1964,9 +2040,9 @@ (make-acode (%nx1-default-operator) - (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) - (nx1-form offset)))) + (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform)) + (nx1-form :value offset)))) (defnx1 nx1-%set-float ((%set-single-float) - (%set-double-float)) (ptrform offset &optional (newval nil newval-p)) + (%set-double-float)) context (ptrform offset &optional (newval nil newval-p)) (unless newval-p (setq newval offset @@ -1979,9 +2055,9 @@ (make-acode (%nx1-default-operator) - (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform)) - (nx1-form offset) - (nx1-form newval)))) - -(defnx1 nx1-let let (pairs &body forms &environment old-env) + (make-acode (%nx1-operator %macptrptr%) (nx1-form :value ptrform)) + (nx1-form :value offset) + (nx1-form :value newval)))) + +(defnx1 nx1-let let context (pairs &body forms &environment old-env) (collect ((vars) (vals) @@ -2014,5 +2090,5 @@ (progn (nx-effect-other-decls pending *nx-lexical-environment*) - (nx1-env-body body old-env)) + (nx1-env-body context body old-env)) *nx-new-p2decls*))) (nx1-check-var-bindings varbindings) @@ -2023,5 +2099,5 @@ ;((lambda (lambda-list) . body) . args) -(defun nx1-lambda-bind (lambda-list args body &optional (body-environment *nx-lexical-environment*)) +(defun nx1-lambda-bind (context lambda-list args body &optional (body-environment *nx-lexical-environment*)) (let* ((old-env body-environment) (arg-env *nx-lexical-environment*) @@ -2033,5 +2109,5 @@ (declare (ignore req opttail)) (when (and ok (eq (%car resttail) '&lexpr)) - (return-from nx1-lambda-bind (nx1-call (nx1-form `(lambda ,lambda-list ,@body)) args)))) + (return-from nx1-lambda-bind (nx1-call context (nx1-form context `(lambda ,lambda-list ,@body)) args)))) (let* ((*nx-lexical-environment* body-environment) (*nx-bound-vars* *nx-bound-vars*)) @@ -2042,7 +2118,7 @@ (nx-parse-simple-lambda-list pending lambda-list) (let* ((*nx-lexical-environment* arg-env)) - (setq arglist (nx1-formlist args))) + (setq arglist (nx1-formlist context args))) (nx-effect-other-decls pending *nx-lexical-environment*) - (setq body (nx1-env-body body old-env)) + (setq body (nx1-env-body context body old-env)) (while req (when (null arglist) @@ -2152,5 +2228,5 @@ -(defnx1 nx1-lap-function (ppc-lap-function) (name bindings &body body) +(defnx1 nx1-lap-function (ppc-lap-function) context (name bindings &body body) (declare (ftype (function (t t t)) %define-ppc-lap-function)) (require "PPC-LAP" "ccl:compiler;ppc;ppc-lap") @@ -2159,5 +2235,5 @@ (dpb (length bindings) $lfbits-numreq 0)))) -(defnx1 nx1-x86-lap-function (x86-lap-function) (name bindings &body body) +(defnx1 nx1-x86-lap-function (x86-lap-function) context (name bindings &body body) (declare (ftype (function (t t t)) %define-x86-lap-function)) (require "X86-LAP") @@ -2166,5 +2242,5 @@ (dpb (length bindings) $lfbits-numreq 0)))) -(defnx1 nx1-arm-lap-function (arm-lap-function) (name bindings &body body) +(defnx1 nx1-arm-lap-function (arm-lap-function) context (name bindings &body body) (declare (ftype (function (t t t)) %define-arm-lap-function)) (require "ARM-LAP") @@ -2177,6 +2253,6 @@ -(defun nx1-env-body (body old-env &optional (typecheck (nx-declarations-typecheck *nx-lexical-environment*))) - (do* ((form (nx1-progn-body body)) +(defun nx1-env-body (context body old-env &optional (typecheck (nx-declarations-typecheck *nx-lexical-environment*))) + (do* ((form (nx1-progn-body context body)) (typechecks nil) (env *nx-lexical-environment* (lexenv.parent-env env))) @@ -2198,5 +2274,5 @@ (unless (eq type t) (let ((old-bits (nx-var-bits var))) - (push (nx1-form `(the ,type ,sym)) typechecks) + (push (nx1-form :value `(the ,type ,sym)) typechecks) (when (%izerop (logior (%ilogand2 old-bits @@ -2210,5 +2286,5 @@ -(defnx1 nx1-let* (let*) (varspecs &body forms) +(defnx1 nx1-let* (let*) context (varspecs &body forms) (let* ((vars nil) (vals nil) @@ -2235,5 +2311,5 @@ (setq vars (nreverse vars)) (setq vals (nreverse vals)) - (nx1-env-body body old-env) + (nx1-env-body context body old-env) *nx-new-p2decls*))) (nx1-check-var-bindings var-bound-vars) @@ -2241,12 +2317,12 @@ result))))) -(defnx1 nx1-multiple-value-bind multiple-value-bind +(defnx1 nx1-multiple-value-bind multiple-value-bind context (varspecs bindform &body forms) (if (= (length varspecs) 1) - (nx1-form `(let* ((,(car varspecs) ,bindform)) ,@forms)) + (nx1-form context `(let* ((,(car varspecs) ,bindform)) ,@forms)) (let* ((vars nil) (*nx-bound-vars* *nx-bound-vars*) (old-env *nx-lexical-environment*) - (mvform (nx1-form bindform))) + (mvform (nx1-form :value bindform))) (with-nx-declarations (pending) (multiple-value-bind (body decls) @@ -2260,5 +2336,5 @@ (nreverse vars) mvform - (nx1-env-body body old-env) + (nx1-env-body context body old-env) *nx-new-p2decls*)))))) @@ -2266,52 +2342,52 @@ ;;; This isn't intended to be user-visible; there isn't a whole lot of ;;; sanity-checking applied to the subtag. -(defnx1 nx1-%alloc-misc ((%alloc-misc)) (element-count subtag &optional (init nil init-p)) +(defnx1 nx1-%alloc-misc ((%alloc-misc)) context (element-count subtag &optional (init nil init-p)) (if init-p ; ensure that "init" is evaluated before miscobj is created. (make-acode (%nx1-operator %make-uvector) - (nx1-form element-count) - (nx1-form subtag) - (nx1-form init)) + (nx1-form :value element-count) + (nx1-form :value subtag) + (nx1-form :value init)) (make-acode (%nx1-operator %make-uvector) - (nx1-form element-count) - (nx1-form subtag)))) - -(defnx1 nx1-%lisp-word-ref (%lisp-word-ref) (base offset) + (nx1-form :value element-count) + (nx1-form :value subtag)))) + +(defnx1 nx1-%lisp-word-ref (%lisp-word-ref) context (base offset) (make-acode (%nx1-operator %lisp-word-ref) - (nx1-form base) - (nx1-form offset))) - -(defnx1 nx1-%single-to-double ((%single-to-double)) (arg) + (nx1-form :value base) + (nx1-form :value offset))) + +(defnx1 nx1-%single-to-double ((%single-to-double)) context (arg) (make-acode (%nx1-operator %single-to-double) - (nx1-form arg))) - -(defnx1 nx1-%double-to-single ((%double-to-single)) (arg) + (nx1-form :value arg))) + +(defnx1 nx1-%double-to-single ((%double-to-single)) context (arg) (make-acode (%nx1-operator %double-to-single) - (nx1-form arg))) - -(defnx1 nx1-%fixnum-to-double ((%fixnum-to-double)) (arg) + (nx1-form :value arg))) + +(defnx1 nx1-%fixnum-to-double ((%fixnum-to-double)) context (arg) (make-acode (%nx1-operator %fixnum-to-double) - (nx1-form arg))) - -(defnx1 nx1-%fixnum-to-single ((%fixnum-to-single)) (arg) + (nx1-form :value arg))) + +(defnx1 nx1-%fixnum-to-single ((%fixnum-to-single)) context (arg) (make-acode (%nx1-operator %fixnum-to-single) - (nx1-form arg))) - -(defnx1 nx1-%double-float ((%double-float)) (&whole whole arg &optional (result nil result-p)) + (nx1-form :value arg))) + +(defnx1 nx1-%double-float ((%double-float)) context (&whole whole arg &optional (result nil result-p)) (declare (ignore result)) (if result-p - (nx1-treat-as-call whole) - (make-acode (%nx1-operator %double-float) (nx1-form arg)))) - -(defnx1 nx1-%short-float ((%short-float)) (&whole whole arg &optional (result nil result-p)) + (nx1-treat-as-call context whole) + (make-acode (%nx1-operator %double-float) (nx1-form :value arg)))) + +(defnx1 nx1-%short-float ((%short-float)) context (&whole whole arg &optional (result nil result-p)) (declare (ignore result)) (if result-p - (nx1-treat-as-call whole) - (make-acode (%nx1-operator %single-float) (nx1-form arg)))) - - -(defnx1 nx1-symvector ((%symptr->symvector) (%symvector->symptr)) (arg) - (make-acode (%nx1-default-operator) (nx1-form arg))) - -(defnx1 nx1-%ilognot (%ilognot) (n) + (nx1-treat-as-call context whole) + (make-acode (%nx1-operator %single-float) (nx1-form :value arg)))) + + +(defnx1 nx1-symvector ((%symptr->symvector) (%symvector->symptr)) context (arg) + (make-acode (%nx1-default-operator) (nx1-form :value arg))) + +(defnx1 nx1-%ilognot (%ilognot) context (n) ;; Bootstrapping nonsense. (if (aref (backend-p2-dispatch *target-backend*) @@ -2320,9 +2396,9 @@ 'fixnum (make-acode (%nx1-operator %ilognot) - (nx1-form n))) - (nx1-form (macroexpand `(%ilognot ,n))))) + (nx1-form :value n))) + (nx1-form context (macroexpand `(%ilognot ,n))))) -(defnx1 nx1-ash (ash) (&whole call &environment env num amt) +(defnx1 nx1-ash (ash) context (&whole call &environment env num amt) (flet ((defer-to-backend () ;; Bootstrapping nonsense @@ -2333,7 +2409,7 @@ (make-acode (%nx1-operator ash) - (nx1-form num) - (nx1-form amt))) - (nx1-treat-as-call call)))) + (nx1-form :value num) + (nx1-form :value amt))) + (nx1-treat-as-call context call)))) (let* ((unsigned-natural-type *nx-target-natural-type*) (max (target-word-size-case (32 32) (64 64))) @@ -2341,5 +2417,5 @@ (32 29) (64 60)))) - (cond ((eq amt 0) (nx1-form `(require-type ,num 'integer) env)) + (cond ((eq amt 0) (nx1-form context `(require-type ,num 'integer) env)) ((and (fixnump amt) (< amt 0)) @@ -2348,12 +2424,12 @@ (make-acode (%nx1-operator fixnum) (- amt)) - (nx1-form num)) + (nx1-form :value num)) (if (nx-form-typep num unsigned-natural-type env) (if (< (- amt) max) (make-acode (%nx1-operator natural-shift-right) - (nx1-form num) + (nx1-form :value num) (make-acode (%nx1-operator fixnum) (- amt))) - (nx1-form `(progn (require-type ,num 'integer) 0) env)) + (nx1-form context `(progn (require-type ,num 'integer) 0) env)) (defer-to-backend)))) ((and (fixnump amt) @@ -2363,5 +2439,5 @@ (nx-trust-declarations env) (subtypep *nx-form-type* 'fixnum)))) - (nx1-form `(%ilsl ,amt ,num))) + (nx1-form context `(%ilsl ,amt ,num))) ((and (fixnump amt) (< 0 amt max) @@ -2370,6 +2446,6 @@ (subtypep *nx-form-type* unsigned-natural-type)) (make-acode (%nx1-operator natural-shift-left) - (nx1-form num) - (nx1-form amt))) + (nx1-form :value num) + (nx1-form :value amt))) ((fixnump num) (let* ((field-width (1+ (integer-length num))) @@ -2377,5 +2453,5 @@ (max-shift (- (1+ maxbits) field-width))) (if (nx-form-typep amt `(mod ,(1+ max-shift)) env) - (nx1-form `(%ilsl ,amt ,num)) + (nx1-form context `(%ilsl ,amt ,num)) (defer-to-backend)))) (t (defer-to-backend)))))) @@ -2386,8 +2462,8 @@ (nx-error "Bad argument format in ~S ." args)) -(defnx1 nx1-eval-when eval-when (when &body body) - (nx1-progn-body (if (or (memq 'eval when) (memq :execute when)) body))) - -(defnx1 nx1-misplaced (declare) (&rest args) +(defnx1 nx1-eval-when eval-when context (when &body body) + (nx1-progn-body context (if (or (memq 'eval when) (memq :execute when)) body))) + +(defnx1 nx1-misplaced (declare) context (&rest args) (nx-error "~S not expected in ~S." *nx-sfname* (cons *nx-sfname* args)))