diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp new file mode 100644 index 000000000..08656d56a --- /dev/null +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp @@ -0,0 +1,137 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; +;;;; Copyright (c) 2010, Juan Jose Garcia Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański +;;;; +;;;; See the file 'LICENSE' for the copyright details. +;;;; + +;;;; C/C++ specific optimizer for numerical expressions. + +(in-package "COMPILER") + +;;; +;;; Bit fiddling. It is a bit tricky because C does not allow +;;; shifts in << or >> which exceed the integer size. In those +;;; cases the compiler may do whatever it wants (and gcc does!) +;;; +(define-c-inliner shift (return-type argument orig-shift) + (let* ((arg-type (inlined-arg-type argument)) + (arg-c-type (lisp-type->rep-type arg-type)) + (return-c-type (lisp-type->rep-type return-type)) + (shift (loc-immediate-value (inlined-arg-loc orig-shift)))) + (if (or (not (c-integer-rep-type-p arg-c-type)) + (not (c-integer-rep-type-p return-c-type))) + (produce-inline-loc (list argument orig-shift) '(:object :fixnum) '(:object) + "ecl_ash(#0,#1)" nil t) + (let* ((arg-bits (c-integer-rep-type-bits arg-c-type)) + (return-bits (c-integer-rep-type-bits return-c-type)) + (max-type (if (and (plusp shift) + (< arg-bits return-bits)) + return-c-type + arg-c-type))) + (produce-inline-loc (list argument) (list max-type) (list return-type) + (format nil + (if (minusp shift) + "((#0) >> (~D))" + "((#0) << (~D))") + (abs shift)) + nil t))))) + +;;; +;;; Inliners for arithmetic operations. +;;; + +(defun most-generic-number-rep-type (r1 r2) + (let* ((r1 (rep-type-record r1)) + (r2 (rep-type-record r2))) + (rep-type-name (if (< (rep-type-index r1) (rep-type-index r2)) + r2 + r1)))) + +(defun inline-binop (expected-type arg1 arg2 consing non-consing) + (let ((arg1-type (inlined-arg-type arg1)) + (arg2-type (inlined-arg-type arg2))) + (if (and (policy-assume-right-type) + (c-number-type-p expected-type) + (c-number-type-p arg1-type) + (c-number-type-p arg2-type)) + ;; The input arguments have to be coerced to a C + ;; type that fits the output, to avoid overflow which + ;; would happen if we used say, long c = (int)a * (int)b + ;; as the output would be an integer, not a long. + (let* ((arg1-rep (lisp-type->rep-type arg1-type)) + (arg2-rep (lisp-type->rep-type arg2-type)) + (out-rep (lisp-type->rep-type expected-type)) + (max-rep (most-generic-number-rep-type + (most-generic-number-rep-type + arg1-rep arg2-rep) out-rep)) + (max-name (rep-type->c-name max-rep))) + (produce-inline-loc + (list arg1 arg2) + (list arg1-rep arg2-rep) + (list max-rep) + (format nil "(~@[(~A)~]#0)~A(~@[(~A)~]#1)" + (unless (eq arg1-rep max-rep) max-name) + non-consing + (unless (eq arg2-rep max-rep) max-name)) + nil t)) + (produce-inline-loc (list arg1 arg2) '(:object :object) '(:object) + consing nil t)))) + +(defun inline-arith-unop (expected-type arg1 consing non-consing) + (let ((arg1-type (inlined-arg-type arg1))) + (if (and (policy-assume-right-type) + (c-number-type-p expected-type) + (c-number-type-p arg1-type)) + (produce-inline-loc (list arg1) + (list (lisp-type->rep-type arg1-type)) + (list (lisp-type->rep-type expected-type)) + non-consing nil t) + (produce-inline-loc (list arg1) '(:object :object) '(:object) + consing nil t)))) + +(define-c-inliner + (return-type &rest arguments &aux arg1 arg2) + (when (null arguments) + (return '(fixnum-value 0))) + (setf arg1 (pop arguments)) + (when (null arguments) + (return (inlined-arg-loc arg1))) + (loop for arg2 = (pop arguments) + for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+) + do (if arguments + (setf arg1 (save-inline-loc result)) + (return result)))) + +(define-c-inliner - (return-type arg1 &rest arguments &aux arg2) + (when (null arguments) + (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)"))) + (loop for arg2 = (pop arguments) + for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-) + do (if arguments + (setf arg1 (save-inline-loc result)) + (return result)))) + +(define-c-inliner * (return-type &rest arguments &aux arg1 arg2) + (when (null arguments) + (return '(fixnum-value 1))) + (setf arg1 (pop arguments)) + (when (null arguments) + (return (inlined-arg-loc arg1))) + (loop for arg2 = (pop arguments) + for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*) + do (if arguments + (setf arg1 (save-inline-loc result)) + (return result)))) + +(define-c-inliner / (return-type arg1 &rest arguments &aux arg2) + (when (null arguments) + (return (inline-arith-unop return-type arg1 + "ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)"))) + (loop for arg2 = (pop arguments) + for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/) + do (if arguments + (setf arg1 (save-inline-loc result)) + (return result)))) diff --git a/src/cmp/cmpnum.lsp b/src/cmp/cmpnum.lsp deleted file mode 100644 index 54a59fe67..000000000 --- a/src/cmp/cmpnum.lsp +++ /dev/null @@ -1,322 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; -;;;; CMPNUM -- Optimizer for numerical expressions. - -;;;; Copyright (c) 2005, Juan Jose Garcia Ripoll -;;;; -;;;; ECoLisp is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. -;;;; -;;;; See file '../Copyright' for full details. - -(in-package "COMPILER") - -;;---------------------------------------------------------------------- -;; We transform BOOLE into the individual operations, which have -;; inliners -;; - -(define-compiler-macro boole (&whole form op-code op1 op2) - (or (and (constantp op-code *cmp-env*) - (case (ext:constant-form-value op-code *cmp-env*) - (#. boole-clr `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) 0)) - (#. boole-set `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) -1)) - (#. boole-1 `(prog1 (ext:checked-value integer ,op1) (ext:checked-value integer ,op2))) - (#. boole-2 `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2))) - (#. boole-c1 `(prog1 (lognot ,op1) (ext:checked-value integer ,op2))) - (#. boole-c2 `(progn (ext:checked-value integer ,op1) (lognot ,op2))) - (#. boole-and `(logand ,op1 ,op2)) - (#. boole-ior `(logior ,op1 ,op2)) - (#. boole-xor `(logxor ,op1 ,op2)) - (#. boole-eqv `(logeqv ,op1 ,op2)) - (#. boole-nand `(lognand ,op1 ,op2)) - (#. boole-nor `(lognor ,op1 ,op2)) - (#. boole-andc1 `(logandc1 ,op1 ,op2)) - (#. boole-andc2 `(logandc2 ,op1 ,op2)) - (#. boole-orc1 `(logorc1 ,op1 ,op2)) - (#. boole-orc2 `(logorc2 ,op1 ,op2)))) - form)) - -(defun simplify-arithmetic (operator args whole) - (if (every #'numberp args) - (apply operator args) - (let ((l (length args))) - (cond ((> l 2) - (simplify-arithmetic - operator - (list* (simplify-arithmetic operator - (list (first args) (second args)) - nil) - (cddr args)) - nil)) - ((= l 2) - (or whole (list* operator args))) - ((= l 1) - (if (or (eq operator '*) (eq operator '+)) - (first args) - (or whole (list* operator args)))) - ((eq operator '*) - 1) - ((eq operator '+) - 0) - (t - (error 'simple-program-error - :format-error "Wrong number of arguments for operator ~a in ~a" - :format-arguments (list operator (or whole - (list* operator args))))))))) - -(define-compiler-macro * (&whole all &rest args) - (simplify-arithmetic '* args all)) - -(define-compiler-macro + (&whole all &rest args) - (simplify-arithmetic '+ args all)) - -(define-compiler-macro / (&whole all &rest args) - (simplify-arithmetic '/ args all)) - -(define-compiler-macro - (&whole all &rest args) - (simplify-arithmetic '- args all)) - -;;; -;;; The following are type propagators for arithmetic operations. Note -;;; that some of they have become binary operators. -;;; - -(defun maximum-number-type (type1 type2 &key only-real integer-result) - ;; Computes the output type of an operation between number types T1 - ;; and T2 using the rules of floating point contagion. It returns - ;; the type of the result, and the types of T1 and T2, if they - ;; represent known types, or NUMBER, in other cases. - (let ((t1-eq nil) - (t2-eq nil) - (t1 type1) - (t2 type2) - (output nil) - (complex-t1 nil) - (complex-t2 nil) - (default (if only-real 'REAL 'NUMBER)) - (number-types #(FIXNUM INTEGER RATIONAL SINGLE-FLOAT - DOUBLE-FLOAT LONG-FLOAT FLOAT REAL))) - (when (and (consp t1) (eq (first t1) 'COMPLEX)) - (setf t1 (second t1) complex-t1 t)) - (when (and (consp t2) (eq (first t2) 'COMPLEX)) - (setf t2 (second t2) complex-t2 t)) - (when (and only-real (or complex-t1 complex-t2)) - (return-from maximum-number-type (values default default default))) - (loop for i across number-types - do (when (and (null t1-eq) (type>= i t1)) - (when (equalp t1 t2) - (setf t2-eq i)) - (setf t1-eq i output i)) - (when (and (null t2-eq) (type>= i t2)) - (setf t2-eq i output i))) - (unless (and t1-eq t2-eq output) - (setf output default)) - (when (and integer-result (or (eq output 'FIXNUM) (eq output 'INTEGER))) - (setf output integer-result)) - (when (and (or complex-t1 complex-t2) (not (eq output 'NUMBER))) - (setf output (if (eq output 'REAL) 'COMPLEX `(COMPLEX ,output)))) - (values output (if t1-eq type1 default) (if t2-eq type2 default)))) - -(defun ensure-number-type (general-type &key integer-result) - (maximum-number-type general-type general-type :integer-result integer-result)) - -(defun ensure-nonrational-type (general-type) - (maximum-number-type general-type 'single-float)) - -(defun ensure-real-type (general-type) - (maximum-number-type general-type 'integer :only-real t)) - -(defun arithmetic-propagator (op1-type others integer-result) - ;; Propagates types for an associative operator (we do not care which one). - ;; We collect either the types of the arguments or 'NUMBER, as a generic - ;; expected type. The output type is computed using the rules of floating - ;; point contagion, with the exception that an operation between two - ;; integers has type INTEGER-RESULT (integer for *,-,+ and rational else) - (multiple-value-bind (result-type op1-type) - (ensure-number-type op1-type :integer-result integer-result) - (loop with arg-types = (list op1-type) - for x in others - for op2-type = x - do (progn - (multiple-value-setq (result-type op1-type op2-type) - (maximum-number-type result-type op2-type :integer-result integer-result)) - (setf arg-types (cons op2-type arg-types))) - finally (return (values (nreverse arg-types) result-type))))) - -(def-type-propagator * (fname op1 &rest others) - (arithmetic-propagator op1 others 'integer)) - -(copy-type-propagator '* '(+ -)) - -(def-type-propagator / (fname op1 &rest others) - (arithmetic-propagator op1 others 'rational)) - -(defun most-generic-number-rep-type (r1 r2) - (let* ((r1 (rep-type-record r1)) - (r2 (rep-type-record r2))) - (rep-type-name (if (< (rep-type-index r1) (rep-type-index r2)) - r2 - r1)))) - -(defun inline-binop (expected-type arg1 arg2 consing non-consing) - (let ((arg1-type (inlined-arg-type arg1)) - (arg2-type (inlined-arg-type arg2))) - (if (and (policy-assume-right-type) - (c-number-type-p expected-type) - (c-number-type-p arg1-type) - (c-number-type-p arg2-type)) - ;; The input arguments have to be coerced to a C - ;; type that fits the output, to avoid overflow which - ;; would happen if we used say, long c = (int)a * (int)b - ;; as the output would be an integer, not a long. - (let* ((arg1-rep (lisp-type->rep-type arg1-type)) - (arg2-rep (lisp-type->rep-type arg2-type)) - (out-rep (lisp-type->rep-type expected-type)) - (max-rep (most-generic-number-rep-type - (most-generic-number-rep-type - arg1-rep arg2-rep) out-rep)) - (max-name (rep-type->c-name max-rep))) - (produce-inline-loc - (list arg1 arg2) - (list arg1-rep arg2-rep) - (list max-rep) - (format nil "(~@[(~A)~]#0)~A(~@[(~A)~]#1)" - (unless (eq arg1-rep max-rep) max-name) - non-consing - (unless (eq arg2-rep max-rep) max-name)) - nil t)) - (produce-inline-loc (list arg1 arg2) '(:object :object) '(:object) - consing nil t)))) - -(defun inline-arith-unop (expected-type arg1 consing non-consing) - (let ((arg1-type (inlined-arg-type arg1))) - (if (and (policy-assume-right-type) - (c-number-type-p expected-type) - (c-number-type-p arg1-type)) - (produce-inline-loc (list arg1) - (list (lisp-type->rep-type arg1-type)) - (list (lisp-type->rep-type expected-type)) - non-consing nil t) - (produce-inline-loc (list arg1) '(:object :object) '(:object) - consing nil t)))) - -(define-c-inliner + (return-type &rest arguments &aux arg1 arg2) - (when (null arguments) - (return '(fixnum-value 0))) - (setf arg1 (pop arguments)) - (when (null arguments) - (return (inlined-arg-loc arg1))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) - -(define-c-inliner - (return-type arg1 &rest arguments &aux arg2) - (when (null arguments) - (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)"))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) - -(define-c-inliner * (return-type &rest arguments &aux arg1 arg2) - (when (null arguments) - (return '(fixnum-value 1))) - (setf arg1 (pop arguments)) - (when (null arguments) - (return (inlined-arg-loc arg1))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) - -(define-c-inliner / (return-type arg1 &rest arguments &aux arg2) - (when (null arguments) - (return (inline-arith-unop return-type arg1 - "ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)"))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) - -;;; -;;; SPECIAL FUNCTIONS -;;; - -(def-type-propagator cos (fname op1-type) - (multiple-value-bind (output-type op1-type) - (ensure-nonrational-type op1-type) - (values (list op1-type) output-type))) - -(copy-type-propagator 'cos '(sin tan cosh sinh tanh exp)) - -(def-type-propagator acos (fname op1-type) - (multiple-value-bind (output-type op1-type) - (ensure-nonrational-type op1-type) - (declare (ignore output-type)) - (values (list op1-type) 'NUMBER))) - -(def-type-propagator atan (fname op1-type &optional (op2-type t op2-p)) - (multiple-value-bind (float-t1 t1) - (ensure-nonrational-type op1-type) - (if op2-p - (multiple-value-bind (result t1 t2) - (maximum-number-type t1 op2-type :only-real t) - (values (list t1 t2) result)) - (values (list t1) float-t1)))) - -(def-type-propagator expt (fname base exponent) - ;; Rules: - ;; (expt fixnum integer) -> integer - ;; (expt number-type integer) -> number-type - ;; (expt number-type1 number-type2) -> (max-float number-type1 number-type2) - ;; - (let ((exponent (ensure-real-type exponent))) - (values (list base exponent) - (cond ((eql exponent 'integer) - (if (subtypep base 'fixnum) - 'integer - base)) - ((type>= '(real 0 *) base) - (let* ((exponent (ensure-nonrational-type exponent))) - (maximum-number-type exponent base))) - (t - 'number))))) - -(def-type-propagator abs (fname arg) - (multiple-value-bind (output arg) - (ensure-number-type arg) - (values (list arg) - (or (cdr (assoc output - '((FIXNUM . (INTEGER 0 #.MOST-POSITIVE-FIXNUM)) - (INTEGER . (INTEGER 0 *)) - (RATIONAL . (RATIONAL 0 *)) - (SHORT-FLOAT . (SHORT-FLOAT 0 *)) - (SINGLE-FLOAT . (SINGLE-FLOAT 0 *)) - (DOUBLE-FLOAT . (DOUBLE-FLOAT 0 *)) - (LONG-FLOAT . (LONG-FLOAT 0 *)) - (REAL . (REAL 0 *)) - (NUMBER . (REAL 0 *))))) - output)))) - -(def-type-propagator sqrt (fname arg) - (multiple-value-bind (output arg) - (ensure-nonrational-type arg) - (values (list arg) - (if (type>= '(REAL 0 *) arg) output 'NUMBER)))) - -(def-type-propagator isqrt (fname arg) - (if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg) - (values '((integer 0 #.MOST-POSITIVE-FIXNUM)) - '(integer 0 #.MOST-POSITIVE-FIXNUM)) - (values '((integer 0 *)) '(integer 0 *)))) - diff --git a/src/cmp/cmpopt-bits.lsp b/src/cmp/cmpopt-num.lsp similarity index 62% rename from src/cmp/cmpopt-bits.lsp rename to src/cmp/cmpopt-num.lsp index 88c7d42b3..4a02ab562 100644 --- a/src/cmp/cmpopt-bits.lsp +++ b/src/cmp/cmpopt-num.lsp @@ -1,21 +1,40 @@ ;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- ;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: +;;;; Copyright (c) 2010, Juan Jose Garcia Ripoll ;;;; -;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll -;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. -;;;; -;;;; See file '../Copyright' for full details. -;;;; -;;;; CMPOPT-BITS -- Optimize operations acting on bits +;;;; See the file 'LICENSE' for the copyright details. ;;;; +;;;; Optimizer for numerical expressions. + (in-package "COMPILER") +;;; +;;; We transform BOOLE into the individual operations, which have inliners +;;; + +(define-compiler-macro boole (&whole form op-code op1 op2) + (or (and (constantp op-code *cmp-env*) + (case (ext:constant-form-value op-code *cmp-env*) + (#. boole-clr `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) 0)) + (#. boole-set `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) -1)) + (#. boole-1 `(prog1 (ext:checked-value integer ,op1) (ext:checked-value integer ,op2))) + (#. boole-2 `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2))) + (#. boole-c1 `(prog1 (lognot ,op1) (ext:checked-value integer ,op2))) + (#. boole-c2 `(progn (ext:checked-value integer ,op1) (lognot ,op2))) + (#. boole-and `(logand ,op1 ,op2)) + (#. boole-ior `(logior ,op1 ,op2)) + (#. boole-xor `(logxor ,op1 ,op2)) + (#. boole-eqv `(logeqv ,op1 ,op2)) + (#. boole-nand `(lognand ,op1 ,op2)) + (#. boole-nor `(lognor ,op1 ,op2)) + (#. boole-andc1 `(logandc1 ,op1 ,op2)) + (#. boole-andc2 `(logandc2 ,op1 ,op2)) + (#. boole-orc1 `(logorc1 ,op1 ,op2)) + (#. boole-orc2 `(logorc2 ,op1 ,op2)))) + form)) + ;;; ;;; LDB ;;; Look for inline expansion of LDB1 in sysfun.lsp @@ -123,9 +142,6 @@ ;;; ;;; ASH -;;; Bit fiddling. It is a bit tricky because C does not allow -;;; shifts in << or >> which exceed the integer size. In those -;;; cases the compiler may do whatever it wants (and gcc does!) ;;; (define-compiler-macro ash (&whole whole argument shift) @@ -140,39 +156,42 @@ (t whole))) -(define-c-inliner shift (return-type argument orig-shift) - (let* ((arg-type (inlined-arg-type argument)) - (arg-c-type (lisp-type->rep-type arg-type)) - (return-c-type (lisp-type->rep-type return-type)) - (shift (loc-immediate-value (inlined-arg-loc orig-shift)))) - (if (or (not (c-integer-rep-type-p arg-c-type)) - (not (c-integer-rep-type-p return-c-type))) - (produce-inline-loc (list argument orig-shift) '(:object :fixnum) '(:object) - "ecl_ash(#0,#1)" nil t) - (let* ((arg-bits (c-integer-rep-type-bits arg-c-type)) - (return-bits (c-integer-rep-type-bits return-c-type)) - (max-type (if (and (plusp shift) - (< arg-bits return-bits)) - return-c-type - arg-c-type))) - (produce-inline-loc (list argument) (list max-type) (list return-type) - (format nil - (if (minusp shift) - "((#0) >> (~D))" - "((#0) << (~D))") - (abs shift)) - nil t))))) +(defun simplify-arithmetic (operator args whole) + (if (every #'numberp args) + (apply operator args) + (let ((l (length args))) + (cond ((> l 2) + (simplify-arithmetic + operator + (list* (simplify-arithmetic operator + (list (first args) (second args)) + nil) + (cddr args)) + nil)) + ((= l 2) + (or whole (list* operator args))) + ((= l 1) + (if (or (eq operator '*) (eq operator '+)) + (first args) + (or whole (list* operator args)))) + ((eq operator '*) + 1) + ((eq operator '+) + 0) + (t + (error 'simple-program-error + :format-error "Wrong number of arguments for operator ~a in ~a" + :format-arguments (list operator (or whole + (list* operator args))))))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; TYPE PROPAGATION -;;; +(define-compiler-macro * (&whole all &rest args) + (simplify-arithmetic '* args all)) -(def-type-propagator logand (fname &rest args) - (values args - (if args - (dolist (int-type '((UNSIGNED-BYTE 8) FIXNUM) 'integer) - (when (loop for value in args - always (subtypep value int-type)) - (return int-type))) - 'fixnum))) +(define-compiler-macro + (&whole all &rest args) + (simplify-arithmetic '+ args all)) + +(define-compiler-macro / (&whole all &rest args) + (simplify-arithmetic '/ args all)) + +(define-compiler-macro - (&whole all &rest args) + (simplify-arithmetic '- args all)) diff --git a/src/cmp/cmpprop-num.lsp b/src/cmp/cmpprop-num.lsp new file mode 100644 index 000000000..7eccdf2d7 --- /dev/null +++ b/src/cmp/cmpprop-num.lsp @@ -0,0 +1,172 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; Copyright (c) 2010, Juan Jose Garcia Ripoll +;;;; +;;;; See the file 'LICENSE' for the copyright details. +;;;; + +;;;; Type propagators for numerical expressions. + +(in-package "COMPILER") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; TYPE PROPAGATION +;;; + +(def-type-propagator logand (fname &rest args) + (values args + (if args + (dolist (int-type '((UNSIGNED-BYTE 8) FIXNUM) 'integer) + (when (loop for value in args + always (subtypep value int-type)) + (return int-type))) + 'fixnum))) + +;;; +;;; The following are type propagators for arithmetic operations. Note +;;; that some of they have become binary operators. +;;; + +(defun maximum-number-type (type1 type2 &key only-real integer-result) + ;; Computes the output type of an operation between number types T1 + ;; and T2 using the rules of floating point contagion. It returns + ;; the type of the result, and the types of T1 and T2, if they + ;; represent known types, or NUMBER, in other cases. + (let ((t1-eq nil) + (t2-eq nil) + (t1 type1) + (t2 type2) + (output nil) + (complex-t1 nil) + (complex-t2 nil) + (default (if only-real 'REAL 'NUMBER)) + (number-types #(FIXNUM INTEGER RATIONAL SINGLE-FLOAT + DOUBLE-FLOAT LONG-FLOAT FLOAT REAL))) + (when (and (consp t1) (eq (first t1) 'COMPLEX)) + (setf t1 (second t1) complex-t1 t)) + (when (and (consp t2) (eq (first t2) 'COMPLEX)) + (setf t2 (second t2) complex-t2 t)) + (when (and only-real (or complex-t1 complex-t2)) + (return-from maximum-number-type (values default default default))) + (loop for i across number-types + do (when (and (null t1-eq) (type>= i t1)) + (when (equalp t1 t2) + (setf t2-eq i)) + (setf t1-eq i output i)) + (when (and (null t2-eq) (type>= i t2)) + (setf t2-eq i output i))) + (unless (and t1-eq t2-eq output) + (setf output default)) + (when (and integer-result (or (eq output 'FIXNUM) (eq output 'INTEGER))) + (setf output integer-result)) + (when (and (or complex-t1 complex-t2) (not (eq output 'NUMBER))) + (setf output (if (eq output 'REAL) 'COMPLEX `(COMPLEX ,output)))) + (values output (if t1-eq type1 default) (if t2-eq type2 default)))) + +(defun ensure-number-type (general-type &key integer-result) + (maximum-number-type general-type general-type :integer-result integer-result)) + +(defun ensure-nonrational-type (general-type) + (maximum-number-type general-type 'single-float)) + +(defun ensure-real-type (general-type) + (maximum-number-type general-type 'integer :only-real t)) + +(defun arithmetic-propagator (op1-type others integer-result) + ;; Propagates types for an associative operator (we do not care which one). + ;; We collect either the types of the arguments or 'NUMBER, as a generic + ;; expected type. The output type is computed using the rules of floating + ;; point contagion, with the exception that an operation between two + ;; integers has type INTEGER-RESULT (integer for *,-,+ and rational else) + (multiple-value-bind (result-type op1-type) + (ensure-number-type op1-type :integer-result integer-result) + (loop with arg-types = (list op1-type) + for x in others + for op2-type = x + do (progn + (multiple-value-setq (result-type op1-type op2-type) + (maximum-number-type result-type op2-type :integer-result integer-result)) + (setf arg-types (cons op2-type arg-types))) + finally (return (values (nreverse arg-types) result-type))))) + +(def-type-propagator * (fname op1 &rest others) + (arithmetic-propagator op1 others 'integer)) + +(copy-type-propagator '* '(+ -)) + +(def-type-propagator / (fname op1 &rest others) + (arithmetic-propagator op1 others 'rational)) + +;;; +;;; SPECIAL FUNCTIONS +;;; + +(def-type-propagator cos (fname op1-type) + (multiple-value-bind (output-type op1-type) + (ensure-nonrational-type op1-type) + (values (list op1-type) output-type))) + +(copy-type-propagator 'cos '(sin tan cosh sinh tanh exp)) + +(def-type-propagator acos (fname op1-type) + (multiple-value-bind (output-type op1-type) + (ensure-nonrational-type op1-type) + (declare (ignore output-type)) + (values (list op1-type) 'NUMBER))) + +(def-type-propagator atan (fname op1-type &optional (op2-type t op2-p)) + (multiple-value-bind (float-t1 t1) + (ensure-nonrational-type op1-type) + (if op2-p + (multiple-value-bind (result t1 t2) + (maximum-number-type t1 op2-type :only-real t) + (values (list t1 t2) result)) + (values (list t1) float-t1)))) + +(def-type-propagator expt (fname base exponent) + ;; Rules: + ;; (expt fixnum integer) -> integer + ;; (expt number-type integer) -> number-type + ;; (expt number-type1 number-type2) -> (max-float number-type1 number-type2) + ;; + (let ((exponent (ensure-real-type exponent))) + (values (list base exponent) + (cond ((eql exponent 'integer) + (if (subtypep base 'fixnum) + 'integer + base)) + ((type>= '(real 0 *) base) + (let* ((exponent (ensure-nonrational-type exponent))) + (maximum-number-type exponent base))) + (t + 'number))))) + +(def-type-propagator abs (fname arg) + (multiple-value-bind (output arg) + (ensure-number-type arg) + (values (list arg) + (or (cdr (assoc output + '((FIXNUM . (INTEGER 0 #.MOST-POSITIVE-FIXNUM)) + (INTEGER . (INTEGER 0 *)) + (RATIONAL . (RATIONAL 0 *)) + (SHORT-FLOAT . (SHORT-FLOAT 0 *)) + (SINGLE-FLOAT . (SINGLE-FLOAT 0 *)) + (DOUBLE-FLOAT . (DOUBLE-FLOAT 0 *)) + (LONG-FLOAT . (LONG-FLOAT 0 *)) + (REAL . (REAL 0 *)) + (NUMBER . (REAL 0 *))))) + output)))) + +(def-type-propagator sqrt (fname arg) + (multiple-value-bind (output arg) + (ensure-nonrational-type arg) + (values (list arg) + (if (type>= '(REAL 0 *) arg) output 'NUMBER)))) + +(def-type-propagator isqrt (fname arg) + (if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg) + (values '((integer 0 #.MOST-POSITIVE-FIXNUM)) + '(integer 0 #.MOST-POSITIVE-FIXNUM)) + (values '((integer 0 *)) '(integer 0 *)))) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 92e6f799b..2465fdff5 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -44,11 +44,13 @@ "src:cmp;cmppass1-ffi.lsp" ;; Type propagation pass "src:cmp;cmpprop.lsp" + "src:cmp;cmpprop-num.lsp" ;; C/C++ backend ;; Abstract C machine "src:cmp;cmpbackend-cxx;cmpc-mach.lsp" "src:cmp;cmpbackend-cxx;cmpc-wt.lsp" "src:cmp;cmpbackend-cxx;cmpc-inliner.lsp" + "src:cmp;cmpbackend-cxx;cmpc-opt-num.lsp" ;; Code generation pass "src:cmp;cmpbackend-cxx;cmppass2-data.lsp" "src:cmp;cmpbackend-cxx;cmppass2-top.lsp" @@ -66,10 +68,9 @@ ;; Optimizations "src:cmp;cmpct.lsp" "src:cmp;cmpmap.lsp" - "src:cmp;cmpnum.lsp" "src:cmp;cmpname.lsp" "src:cmp;cmpopt.lsp" - "src:cmp;cmpopt-bits.lsp" + "src:cmp;cmpopt-num.lsp" "src:cmp;cmpopt-clos.lsp" "src:cmp;cmpopt-constant.lsp" "src:cmp;cmpopt-cons.lsp"