Index: /trunk/source/compiler/PPC/ppc2.lisp =================================================================== --- /trunk/source/compiler/PPC/ppc2.lisp (revision 13886) +++ /trunk/source/compiler/PPC/ppc2.lisp (revision 13887) @@ -9116,4 +9116,14 @@ (^)))) +(defppc2 ppc2-%fixnum-mask-to-natural %fixnum-mask-to-natural (seg vreg xfer arg) + (with-imm-target () (dreg :natural) + (let* ((r (ppc2-one-untargeted-reg-form seg arg ppc::arg_z))) + (unless (or (acode-fixnum-form-p arg) + *ppc2-reckless*) + (! trap-unless-fixnum r)) + (! fixnum->signed-natural dreg r) + (<- dreg) + (^)))) + (defppc2 ppc2-%double-float %double-float (seg vreg xfer arg) (let* ((real (or (acode-fixnum-form-p arg) Index: /trunk/source/compiler/X86/x862.lisp =================================================================== --- /trunk/source/compiler/X86/x862.lisp (revision 13886) +++ /trunk/source/compiler/X86/x862.lisp (revision 13887) @@ -10094,4 +10094,14 @@ (^)))) +(defx862 x862-%fixnum-mask-to-natural %fixnum-mask-to-natural (seg vreg xfer arg) + (with-imm-target () (target :natural) + (let ((r (x862-one-untargeted-reg-form seg arg *x862-arg-z*))) + (unless (or (acode-fixnum-form-p arg) + *x862-reckless*) + (! trap-unless-finxum r)) + (! fixnum->signed-natural target r) + (<- target) + (^)))) + (defx862 x862-%double-float %double-float (seg vreg xfer arg) (let* ((real (or (acode-fixnum-form-p arg) Index: /trunk/source/compiler/nx0.lisp =================================================================== --- /trunk/source/compiler/nx0.lisp (revision 13886) +++ /trunk/source/compiler/nx0.lisp (revision 13887) @@ -589,4 +589,20 @@ int))) +(defun acode-natural-constant-p (x) + (let* ((int (or (acode-fixnum-form-p x) + (progn + (setq x (acode-unwrapped-form x)) + (if (acode-p x) + (if (and (eq (acode-operator x) (%nx1-operator immediate)) + (typep (cadr x) 'fixnum)) + (cadr x))))))) + (and int + (target-word-size-case + (32 (typep int '(unsigned-byte 32))) + (64 (typep int '(unsigned-byte 64)))) + int))) + + + (defun acode-real-constant-p (x) (or (acode-fixnum-form-p x) @@ -692,4 +708,15 @@ (defun nx-acode-fixnum-type-p (form env) (acode-fixnum-type-p form (nx-trust-declarations env))) + +(defun acode-natural-type-p (form trust-decls) + (and trust-decls + (acode-p form) + (eq (acode-operator form) (%nx1-operator typed-form)) + (subtypep (cadr form) (target-word-size-case + (32 '(unsigned-byte 32)) + (64 '(unsigned-byte 64)))))) + +(defun nx-acode-natural-type-p (form env) + (acode-natural-type-p form (nx-trust-declarations env))) ; Is acode-expression the result of alphatizing (%int-to-ptr ) ? @@ -2713,5 +2740,4 @@ (subtypep (nx-form-type arg env) type env))) - (defun nx-binary-fixnum-op-p (form1 form2 env &optional ignore-result-type) (setq form1 (nx-transform form1 env) @@ -2746,6 +2772,61 @@ (64 (subtypep *nx-form-type* '(unsigned-byte 64)))))))) - - +(defun nx-logand-2-op (arg-1 arg-2 env) + (let* ((form-1 (nx1-form arg-1)) + (form-2 (nx1-form arg-2)) + (fix-1 (nx-acode-fixnum-type-p form-1 env)) + (fix-2 (nx-acode-fixnum-type-p form-2 env)) + (nat-1 (nx-acode-natural-type-p form-1 env)) + (nat-2 (nx-acode-natural-type-p form-2 env))) + (cond + ((and fix-1 fix-2) + (make-acode (%nx1-operator %ilogand2) form-1 form-2)) + ((and nat-1 nat-2) + (make-acode (%nx1-operator typed-form) + (target-word-size-case + (32 '(unsigned-byte 32)) + (64 '(unsigned-byte 64))) + (make-acode (%nx1-operator %natural-logand) form-1 form-2))) + ((and fix-1 nat-2) + (make-acode (%nx1-operator typed-form) + (target-word-size-case + (32 '(unsigned-byte 32)) + (64 '(unsigned-byte 64))) + (make-acode (%nx1-operator %natural-logand) + (make-acode (%nx1-operator %fixnum-mask-to-natural) + form-1) + form-2))) + ((and nat-1 fix-2) + (make-acode (%nx1-operator typed-form) + (target-word-size-case + (32 '(unsigned-byte 32)) + (64 '(unsigned-byte 64))) + (make-acode (%nx1-operator %natural-logand) + form-1 + (make-acode (%nx1-operator %fixnum-mask-to-natural) + form-2)))) + (t + (make-acode (%nx1-operator logand2) form-1 form-2))))) + +(defun nx-logior-2-op (arg-1 arg-2 env) + (let* ((form-1 (nx1-form arg-1)) + (form-2 (nx1-form arg-2)) + (fix-1 (nx-acode-fixnum-type-p form-1 env)) + (fix-2 (nx-acode-fixnum-type-p form-2 env)) + (nat-1 (or (acode-natural-constant-p form-1) + (nx-acode-natural-type-p form-1 env))) + (nat-2 (or (acode-natural-constant-p form-2) + (nx-acode-natural-type-p form-2 env)))) + (cond + ((and fix-1 fix-2) + (make-acode (%nx1-operator %ilogior2) form-1 form-2)) + ((and nat-1 nat-2) + (make-acode (%nx1-operator typed-form) + (target-word-size-case + (32 '(unsigned-byte 32)) + (64 '(unsigned-byte 64))) + (make-acode (%nx1-operator %natural-logior) form-1 form-2))) + (t + (make-acode (%nx1-operator logior2) form-1 form-2))))) (defun nx-binary-boole-op (whole env arg-1 arg-2 fixop intop naturalop) Index: /trunk/source/compiler/nx1.lisp =================================================================== --- /trunk/source/compiler/nx1.lisp (revision 13886) +++ /trunk/source/compiler/nx1.lisp (revision 13887) @@ -450,12 +450,6 @@ (nx1-form newvalue))) -(defnx1 nx1-logior-2 ((logior-2)) (&whole w &environment env arg-1 arg-2) - (nx-binary-boole-op w - env - arg-1 - arg-2 - (%nx1-operator %ilogior2) - (%nx1-operator logior2) - (%nx1-operator %natural-logior))) +(defnx1 nx1-logior-2 ((logior-2)) (&environment env arg-1 arg-2) + (nx-logior-2-op arg-1 arg-2 env)) (defnx1 nx1-logxor-2 ((logxor-2)) (&whole w &environment env arg-1 arg-2) @@ -468,12 +462,6 @@ (%nx1-operator %natural-logxor))) -(defnx1 nx1-logand-2 ((logand-2)) (&whole w &environment env arg-1 arg-2) - (nx-binary-boole-op w - env - arg-1 - arg-2 - (%nx1-operator %ilogand2) - (%nx1-operator logand2) - (%nx1-operator %natural-logand))) +(defnx1 nx1-logand-2 ((logand-2)) (&environment env arg-1 arg-2) + (nx-logand-2-op arg-1 arg-2 env)) (defnx1 nx1-require ((require-simple-vector) @@ -2198,4 +2186,8 @@ (nx1-form arg))) +(defnx1 nx1-%fixnum-mask-to-natural ((%fixnum-mask-to-natural)) (arg) + (make-acode (%nx1-operator %fixnum-mask-to-natural) + (nx1-form arg))) + (defnx1 nx1-%double-float ((%double-float)) (&whole whole arg &optional (result nil result-p)) (declare (ignore result)) Index: /trunk/source/compiler/nxenv.lisp =================================================================== --- /trunk/source/compiler/nxenv.lisp (revision 13886) +++ /trunk/source/compiler/nxenv.lisp (revision 13887) @@ -370,5 +370,6 @@ (%double-float . #. #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask)) (i386-ff-call . 0) - (i386-syscall . 0)))) + (i386-syscall . 0) + (%fixnum-mask-to-natural . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))))) (defmacro %nx1-operator (sym)