diff --git a/src/CHANGELOG b/src/CHANGELOG index e01ad7475..681089095 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -60,6 +60,8 @@ ECL 1.0: * Bugs fixed: + - Remove ancient, bogus optimizers for: ASH, LDB. + - MINGW's compiler is broken: it does not accept directories with trailing slashes as an argument to "-I". We include a hack in cmpmain.lsp for that. diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index 066b0fb79..dd9535f62 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -201,30 +201,6 @@ (6 (list 'CDDR (cons 'CDDDDR (cdr args)))) (7 (list 'CDDDR (cons 'CDDDDR (cdr args)))))))) -;---------------------------------------------------------------------- - -(defun co1ash (args) - (let ((shamt (second args)) type fun) - (when (cond ((and (constantp shamt) - (sys::fixnump (setq shamt (eval shamt)))) - (setq fun (if (< shamt 0) 'SHIFT>> 'SHIFT<<))) - ((and (consp shamt) - (eq (car shamt) 'THE) - (or (subtypep (setq type (second shamt)) - '(INTEGER 0 100)) - (and (boundp 'SYS::*ASH->>*) sys::*ash->>* - (subtypep type '(INTEGER -100 0))))) - (setq fun - ;; it had to be a (the type..) - (cond ((subtypep type '(INTEGER 0 100)) - 'SHIFT<<) - ((subtypep type '(INTEGER -100 0)) - 'SHIFT>>))))) - (c1expr (cons fun args))))) - -(setf (symbol-function 'shift<<) #'ash) -(setf (symbol-function 'shift>>) #'ash) - ;;---------------------------------------------------------------------- ;; We transform BOOLE into the individual operations, which have ;; inliners @@ -358,7 +334,6 @@ (put-sysprop 'nth 'C1CONDITIONAL 'co1nth) (put-sysprop 'nthcdr 'C1CONDITIONAL 'co1nthcdr) -(put-sysprop 'ash 'C1CONDITIONAL 'co1ash) (put-sysprop 'coerce 'C1CONDITIONAL 'co1coerce) (put-sysprop 'cons 'C1CONDITIONAL 'co1cons) (put-sysprop 'ldb 'C1CONDITIONAL 'co1ldb) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index 228332273..ad1b48ba5 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -70,28 +70,22 @@ (arg-locs (inline-args args)) (loc (inline-function fname arg-locs return-type))) (if loc - (progn - ;; If there are side effects, we may not move the C form - ;; around and we have to save its value in a variable. - ;; We use a variable of type out-type to save the value - ;; if (return-type >= out-type) - ;; then - ;; coerce the value to out-type - ;; otherwise - ;; save the value without coercion and return the - ;; variable tagged with and-type, - ;; so that whoever uses it may coerce it to such type - (when (and (consp loc) - (eq (first loc) 'C-INLINE) - (not (all-locations (rest forms))) - (or (need-to-protect (rest forms)) - (fifth loc))) ; side effects? - (let* ((and-type (type-and return-type (loc-type loc))) - (out-rep-type (loc-representation-type loc)) - (var (make-lcl-var :rep-type out-rep-type :type and-type))) - (wt-nl "{" (rep-type-name out-rep-type) " " var "= " loc ";") - (incf *inline-blocks*) - (setq loc var))) + ;; If there are side effects, we may not move the C form + ;; around and we have to save its value in a variable. + ;; We use a variable of type out-type to save the value + ;; if (return-type >= out-type) + ;; then + ;; coerce the value to out-type + ;; otherwise + ;; save the value without coercion and return the + ;; variable tagged with and-type, + ;; so that whoever uses it may coerce it to such type + (let* ((and-type (type-and return-type (loc-type loc))) + (out-rep-type (loc-representation-type loc)) + (var (make-lcl-var :rep-type out-rep-type :type and-type))) + (wt-nl "{" (rep-type-name out-rep-type) " " var "= " loc ";") + (incf *inline-blocks*) + (setq loc var) (push (list (loc-type loc) loc) locs)) ;; FIXME! Why is (make-temp-var) before rebinding of *temp*??? (let* ((temp (make-temp-var)) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 75c60342a..9c408b60b 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -846,7 +846,7 @@ (proclaim-function logbitp (t t) t :predicate t :no-side-effects t) (def-inline logbitp :always ((integer -29 29) fixnum) :bool "(#1 >> #0) & 1") -(proclaim-function ash (t t) t) +(proclaim-function ash (integer integer) t) (proclaim-function logcount (t) t) (proclaim-function integer-length (t) fixnum) (proclaim-function si:bit-array-op (*) t)