mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-18 07:12:26 -08:00
9229976731
C inliners for arithmetic operations assumed that there may be more than two
arguments and worked similar to reduce:
ARG_n+3 <- (inline-binop ARG_n+2 ARG_n+1) op ARG_n
that said ECL has compiler macros that simplify the arithmetic so there are
always at most two arguments, so it is enough to inline:
(inline-binop ARG1 ARG2)
As for the incorrect code -- when there were remaining arguments, the result of
the previous operation was saved with save-inline-loc, but(!) save-inline-loc
expected an inlined argument, while inline-binop calls produce-inline-loc that
returns a "normal" location - that's probably some change from the past, because
produce-inline-loc seems to clearly indicate that it should return inlined value
- and save-inline-loc would always error because of the argument type mismatch.
This commit removes the dead code and now unused save-inline-loc function.
200 lines
7.7 KiB
Common Lisp
200 lines
7.7 KiB
Common Lisp
;;;; -*- 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.
|
|
;;;;
|
|
|
|
;;;; 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
|
|
;;;
|
|
|
|
(defun inline-bytespec (bytespec)
|
|
(declare (si::c-local))
|
|
(and (consp bytespec)
|
|
(eq 'BYTE (car bytespec))
|
|
(= (length bytespec) 3)
|
|
(policy-inline-bit-operations)))
|
|
|
|
(define-compiler-macro ldb (&whole whole bytespec integer)
|
|
(if (inline-bytespec bytespec)
|
|
(ext:with-clean-symbols (%pos %size)
|
|
`(with-let*-type-check ((%size ,(second bytespec) unsigned-byte)
|
|
(%pos ,(third bytespec) unsigned-byte))
|
|
(logand (lognot (ash -1 %size)) (ash ,integer (- %pos)))))
|
|
whole))
|
|
|
|
(define-compiler-macro ldb-test (&whole whole bytespec integer)
|
|
(if (inline-bytespec bytespec)
|
|
`(not (zerop (mask-field ,bytespec ,integer)))
|
|
whole))
|
|
|
|
(define-compiler-macro mask-field (&whole whole bytespec integer)
|
|
(if (inline-bytespec bytespec)
|
|
(ext:with-clean-symbols (%pos %size)
|
|
`(with-let*-type-check ((%size ,(second bytespec) unsigned-byte)
|
|
(%pos ,(third bytespec) unsigned-byte))
|
|
(logand (ash (lognot (ash -1 %size)) %pos)
|
|
,integer)))
|
|
whole))
|
|
|
|
(define-compiler-macro dpb (&whole whole newbyte bytespec integer)
|
|
(if (inline-bytespec bytespec)
|
|
(ext:with-clean-symbols (%pos %size %mask)
|
|
`(with-let*-type-check ((%size ,(second bytespec) unsigned-byte)
|
|
(%pos ,(third bytespec) unsigned-byte)
|
|
(%mask (ash (lognot (ash -1 %size)) %pos) t))
|
|
(logior (logand (ash ,newbyte %pos) %mask)
|
|
(logandc2 ,integer %mask))))
|
|
whole))
|
|
|
|
(define-compiler-macro deposit-field (&whole whole newbyte bytespec integer)
|
|
(if (inline-bytespec bytespec)
|
|
(ext:with-clean-symbols (%pos %size %mask)
|
|
`(with-let*-type-check ((%size ,(second bytespec) unsigned-byte)
|
|
(%pos ,(third bytespec) unsigned-byte)
|
|
(%mask (ash (lognot (ash -1 %size)) %pos) t))
|
|
(logior (logand ,newbyte %mask)
|
|
(logandc2 ,integer %mask)
|
|
)))
|
|
whole))
|
|
|
|
(define-setf-expander ldb (&environment env bytespec int)
|
|
(multiple-value-bind (temps vals stores store-form access-form)
|
|
(get-setf-expansion int env)
|
|
(if (inline-bytespec bytespec)
|
|
(let* ((bpos (gensym))
|
|
(bsize (gensym))
|
|
(store (gensym))
|
|
(btemp `(byte ,bpos ,bsize))
|
|
(stemp (first stores)))
|
|
(values `(,bpos ,bsize ,@temps)
|
|
`(,(second bytespec) ,(third bytespec) ,@vals)
|
|
`(,store)
|
|
`(let ((,stemp (dpb ,store ,btemp ,access-form)))
|
|
,store-form ,store)
|
|
`(ldb ,btemp ,access-form)))
|
|
(let* ((btemp (gensym))
|
|
(store (gensym))
|
|
(stemp (first stores)))
|
|
(values `(,btemp ,@temps)
|
|
`(,bytespec ,@vals)
|
|
`(,store)
|
|
`(let ((,stemp (dpb ,store ,btemp ,access-form)))
|
|
,store-form ,store)
|
|
`(ldb ,btemp ,access-form))))))
|
|
|
|
(define-setf-expander mask-field (&environment env bytespec int)
|
|
(multiple-value-bind (temps vals stores store-form access-form)
|
|
(get-setf-expansion int env)
|
|
(if (inline-bytespec bytespec)
|
|
(let* ((bpos (gensym))
|
|
(bsize (gensym))
|
|
(store (gensym))
|
|
(btemp `(byte ,bpos ,bsize))
|
|
(stemp (first stores)))
|
|
(values `(,bpos ,bsize ,@temps)
|
|
`(,(second bytespec) ,(third bytespec) ,@vals)
|
|
`(,store)
|
|
`(let ((,stemp (deposit-field ,store ,btemp ,access-form)))
|
|
,store-form ,store)
|
|
`(mask-field ,btemp ,access-form)))
|
|
(let* ((btemp (gensym))
|
|
(store (gensym))
|
|
(stemp (first stores)))
|
|
(values `(,btemp ,@temps)
|
|
`(,bytespec ,@vals)
|
|
`(,store)
|
|
`(let ((,stemp (deposit-field ,store ,btemp ,access-form)))
|
|
,store-form ,store)
|
|
`(mask-field ,btemp ,access-form))))))
|
|
|
|
;;;
|
|
;;; ASH
|
|
;;;
|
|
|
|
(define-compiler-macro ash (&whole whole argument shift)
|
|
(cond ((and (integerp argument)
|
|
(integerp shift))
|
|
(ash argument shift))
|
|
((and (policy-assume-right-type)
|
|
(integerp shift))
|
|
(if (zerop shift)
|
|
argument
|
|
`(shift ,argument ,shift)))
|
|
(t
|
|
whole)))
|
|
|
|
(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)))))))))
|
|
|
|
;;; INV These compiler macros are expected to be in effect by C inliners
|
|
;;; defined for corresponding operators. -- jd 2023-12-04
|
|
|
|
(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))
|