[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
SIGSEGV cannot be cured
- To: clisp-list@ma2s2.mathematik.uni-karlsruhe.de
- Subject: SIGSEGV cannot be cured
- From: nathan@bristol.st.com
- Date: Mon, 30 Sep 1996 17:16:38 +0100 (BST)
Hi,
I appear to have a located a bug.
The program appended gives an uncurable segfault when running the compiled program.
here is the terminal output
***start terminal output
nathan@finlandia:1>clisp -q -c bang
Compiling file /home/nathan/tgz/sparc-SunOS-5.5-sun4u-X11+OpenGL/src/tools/cwic/bang.lsp ...
Compilation of file /home/nathan/tgz/sparc-SunOS-5.5-sun4u-X11+OpenGL/src/tools/cwic/bang.lsp is finished.
0 errors, 0 warnings
nathan@finlandia:2>clisp -q -i bang
> (bang)
Doing evaluate xor
handle_fault error1 !
*** - SIGSEGV cannot be cured. Fault address = 0x1703A000.
zsh: 7774 segmentation fault (core dumped) clisp -q -i bang
nathan@finlandia:3>clisp -q
> (lisp-implementation-version)
"1996-05-30 (May 1996)"
> (machine-version)
"SUN4U"
> (software-version)
"GNU C 2.7.2"
>
nathan@finlandia:4>uname -a
SunOS finlandia 5.5 Generic sun4u sparc SUNW,Ultra-1
nathan@finlandia:5>exit
***end terminal output
the lisp was compiled up by me using gcc
an SGI with "1996-04-17 (April 1996)", "IP22", & "GNU C 2.7.2.f.1" also exhibits the
same symptoms, and I suspect my linux system also had it, but I can't check that
right now.
the death appears to be between the two formats in the :expr-xor branch of evaluate's
outermost CASE form. But, removing the trailing IF, or altering any of
the preceeding CASE branches removes the problem. Strange indeed!
and here is the smallest program I can get to do this,
***start bad program
;;;; FOLD=";{{{" "" ";}}}"
;;;; $Id: cwc.lsp,v 1.17 1996/09/27 17:04:47 nathan Exp $
;;;; (C) 1996 Nathan Sidwell
;;; report a bug
;{{{(defun compiler-bug (&rest args)
(defun compiler-bug (format &rest args)
(format *error-output* "~&Compiler bug!~&~?" format args)
(throw 'compiler-bug nil))
;}}}
;{{{(defmacro compiler-assert (expr)
(defmacro compiler-assert (expr)
`(if (not ,expr)
(compiler-bug "Assertion of ~s failed~&" ',expr)))
;}}}
;{{{(defstruct type-node
(defstruct type-node
attrib ;sort of type :function :pointer :array :base :compound
of ;derived from
primary ;primary modifier
secondary) ;secondary modifier
;}}}
;;; information about a base type
;{{{(defstruct base-type
(defstruct base-type
self
category ;sint, uint, float, void, nil
limit) ;one greater than mostpos value for integral types, print digits for float
;}}}
(defvar *base-types*)
;;; add/override a base type
(defun add-base-type (name)
(setf (gethash name *base-types*)
(make-base-type :self name :category name :limit 256)))
;;; return type-info struct for a particular type.
(defun base-type-info (base-type)
(gethash base-type *base-types*))
;;; an ae-node is part of the abstract expression tree, which is what
;;; the program gets turned into.
;{{{(defstruct ae-node
(defstruct ae-node
attrib ;type of node
args ;arguments to ae node
type-node) ;type of node, if known
;}}}
;;; a value structure holds compile time information about expression values
;{{{(defstruct value
(defstruct value
type-node ;type of value
exact ;exact value
min ;min possible
max) ;max possible
;}}}
;{{{eval-return
;;; this structure is used to return information from the expression and
;;; statement productions and for the node evaluating functions
;{{{(defstruct eval-return
(defstruct eval-return
ae-node ; the ae-node
value ; value of expression struct:value
)
;}}}
;}}}
;;; evaluate an ae node, given the evaluate results of its child nodes.
;;; returns struct:value
;{{{(defun evaluate (ae-node &rest exprs)
(defun evaluate (ae-node &rest exprs)
(let ((value (make-value :type-node (ae-node-type-node ae-node))) info)
(setf info (base-type-info (type-node-of (value-type-node value))))
(case (ae-node-attrib ae-node)
;{{{:expr-literal
(:expr-literal
(case (type-node-attrib (value-type-node value))
(:base
(setf (value-exact value) (ae-node-args ae-node)))
(t
(setf value nil))))
;}}}
;{{{(:expr-or :expr-or-assign)
((:expr-or :expr-or-assign)
(let ((value-a (eval-return-value (first exprs)))
(value-b (eval-return-value (second exprs))) all-bits)
(compiler-assert (member (base-type-category info) '(sint uint)))
(case (base-type-category info)
(sint
(setf all-bits -1))
(uint
(setf all-bits (1- (base-type-limit info)))))
(cond
((and value-a (value-exact value-a) (eq (value-exact value-a) all-bits))
(setf (value-exact value) all-bits))
((and value-b (value-exact value-b) (eq (value-exact value-b) all-bits))
(setf (value-exact value) all-bits))
((and value-a value-b)
(if (and (value-exact value-a) (value-exact value-b))
(setf (value-exact value)
(logior (value-exact value-a) (value-exact value-b)))
;{{{combine ranges
;; to combine the ranges optimally is quite hard. Infact
;; I spent a couple of days figuring out the algorithm to
;; determine the optimum lower bound. The algorithm seemed
;; fairly complex and I had little confidence in my solutions
;; being correct -- three times I thought I had the correct
;; answer, but three times I was wrong. As the expected return
;; is small, I will be simplistic about combining ranges
(let ((min-a (value-min value-a)) (min-b (value-min value-b))
(max-a (value-max value-a)) (max-b (value-max value-b)))
(compiler-assert (eq (not min-a) (not max-a)))
(compiler-assert (eq (not min-b) (not max-b)))
(flet
((lsbmask (value)
(compiler-assert (not (minusp value)))
(do ((lsb (logand value (- value)) (logand value (- value))))
((= value lsb)
(if (zerop lsb) 0 (1- (ash lsb 1))))
(setf value (logxor value lsb)))))
(cond
((or (not min-a) (not min-b)))
;{{{both ranges positive
((and (plusp min-a) (plusp min-b))
(setf (value-min value) (max min-a min-b))
(let ((result (max max-a max-b))
(mask (lsbmask (min max-a max-b))))
(setf (value-max value) (logior result mask))))
;}}}
;{{{both ranges negative
((and (minusp max-a) (minusp max-b))
(setf (value-min value) (max min-a min-b))
(setf (value-max value) -1))
;}}}
;{{{both ranges include zero
((not (or (plusp min-a) (plusp min-b)
(minusp max-a) (minusp max-b)))
(setf (value-min value) (min min-a min-b))
(let ((result (max max-a max-b))
(mask (lsbmask (min max-a max-b))))
(setf (value-max value) (logior result mask))))
;}}}
;{{{a includes zero, b does not
((not (or (plusp min-a) (minusp max-a)))
(cond
;{{{b < 0?
((minusp max-b)
(setf (value-min value) (max min-a min-b))
(let ((result max-b) (mask (lsbmask max-a)))
(setf (value-max value) (logior result mask))))
;}}}
;{{{b > 0?
((plusp min-b)
(setf (value-min value) min-a)
(let ((result (max max-a max-b))
(mask (lsbmask (min max-a max-b))))
(setf (value-max value) (logior result mask))))
;}}}
(t
(compiler-bug "Logic error"))))
;}}}
;{{{b includes zero, a does not
((not (or (plusp min-b) (minusp max-b)))
(cond
;{{{a < 0?
((minusp max-a)
(setf (value-min value) (max min-a min-b))
(let ((result max-a) (mask (lsbmask max-b)))
(setf (value-max value) (logior result mask))))
;}}}
;{{{a > 0?
((plusp min-a)
(setf (value-min value) min-b)
(let ((result (max max-a max-b))
(mask (lsbmask (min max-a max-b))))
(setf (value-max value) (logior result mask))))
;}}}
(t
(compiler-bug "Logic error"))))
;}}}
(t
(compiler-bug "Cannot determine bitwise or interval")))))))
;}}}
)
))
;}}}
;{{{(:expr-and :expr-and-assign)
((:expr-and :expr-and-assign)
(let ((value-a (eval-return-value (first exprs)))
(value-b (eval-return-value (second exprs))) all-bits)
(compiler-assert (member (base-type-category info) '(sint uint)))
(case (base-type-category info)
(sint
(setf all-bits -1))
(uint
(setf all-bits (1- (base-type-limit info)))))
(cond
((and value-a (value-exact value-a) (zerop (value-exact value-a)))
(setf (value-exact value) 0))
((and value-b (value-exact value-b) (zerop (value-exact value-b)))
(setf (value-exact value) 0))
((and value-a value-b)
(if (and (value-exact value-a) (value-exact value-b))
(setf (value-exact value)
(logand (value-exact value-a) (value-exact value-b)))
;{{{combine ranges
;; to combine the ranges optimally is quite hard. Infact
;; I spent a couple of days figuring out the algorithm to
;; determine the optimum lower bound. The algorithm seemed
;; fairly complex and I had little confidence in my solutions
;; being correct -- three times I thought I had the correct
;; answer, but three times I was wrong. As the expected return
;; is small, I will be simplistic about combining ranges
(let ((min-a (value-min value-a)) (min-b (value-min value-b))
(max-a (value-max value-a)) (max-b (value-max value-b)))
(compiler-assert (eq (not min-a) (not max-a)))
(compiler-assert (eq (not min-b) (not max-b)))
(flet
((lsbmask (value)
(compiler-assert (minusp value))
(do ((lsb (logand value (- value)) (logand value (- value))))
((= (- value) lsb)
(if (zerop lsb) 0 (1- lsb)))
(setf value (logxor value lsb)))))
(cond
((or (not min-a) (not min-b)))
;{{{both ranges > -1
((not (or (minusp min-a) (minusp min-b)))
(setf (value-max value) (min max-a max-b))
(setf (value-min value) 0))
;}}}
;{{{both ranges < -1
((and (< max-a -1) (< max-b -1))
(setf (value-max value) (min max-a max-b))
(let ((result (min min-a min-b))
(mask (lsbmask (max min-a min-b))))
(setf (value-max value) (logandc2 result mask))))
;}}}
;{{{both ranges include -1
((not (or (> min-a -1) (> min-b -1)
(< max-a -1) (< max-b -1)))
(setf (value-max value) (max max-a max-b))
(let ((result (min min-a min-b))
(mask (lsbmask (max min-a min-b))))
(setf (value-min value) (logandc2 result mask))))
;}}}
;{{{a includes -1, b does not
((not (or (> min-a -1) (< max-a -1)))
(cond
;{{{b > -1
((> min-b -1)
(setf (value-max value) (min max-a max-b))
(let ((result min-b) (mask (lsbmask min-a)))
(setf (value-min value) (logandc2 result mask))))
;}}}
;{{{b < -1
((< max-b -1)
(setf (value-max value) max-a)
(let ((result (min min-a min-b))
(mask (lsbmask (max min-a min-b))))
(setf (value-max value) (logandc2 result mask))))
;}}}
(t
(compiler-bug "Logic error"))))
;}}}
;{{{b includes -1, a does not
((not (or (> min-b -1) (< max-b -1)))
(cond
;{{{a > -1
((> min-a -1)
(setf (value-max value) (min max-a max-b))
(let ((result min-a) (mask (lsbmask min-b)))
(setf (value-min value) (logandc2 result mask))))
;}}}
;{{{a < -1
((< max-a -1)
(setf (value-max value) max-b)
(let ((result (min min-a min-b))
(mask (lsbmask (max min-a min-b))))
(setf (value-max value) (logandc2 result mask))))
;}}}
(t
(compiler-bug "Logic error"))))
;}}}
(t
(compiler-bug "Cannot determine bitwise and interval"))))))))))
;}}}
;}}}
;{{{(:expr-xor :expr-xor-assign)
((:expr-xor :expr-xor-assign)
(format *debug-io* "~&Doing evaluate xor")
(let (all-bits)
(if (not (member (base-type-category info) '(sint uint)))
(compiler-bug "oops"))
(case (base-type-category info)
(sint
(setf all-bits -1))
(uint
(setf all-bits (1- (base-type-limit info)))))
)
(format *debug-io* "~&Done evaluate xor~&fg~&")
)
;}}}
(t
(setf value nil)))
(if value
(setf value nil))
value))
;}}}
(defun bang()
(setf *base-types* (make-hash-table :test #'eq))
(add-base-type 'sint)
(add-base-type 'uint)
(evaluate
(make-ae-node :attrib :expr-xor :type-node (make-type-node :attrib :base :of 'uint))
(make-eval-return) (make-eval-return)))
***end bad program
any help would be appreciated.
nathan
--
Nathan Sidwell Holder of the Xmris home page
Chameleon Architecture Group at SGS-Thomson, formerly Inmos
http://www.pact.srf.ac.uk/~nathan/ Tel 0117 9707182
nathan@pact.srf.ac.uk or nathan@inmos.co.uk or nathan@bristol.st.com