Commit bffb8433 authored by Mark Evenson's avatar Mark Evenson

Fix java.lang.VerifyError with PROGN

(somewhat-functional-programmer)

- Added a constant folding case if arg2 was detected as a constant
  (but wasn't a literal integer, such as (- 1) )

- Fixed all with-operand-accumulation forms to have the correct types

- Added test cases that exercise all code paths of p2-ash

<https://mailman.common-lisp.net/pipermail/armedbear-devel/2019-December/004029.html>
parent e02795c8
......@@ -4236,13 +4236,18 @@ given a specific common representation.")
(constant-shift (fixnum-constant-value type2))
(result-type (derive-compiler-type form)))
(cond ((and (integerp arg1) (integerp arg2))
;; test t/ash.lisp: ash-constant
(compile-constant (ash arg1 arg2) target representation))
((and (integerp arg1) constant-shift)
;; test t/ash.lisp: ash-constant2
(compile-constant (ash arg1 constant-shift) target representation))
((and constant-shift
;; ishl/ishr only use the low five bits of the mask.
(<= -31 constant-shift 31)
(fixnum-type-p type1)
(fixnum-type-p result-type))
(cond ((plusp constant-shift)
;; test t/ash.lisp: ash-fixnum1-pos-constant-shift2
(with-operand-accumulation
((compile-operand arg1 :int)
(compile-operand arg2 :int)
......@@ -4250,21 +4255,24 @@ given a specific common representation.")
(emit 'ishl))
((minusp constant-shift)
(cond ((fixnump arg2)
;; test t/ash.lisp: ash-fixnum1-neg-constant-shift2
(with-operand-accumulation
((compile-operand arg1 :int)
(accumulate-operand (representation)
(accumulate-operand (:int)
(emit-push-constant-int (- arg2)))
(maybe-emit-clear-values arg1))))
(t
;; test t/ash.lisp: ash-fixnum1-neg-constant-shift-form2
(with-operand-accumulation
((compile-operand arg1 :int)
(accumulate-operand (representation :unsafe-p t)
(accumulate-operand (:int)
(compile-form arg2 'stack :int)
(emit 'ineg))
(maybe-emit-clear-values arg1 arg2)))))
(maybe-emit-clear-values arg1 arg2)
(emit 'ishr))
((zerop constant-shift)
;; test t/ash.lisp: ash-fixnum1-zero-shift2
(compile-form arg1 'stack :int)
(compile-form arg2 nil nil))) ; for effect
(convert-representation :int representation)
......@@ -4275,6 +4283,7 @@ given a specific common representation.")
(java-long-type-p type1)
(java-long-type-p result-type))
(cond ((plusp constant-shift)
;; test t/ash.lisp: ash-long1-pos-constant-shift2
(with-operand-accumulation
((compile-operand arg1 :long)
(compile-operand arg2 :int)
......@@ -4282,30 +4291,37 @@ given a specific common representation.")
(emit 'lshl))
((minusp constant-shift)
(cond ((fixnump arg2)
;; test t/ash.lisp: ash-long1-neg-constant-shift2
(with-operand-accumulation
((compile-operand arg1 :long)
(with-operand-accumulation (representation)
(with-operand-accumulation (:int)
(emit-push-constant-int (- arg2)))
(maybe-emit-clear-values arg1))))
(t
;; test t/ash.lisp: ash-long1-neg-constant-shift-form2
(with-operand-accumulation
((compile-operand arg1 :long)
(accumulate-operand (representation :unsafe-p t)
(accumulate-operand (:int)
(compile-form arg2 'stack :int)
(emit 'ineg))
(maybe-emit-clear-values arg1 arg2)))))
(maybe-emit-clear-values arg1 arg2)
(emit 'lshr))
((zerop constant-shift)
;; test t/ash.lisp: ash-long1-zero-shift2
(compile-form arg1 'stack :long)
(compile-form arg2 nil nil))) ; for effect
(convert-representation :long representation)
(emit-move-from-stack target representation))
((and (fixnum-type-p type1)
low2 high2 (<= -31 low2 high2 0)) ; Negative shift.
(compile-forms-and-maybe-emit-clear-values arg1 'stack :int
arg2 'stack :int)
(emit 'ineg)
;; t/ash.lisp: ash-fixnum1-neg-2
(with-operand-accumulation
((compile-operand arg1 :int)
(accumulate-operand (:int)
(compile-operand arg2 :int)
(emit 'ineg))))
(maybe-emit-clear-values arg1 arg2)
(emit 'ishr)
(convert-representation :int representation)
(emit-move-from-stack target representation))
......@@ -4313,6 +4329,7 @@ given a specific common representation.")
(cond ((and low2 high2 (<= 0 low2 high2 63) ; Non-negative shift.
(java-long-type-p type1)
(java-long-type-p result-type))
;; test t/ash.lisp: ash-long1-pos-fixnum2
(with-operand-accumulation
((compile-operand arg1 :long)
(compile-operand arg2 :int)
......@@ -4322,14 +4339,17 @@ given a specific common representation.")
((and low2 high2 (<= -63 low2 high2 0) ; Negative shift.
(java-long-type-p type1)
(java-long-type-p result-type))
;; test t/ash.lisp: ash-long1-neg-fixnum2
(with-operand-accumulation
((compile-operand arg1 :long)
(compile-operand arg2 :int)
(maybe-emit-clear-values arg1 arg2)))
(emit 'ineg)
(accumulate-operand (:int)
(compile-operand arg2 :int)
(emit 'ineg))))
(maybe-emit-clear-values arg1 arg2)
(emit 'lshr)
(convert-representation :long representation))
(t
;; test t/ash.lisp ash-long1-fixnum2
(with-operand-accumulation
((compile-operand arg1 nil)
(compile-operand arg2 :int)
......@@ -4338,6 +4358,7 @@ given a specific common representation.")
(fix-boxing representation result-type)))
(emit-move-from-stack target representation))
(t
;; test t/ash.lisp: ash-regular
(compile-function-call form target representation)))))
(defknown p2-logand (t t t) t)
......
(in-package :cl-user)
;; make sure we can compile even with non-opstack safe forms
(prove:plan 2)
(prove:ok
(compile
nil
'(lambda (a)
(ash 1
(the (unsigned-byte 8)
(block nil
(format t "side effect1~%")
(when a
(return-from nil a))
(format t "side effect2~%")
0)))))
"Compile opstack unsafe form within ash")
(prove:ok
(compile
nil
'(lambda (a)
(ash 1
(bit #*0100
(catch 'ct7 a)))))
"Compile opstack unsafe form within ash (original reported failure, github issue #69)")
(prove:finalize)
;; see comments in jvm::p2-ash for which sections of the function each of these tests exercises
(let ((all-tests
'((ash-fixnum1-pos-constant-shift2 ((lambda (x)
(ash (the (unsigned-byte 29) x) 2))
((2) => 8)
((4) => 16)))
(ash-fixnum1-neg-constant-shift2 ((lambda (x)
(ash (the (unsigned-byte 29) x) -2))
((2) => 0)
((4) => 1)
((0) => 0)))
(ash-fixnum1-neg-constant-shift-form2 ((lambda (x)
(ash (the (unsigned-byte 29) x) (- 2)))
((2) => 0)
((4) => 1)
((0) => 0)))
(ash-fixnum1-zero-shift2 ((lambda (x)
(ash (the (unsigned-byte 29) x) 0))
((2) => 2)
((4) => 4)
((0) => 0)))
(ash-long1-pos-constant-shift2 ((lambda (x)
(ash (the (unsigned-byte 61) x) 2))
((2) => 8)
((4) => 16)))
(ash-long1-neg-constant-shift2 ((lambda (x)
(ash (the (unsigned-byte 61) x) -2))
((2) => 0)
((4) => 1)
((0) => 0)))
(ash-long1-neg-constant-shift-form2 ((lambda (x)
(ash (the (unsigned-byte 61) x) (- 2)))
((2) => 0)
((4) => 1)
((0) => 0)))
(ash-long1-zero-shift2 ((lambda (x)
(ash (the (unsigned-byte 61) x) 0))
((2) => 2)
((4) => 4)
((0) => 0)))
(ash-fixnum1-neg-2 ((lambda (x y)
(ash (the (unsigned-byte 29) x) (the (integer -5 -1) y)))
((2 -1) => 1)
((4 -2) => 1)
((0 -2) => 0)))
(ash-long1-pos-fixnum2 ((lambda (x y)
(ash (the (unsigned-byte 40) x) (the (unsigned-byte 4) y)))
((2 2) => 8)
((4 2) => 16)))
(ash-long1-neg-fixnum2 ((lambda (x y)
(ash (the (unsigned-byte 40) x) (the (integer -5 -1) y)))
((4 -2) => 1)
((32 -1) => 16)))
(ash-long1-fixnum2 ((lambda (x y)
(ash (the (unsigned-byte 40) x) (the (integer -10 10) y)))
((2 3) => 16)
((4 -2) => 1)
((32 -1) => 16)))
(ash-regular ((lambda (x y)
(ash x y))
((2 3) => 16)
((4 -2) => 1)
((32 -1) => 16)))
(ash-constant ((lambda ()
(ash 2 4))
(() => 32)))
(ash-constant2 ((lambda ()
(ash 2 (+ 4)))
(() => 32))))))
(dolist (test-data all-tests)
(destructuring-bind (test-sym (test-fn &rest tests)) test-data
(prove:plan (1+ (length tests)))
(prove:ok
(compile test-sym test-fn)
(format nil "Checking for successful compilation of ~S: ~S" test-sym test-fn))
(dolist (test tests)
(destructuring-bind (args _ result) test
(declare (ignore _))
(prove:is
(apply test-sym args)
result
(format nil "Calling ~S with args ~S should be ~S" test-sym args result))))
(prove:finalize))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment