Changeset 12861
- Timestamp:
- Sep 22, 2009, 3:05:49 AM (10 years ago)
- Location:
- trunk/source
- Files:
-
- 8 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/compiler/X86/x862.lisp
r12838 r12861 2111 2111 (is-node (member type-keyword (arch::target-gvector-types arch)))) 2112 2112 (if is-node 2113 (cond (( eq form *nx-nil*)2113 (cond ((nx-null form) 2114 2114 (target-nil-value)) 2115 (( eq form *nx-t*)2115 ((nx-t form) 2116 2116 (+ (target-nil-value) (arch::target-t-offset arch))) 2117 2117 (t … … 3548 3548 (let ((value (acode-unwrapped-form-value form))) 3549 3549 (when (acode-p value) 3550 (if (or ( eq value *nx-t*)3551 ( eq value *nx-nil*)3550 (if (or (nx-t value) 3551 (nx-null value) 3552 3552 (let* ((operator (acode-operator value))) 3553 3553 (member operator *x862-operator-supports-push*))) … … 3696 3696 3697 3697 (defun x862-compare-register-to-constant (seg vreg xfer ireg cr-bit true-p constant) 3698 (cond (( eq constant *nx-nil*)3698 (cond ((nx-null constant) 3699 3699 (x862-compare-register-to-nil seg vreg xfer ireg cr-bit true-p)) 3700 3700 (t 3701 3701 (with-x86-local-vinsn-macros (seg vreg xfer) 3702 3702 (when vreg 3703 (if ( eq constant *nx-t*)3703 (if (nx-t constant) 3704 3704 (! compare-to-t ireg) 3705 3705 (let* ((imm (x862-immediate-operand constant)) … … 4368 4368 (let* ((bits (nx-var-bits var))) 4369 4369 (if (%ilogbitp $vbitpuntable bits) 4370 (nx-untyped-form initform)))))4370 initform)))) 4371 4371 (declare (inline x862-puntable-binding-p)) 4372 4372 (if (and (not (x862-load-ea-p val)) … … 4374 4374 (progn 4375 4375 (nx-set-var-bits var (%ilogior (%ilsl $vbitpunted 1) bits)) 4376 (nx2-replace-var-refs var puntval) 4376 4377 (x862-set-var-ea seg var puntval)) 4377 4378 (progn … … 4481 4482 (with-x86-local-vinsn-macros (seg) 4482 4483 (let* ((ea-p (x862-load-ea-p value)) 4483 (nil-p (unless ea-p ( eq (setq value (nx-untyped-form value)) *nx-nil*)))4484 (nil-p (unless ea-p (nx-null (setq value (nx-untyped-form value))))) 4484 4485 (self-p (unless ea-p (and (or 4485 4486 (eq (acode-operator value) (%nx1-operator bound-special-ref)) … … 4998 4999 nil 4999 5000 (let* ((val (acode-unwrapped-form-value valform))) 5000 (if (or ( eq val *nx-t*)5001 ( eq val *nx-nil*)5001 (if (or (nx-t val) 5002 (nx-null val) 5002 5003 (and (acode-p val) 5003 5004 (let* ((op (acode-operator val))) … … 6338 6339 (x862-form seg vreg xfer form))) 6339 6340 6341 (defx862 x862-type-asserted-form type-asserted-form (seg vreg xfer typespec form &optional check) 6342 (declare (ignore typespec check)) 6343 (x862-form seg vreg xfer form)) 6344 6340 6345 (defx862 x862-%primitive %primitive (seg vreg xfer &rest ignore) 6341 6346 (declare (ignore seg vreg xfer ignore)) … … 6734 6739 (let* ((f1 (acode-unwrapped-form form1)) 6735 6740 (f2 (acode-unwrapped-form form2))) 6736 (cond ((or ( eq f1 *nx-nil*)6737 ( eq f1 *nx-t*)6741 (cond ((or (nx-null f1 ) 6742 (nx-t f1) 6738 6743 (and (acode-p f1) 6739 6744 (eq (acode-operator f1) (%nx1-operator immediate)))) 6740 6745 (x862-compare-register-to-constant seg vreg xfer (x862-one-untargeted-reg-form seg form2 ($ *x862-arg-z*)) cr-bit true-p f1)) 6741 ((or ( eq f2 *nx-nil*)6742 ( eq f2 *nx-t*)6746 ((or (nx-null f2) 6747 (nx-t f2) 6743 6748 (and (acode-p f2) 6744 6749 (eq (acode-operator f2) (%nx1-operator immediate)))) -
trunk/source/compiler/nx-basic.lisp
r12618 r12861 484 484 485 485 (defun cons-var (name &optional (bits 0)) 486 (%istruct 'var name bits nil nil nil nil nil ))486 (%istruct 'var name bits nil nil nil nil nil nil)) 487 487 488 488 -
trunk/source/compiler/nx0.lisp
r12583 r12861 436 436 437 437 438 (defun acode-form-type (form trust-decls) 439 (nx-target-type 440 (if (acode-p form) 441 (let* ((op (acode-operator form))) 442 (if (eq op (%nx1-operator fixnum)) 443 'fixnum 444 (if (eq op (%nx1-operator immediate)) 445 (type-of (%cadr form)) 446 (and trust-decls 447 (if (eq op (%nx1-operator typed-form)) 448 (if (eq (%cadr form) 'number) 449 (or (acode-form-type (nx-untyped-form form) trust-decls) 450 'number) 451 (%cadr form)) 452 (if (eq op (%nx1-operator lexical-reference)) 453 (let* ((var (cadr form)) 454 (bits (nx-var-bits var)) 455 (punted (logbitp $vbitpunted bits))) 456 (if (or punted 457 (eql 0 (%ilogand $vsetqmask bits))) 458 (var-inittype var))) 459 (if (or (eq op (%nx1-operator %aref1)) 460 (eq op (%nx1-operator simple-typed-aref2)) 461 (eq op (%nx1-operator general-aref2)) 462 (eq op (%nx1-operator simple-typed-aref3)) 463 (eq op (%nx1-operator general-aref3))) 464 (let* ((atype (acode-form-type (cadr form) t)) 465 (actype (if atype (specifier-type atype)))) 466 (if (typep actype 'array-ctype) 467 (type-specifier (array-ctype-specialized-element-type 468 actype)))) 469 (if (member op *numeric-acode-ops*) 470 (multiple-value-bind (f1 f2) 471 (nx-binop-numeric-contagion (cadr form) 472 (caddr form) 473 trust-decls) 474 (if (and (acode-form-typep f1 'float trust-decls) 475 (acode-form-typep f2 'float trust-decls)) 476 477 (if (or (acode-form-typep f1 'double-float trust-decls) 478 (acode-form-typep f2 'double-float trust-decls)) 479 'double-float 480 'single-float))) 481 (cdr (assq op *nx-operator-result-types*))))))))))))) 438 439 (defun acode-form-type (form trust-decls &optional (assert t)) 440 (let* ((typespec 441 (if (nx-null form) 442 'null 443 (if (eq form *nx-t*) 444 'boolean 445 (nx-target-type 446 (if (acode-p form) 447 (let* ((op (acode-operator form))) 448 (if (eq op (%nx1-operator fixnum)) 449 'fixnum 450 (if (eq op (%nx1-operator immediate)) 451 (type-of (%cadr form)) 452 (and trust-decls 453 (if (eq op (%nx1-operator type-asserted-form)) 454 (progn 455 (setq assert nil) 456 (%cadr form)) 457 (if (eq op (%nx1-operator typed-form)) 458 (progn 459 (when (and assert (null (nth 3 form))) 460 (setf (%car form) (%nx1-operator type-asserted-form) 461 assert nil)) 462 (if (eq (%cadr form) 'number) 463 (or (acode-form-type (nx-untyped-form form) trust-decls) 464 'number) 465 (%cadr form))) 466 (if (eq op (%nx1-operator lexical-reference)) 467 (let* ((var (cadr form)) 468 (bits (nx-var-bits var)) 469 (punted (logbitp $vbitpunted bits))) 470 (if (or punted 471 (eql 0 (%ilogand $vsetqmask bits))) 472 (var-inittype var))) 473 (if (or (eq op (%nx1-operator %aref1)) 474 (eq op (%nx1-operator simple-typed-aref2)) 475 (eq op (%nx1-operator general-aref2)) 476 (eq op (%nx1-operator simple-typed-aref3)) 477 (eq op (%nx1-operator general-aref3))) 478 (let* ((atype (acode-form-type (cadr form) t)) 479 (actype (if atype (specifier-type atype)))) 480 (if (typep actype 'array-ctype) 481 (type-specifier (array-ctype-specialized-element-type 482 actype)))) 483 (if (member op *numeric-acode-ops*) 484 (multiple-value-bind (f1 f2) 485 (nx-binop-numeric-contagion (cadr form) 486 (caddr form) 487 trust-decls) 488 (if (and (acode-form-typep f1 'float trust-decls) 489 (acode-form-typep f2 'float trust-decls)) 490 491 (if (or (acode-form-typep f1 'double-float trust-decls) 492 (acode-form-typep f2 'double-float trust-decls)) 493 'double-float 494 'single-float))) 495 (cdr (assq op *nx-operator-result-types*))))))))))))))))) 496 (when (and (acode-p form) (typep (acode-operator form) 'fixnum) assert) 497 (unless typespec (setq typespec t)) 498 (let* ((new (cons typespec (cons (cons (%car form) (%cdr form)) nil)))) 499 (setf (%car form) (%nx1-operator type-asserted-form) 500 (%cdr form) new))) 501 typespec)) 482 502 483 503 (defun nx-binop-numeric-contagion (form1 form2 trust-decls) … … 1818 1838 (nx-set-var-bits info (%ilogior2 (%ilsl $vbitreffed 1) (nx-var-bits info)))) 1819 1839 (nx-adjust-ref-count info) 1820 ( make-acode (%nx1-operator lexical-reference)info)))1840 (nx-make-lexical-reference info))) 1821 1841 (make-acode 1822 1842 (if (nx1-check-special-ref form info) … … 2526 2546 ((fixnump bits) (setf (var-bits var) newbits)))) 2527 2547 2548 (defun nx-make-lexical-reference (var) 2549 (let* ((ref (make-acode (%nx1-operator lexical-reference) var))) 2550 (push ref (var-ref-forms var)) 2551 ref)) 2552 2528 2553 (defun nx-adjust-ref-count (var) 2529 2554 (let* ((bits (nx-var-bits var)) … … 2567 2592 (or (and op (cdr (assq op *nx-operator-result-types*))) 2568 2593 (and (not op)(cdr (assq (car form) *nx-operator-result-types-by-name*))) 2569 (and (memq (car form) *numeric-ops*)2594 #+no (and (memq (car form) *numeric-ops*) 2570 2595 (grovel-numeric-form form env)) 2571 (and (memq (car form) *logical-ops*)2596 #+no (and (memq (car form) *logical-ops*) 2572 2597 (grovel-logical-form form env)) 2573 2598 (nx-declared-result-type (%car form) env) -
trunk/source/compiler/nx1.lisp
r12583 r12861 322 322 (defun nx-untyped-form (form) 323 323 (while (and (consp form) 324 (eq (%car form) (%nx1-operator typed-form)) 325 (null (nth 3 form))) 324 (or (and (eq (%car form) (%nx1-operator typed-form)) 325 (null (nth 3 form))) 326 (eq (%car form) (%nx1-operator type-asserted-form)))) 326 327 (setq form (%caddr form))) 327 328 form) … … 1254 1255 (%nx1-operator closed-function) 1255 1256 (%nx1-operator simple-function))) 1256 (ref (a func-ref-form afunc)))1257 (ref (acode-unwrapped-form (afunc-ref-form afunc)))) 1257 1258 (if ref 1258 1259 (%rplaca ref op) ; returns ref … … 1470 1471 (make-acode 1471 1472 (%nx1-operator catch) 1472 ( make-acode (%nx1-operator lexical-reference)tagvar)1473 (nx-make-lexical-reference tagvar) 1473 1474 body) 1474 1475 0))))))) … … 1958 1959 (%nx1-operator debind) 1959 1960 nil 1960 (make-acode 1961 (%nx1-operator lexical-reference) var) 1961 (nx-make-lexical-reference var) 1962 1962 nil 1963 1963 nil -
trunk/source/compiler/nx2.lisp
r12060 r12861 226 226 (setq entries new))))))) 227 227 entries)) 228 228 229 (defun nx2-replace-var-refs (var value) 230 (when (acode-p value) 231 (let* ((op (acode-operator value)) 232 (operands (acode-operands value))) 233 (when (typep op 'fixnum) 234 (dolist (ref (var-ref-forms var) (setf (var-ref-forms var) nil)) 235 (when (acode-p ref) 236 (setf (acode-operator ref) op 237 (acode-operands ref) operands))))))) -
trunk/source/compiler/nxenv.lisp
r12071 r12861 25 25 (require 'lispequ) 26 26 ) 27 28 #-bootstrapped 29 (eval-when (:compile-toplevel :load-toplevel :execute) 30 (when (and (macro-function 'var-decls) 31 (not (macro-function 'var-ref-forms))) 32 (setf (macro-function 'var-ref-forms) 33 (macro-function 'var-decls)))) 27 34 28 35 #+ppc-target (require "PPCENV") … … 124 131 (local-tagbody . #.operator-single-valued-mask) 125 132 (%fixnum-set-natural . #.operator-single-valued-mask) 126 ( spushl . #.operator-single-valued-mask)133 (type-asserted-form . 0) 127 134 (spushp . #.operator-single-valued-mask) 128 135 (simple-function . #.operator-single-valued-mask) … … 487 494 ; More Bootstrapping Shit. 488 495 (defmacro acode-operator (form) 489 ; Gak.496 ;; Gak. 490 497 `(%car ,form)) 491 498 492 499 (defmacro acode-operand (n form) 493 ; Gak. Gak.500 ;; Gak. Gak. 494 501 `(nth ,n (the list ,form))) 502 503 (defmacro acode-operands (form) 504 ;; Gak. Gak. Gak. 505 `(%cdr ,form)) 495 506 496 507 (defmacro acode-p (x) -
trunk/source/compiler/optimizers.lisp
r12535 r12861 1226 1226 `(%negate ,n0)))) 1227 1227 1228 (define-compiler-macro * (& whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)1228 (define-compiler-macro * (&optional (n0 nil n0p) (n1 nil n1p) &rest more) 1229 1229 (if more 1230 (let ((type (nx-form-type w env))) 1231 (if (and type (numeric-type-p type)) ; go pairwise if type known, else not 1232 `(*-2 ,n0 (* ,n1 ,@more)) 1233 w)) 1230 `(*-2 ,n0 (* ,n1 ,@more)) 1234 1231 (if n1p 1235 1232 `(*-2 ,n0 ,n1) -
trunk/source/library/lispequ.lisp
r12679 r12861 199 199 (var-bits var-parent) ; fixnum or ptr to parent 200 200 (var-ea var-expansion) ; p2 address (or symbol-macro expansion) 201 var- decls ; list of applicable decls [not used]201 var-ref-forms ; in intermediate-code 202 202 var-inittype 203 203 var-binding-info 204 204 var-refs 205 205 var-nvr 206 var-declared-type 206 207 ) 207 208
Note: See TracChangeset
for help on using the changeset viewer.