[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Gcl-devel] Re: GCL compiler bug: load-time-value and macroexpansion
|
From: |
Camm Maguire |
|
Subject: |
[Gcl-devel] Re: GCL compiler bug: load-time-value and macroexpansion |
|
Date: |
07 May 2007 16:09:14 -0400 |
|
User-agent: |
Gnus/5.09 (Gnus v5.9.0) Emacs/21.4 |
Greetings, and thanks!
Matt Kaufmann <address@hidden> writes:
> Hi, Camm --
>
> Regarding:
>
> >> it could save me a bit of time.
>
> If it would help you out and it's just a matter of my compiling a lisp
> file into an ACL2 image (like I did before), then I'd be happy to try
> it out.
>
OK here is one to try (just small patches to 3 functions in 2.6.7):
=============================================================================
nc1.l
=============================================================================
(in-package 'compiler)
(defun compile (name &optional def &aux tem gaz (*default-pathname-defaults*
#"."))
(cond ((not(symbolp name)) (error "Must be a name"))
((and (consp def)
(member (car def) '(lambda )))
(or name (setf name 'cmp-anon))
(setf (symbol-function name)
def)
(compile name))
(def (error "def not a lambda expression"))
((setq tem (macro-function name))
(setf (symbol-function 'cmp-anon) tem)
(compile 'cmp-anon)
(setf (macro-function name) (macro-function name))
;; FIXME -- support warnings-p and failures-p. CM 20041119
(values name nil nil))
((and (setq tem (symbol-function name))
(consp tem))
(let ((na (if (symbol-package name) name 'cmp-anon)))
(unless (and (fboundp 'si::init-cmp-anon) (or (si::init-cmp-anon)
(fmakunbound 'si::init-cmp-anon)))
(with-open-file
(st (setq gaz (gazonk-name)) :direction :output))
(let* ((*compiler-compile* `(defun ,na ,@ (ecase (car tem)
(lambda (cdr tem))
(lambda-block (cddr
tem)))))
(fi (compile-file gaz)))
(load fi)
(delete-file fi))
(unless *keep-gaz* (delete-file gaz)))
(or (eq na name) (setf (symbol-function name) (symbol-function na)))
;; FIXME -- support warnings-p and failures-p. CM 20041119
(values (symbol-function name) nil nil)
))
(t (error "can't compile ~a" name))))
(defun compile-file1 (input-pathname
&key (output-file input-pathname)
(o-file t)
(c-file *default-c-file*)
(h-file *default-h-file*)
(data-file *default-data-file*)
(c-debug nil)
#+aosvs (ob-file nil)
(system-p *default-system-p*)
(print nil)
(load nil)
&aux (*standard-output* *standard-output*)
(*error-output* *error-output*)
(*compiler-in-use* *compiler-in-use*)
(*c-debug* c-debug)
(*compile-print* (or print *compile-print*))
(*package* *package*)
(*DEFAULT-PATHNAME-DEFAULTS* #"")
(*data* (list (make-array 50 :fill-pointer 0
:adjustable t
)
nil ;inits
nil
))
*init-name*
(*fasd-data* *fasd-data*)
(*error-count* 0))
(declare (special *c-debug* *init-name* system-p))
(cond (*compiler-in-use*
(format t "~&The compiler was called recursively.~%~
Cannot compile ~a.~%"
(namestring (merge-pathnames input-pathname #".lsp")))
(setq *error-p* t)
(return-from compile-file1 (values)))
(t (setq *error-p* nil)
(setq *compiler-in-use* t)))
(unless (probe-file (merge-pathnames input-pathname #".lsp"))
(format t "~&The source file ~a is not found.~%"
(namestring (merge-pathnames input-pathname #".lsp")))
(setq *error-p* t)
(return-from compile-file1 (values)))
(when *compile-verbose*
(format t "~&Compiling ~a.~%"
(namestring (merge-pathnames input-pathname #".lsp"))))
(and *record-call-info* (clear-call-table))
(with-open-file
(*compiler-input* (merge-pathnames input-pathname #".lsp"))
(cond ((numberp *split-files*)
(if (< (file-length *compiler-input*) *split-files*)
(setq *split-files* nil)
;;*split-files* = ( section-length split-file-names
next-section-start-file-position
;; package-ops)
(setq *split-files* (list *split-files* nil 0 nil)))))
(cond ((consp *split-files*)
(file-position *compiler-input* (third *split-files*))
(setq output-file
(make-pathname :directory (pathname-directory output-file)
:name (format nil "~a~a"
(length (second *split-files*))
(pathname-name (pathname
output-file)))
:type "o"))
(push (pathname-name output-file) (second *split-files*))
))
(let* ((eof (cons nil nil))
(dir (or (and (not (null output-file))
(pathname-directory output-file))
(pathname-directory input-pathname)))
(name (or (and (not (null output-file))
(pathname-name output-file))
(pathname-name input-pathname)))
(device (or (and (not (null output-file))
(pathname-device output-file))
(pathname-device input-pathname)))
(o-pathname (get-output-pathname o-file "o" name dir device))
(c-pathname (get-output-pathname c-file "c" name dir device))
(h-pathname (get-output-pathname h-file "h" name dir device))
(data-pathname (get-output-pathname data-file "data" name dir device))
; (i-pathname (get-output-pathname data-file "i" name dir))
#+aosvs (ob-pathname (get-output-pathname ob-file "ob" name dir
device))
)
(declare (special dir name ))
(init-env)
(and (boundp 'si::*gcl-version*)
(not system-p)
(add-init `(si::warn-version ,si::*gcl-major-version*
,si::*gcl-minor-version*
,si::*gcl-extra-version*)))
(when (probe-file "./gcl_cmpinit.lsp")
(load "./gcl_cmpinit.lsp"
:verbose *compile-verbose*))
(with-open-file (*compiler-output-data*
data-pathname
:direction :output)
(progn
(setq *fasd-data*
(cond ((if system-p (eq *fasd-data* :system-p)
*fasd-data*)
(list
(si::open-fasd *compiler-output-data* :output nil nil)
;(si::open-fasd *compiler-output-i* :output nil nil)
))))
(wt-data-begin)
(if *compiler-compile*
(t1expr *compiler-compile*)
(let* ((rtb *readtable*)
(prev (and (eq (get-macro-character #\# rtb)
(get-macro-character
#\# (si:standard-readtable)))
(get-dispatch-macro-character #\# #\, rtb))))
(if (and prev (eq prev (get-dispatch-macro-character
#\# #\, (si:standard-readtable))))
(set-dispatch-macro-character #\# #\,
'si:sharp-comma-reader-for-compiler
rtb)
(setq prev nil))
;; t1expr the package ops again..
(if (consp *split-files*)
(dolist (v (fourth *split-files*)) (t1expr v)))
(unwind-protect
(do ((form (read *compiler-input* nil eof)
(read *compiler-input* nil eof))
(load-flag (or (eq :defaults *eval-when-defaults*)
(member 'load *eval-when-defaults*))))
(nil)
(cond
((eq form eof))
(load-flag (t1expr form))
((maybe-eval nil form)))
(cond
((and *split-files* (check-end form eof))
(setf (fourth *split-files*) (reverse (third *data*)))
(return nil))
((eq form eof) (return nil)))
)
(when prev (set-dispatch-macro-character #\# #\, prev rtb))))))
(setq *init-name* (init-name input-pathname system-p))
; (let ((x (merge-pathnames #".o" o-pathname)))
; (with-open-file (s x :if-does-not-exist :create)
; (setq *init-name* (init-name x system-p)))
; (delete-file x))
(when (zerop *error-count*)
(when *compile-verbose* (format t "~&End of Pass 1. ~%"))
(compiler-pass2 c-pathname h-pathname system-p ))
(wt-data-end)
) ;;; *compiler-output-data* closed.
(init-env)
(if (zerop *error-count*)
#+aosvs
(progn
(when *compile-verbose* (format t "~&End of Pass 2. ~%"))
(when data-file
(with-open-file (in fasl-pathname)
(with-open-file (out data-pathname :direction :output)
(si:copy-stream in out))))
(cond ((or fasl-file ob-file)
(compiler-cc c-pathname ob-pathname)
(cond ((probe-file ob-pathname)
(when fasl-file
(compiler-build ob-pathname fasl-pathname)
(when load (load fasl-pathname)))
(unless ob-file (delete-file ob-pathname))
(when *compile-verbose*
(print-compiler-info)
(format t "~&Finished compiling ~a.~%"
(namestring output-file))
))
(t (format t "~&Your C compiler failed to compile the
intermediate file.~%")
(setq *error-p* t))))
(*compile-verbose*
(print-compiler-info)
(format t "~&Finished compiling ~a.~%" (namestring output-file)
)))
(unless c-file (delete-file c-pathname))
(unless h-file (delete-file h-pathname))
(unless fasl-file (delete-file fasl-pathname)))
(progn
(when *compile-verbose* (format t "~&End of Pass 2. ~%"))
(cond (*record-call-info*
(dump-fn-data (get-output-pathname output-file "fn" name dir
device))))
(cond (o-file
(compiler-cc c-pathname o-pathname )
(cond ((probe-file o-pathname)
(compiler-build o-pathname data-pathname)
(when load (load o-pathname))
(when *compile-verbose*
(print-compiler-info)
(format t "~&Finished compiling ~a.~%"
(namestring output-file)
)))
(t
(format t "~&Your C compiler failed to compile the
intermediate file.~%")
(setq *error-p* t))))
(*compile-verbose*
(print-compiler-info)
(format t "~&Finished compiling ~a.~%" (namestring
output-file)
)))
(unless c-file (delete-file c-pathname))
(unless h-file (delete-file h-pathname))
(unless (or data-file #+ld-not-accept-data t system-p) (delete-file
data-pathname))
o-pathname)
(progn
(when (probe-file c-pathname) (delete-file c-pathname))
(when (probe-file h-pathname) (delete-file h-pathname))
(when (probe-file data-pathname) (delete-file data-pathname))
(format t "~&No FASL generated.~%")
(setq *error-p* t)
(values)
)))))
; ((and *compiler-compile* (not *keep-gaz*))
; (setf (info-type info) (object-type val))
; (list 'LOCATION info (list 'VV (add-object (cons 'si::|#,| `(si::nani
,(si::address val)))))))
(defun c1constant-value (val always-p)
(cond
((eq val nil) (c1nil))
((eq val t) (c1t))
((si:fixnump val)
(list 'LOCATION (make-info :type 'fixnum)
(list 'FIXNUM-VALUE (and (>= (abs val) 1024)(add-object val))
val)))
((characterp val)
(list 'LOCATION (make-info :type 'character)
(list 'CHARACTER-VALUE (add-object val) (char-code val))))
((typep val 'long-float)
;; We can't read in long-floats which are too big:
(let* (sc (vv (cond ((> (abs val) (/ most-positive-long-float 2))
(add-object `(si::|#,| * ,(/ val
most-positive-long-float) most-positive-long-float)))
((< (abs val) (* least-positive-long-float 1.0d20))
(add-object `(si::|#,| * ,(/ val
least-positive-long-float) least-positive-long-float)))
((setq sc t) (add-object val)))))
`(location ,(make-info :type 'long-float)
,(if sc (list 'LONG-FLOAT-VALUE vv val) (list 'vv vv)))))
((typep val 'short-float)
(list 'LOCATION (make-info :type 'short-float)
(list 'SHORT-FLOAT-VALUE (add-object val) val)))
((and *compiler-compile* (not *keep-gaz*))
(list 'LOCATION (make-info :type (object-type val))
(list 'VV (add-object (cons 'si::|#,| `(si::nani ,(si::address
val)))))))
(always-p
(list 'LOCATION (make-info :type (object-type val))
(list 'VV (add-object val))))
(t nil)))
=============================================================================
> -- Matt
> Sender: address@hidden
> Cc: address@hidden
> From: Camm Maguire <address@hidden>
> Date: 03 May 2007 16:12:35 -0400
> X-SpamAssassin-Status: No, hits=1.3 required=5.0
> X-UTCS-Spam-Status: No, hits=-250 required=200
>
> Greetings!
>
> Matt Kaufmann <address@hidden> writes:
>
> > Hi, Camm --
> >
> > I tried the fix, and it worked, though as you suggested, it may need
> > tuning for speed. Result is the third line of numbers below:
> >
> > ; Original run:
> > 12990.367u 274.629s 3:46:08.34 97.7% 0+0k 0+0io 5pf+0w
> >
> > ; One-line fix:
> > 12987.607u 275.321s 3:45:30.28 98.0% 0+0k 0+0io 0pf+0w
> >
> > ; The latest:
> > 13587.777u 296.454s 4:03:23.40 95.0% 0+0k 0+0io 17pf+0w
> >
> > As for ACL2, I plan just to use the following (aforementioned)
> > "One-line fix" (let me know if you object), since it's simplest
> > (perhaps safest, certainly easiest for me to distribute).
> >
> > #+(and gcl (not ansi-cl))
> > (defun compiler::wrap-literals (x) x)
> >
> > If you want to experiment with tuning your latest fix, you could
> > presumably built ACL2 3.2 with (load
> > "/projects/acl2/devel/compiler-patch.o") in the current directory.
> > (By the way, I compiled compiler-patch.lsp in a fresh GCL 2.6.7 with
> > default optimization; I wonder if optimizing could be part of the
> > "tuning for speed".)
> >
>
> OK, thanks to your prompting, I've figured out a way to avoid
> wrap-literals entirely (and all that new code), and to avoid the
> prin1/read in pass1 when invoked from within compile, which might
> speed things up a bit from the fastest you have above. It could be
> argued that this belongs in 2.6 as the current wrap-literals is
> buggy. Your solution above is of course fine, but in case you'd like
> to try this last idea, please let me know -- it could save me a bit of
> time.
>
> Take care,
>
> > -- Matt
> > Sender: address@hidden
> > Cc: address@hidden
> > From: Camm Maguire <address@hidden>
> > Date: 02 May 2007 17:17:25 -0400
> > X-SpamAssassin-Status: No, hits=-1.3 required=5.0
> > X-UTCS-Spam-Status: No, hits=-281 required=200
> >
> > Greetings, and thanks so much! Obviously a bone-headed first attempt
> > -- my apologies.
> >
> > This should work or be close, but might need tuning for speed. If you
> > could test, I'd be most grateful. Just compile and load the
> > following:
> >
> >
> =============================================================================
> > (in-package 'compiler)
> >
> > (defvar *mlts* nil)
> >
> > (defmacro ndbctxt (&rest body)
> > `(let ((*compiler-check-args* *compiler-check-args*)
> > (*safe-compile* *safe-compile*)
> > (*compiler-push-events* *compiler-push-events*)
> > (*notinline* *notinline*)
> > (*space* *space*))
> > ,@body))
> >
> > (defun portable-source (form &optional cdr)
> > (cond ((atom form) form)
> > (cdr (cons (portable-source (car form)) (portable-source (cdr form)
> t)))
> > ((case (car form)
> > ((let let* lambda)
> > `(,(car form)
> > ,(mapcar (lambda (x) (if (atom x) x `(,(car x)
> ,@(portable-source (cdr x) t)))) (cadr form))
> > ,@(let ((r (remove-if-not 'si::specialp (mapcar (lambda
> (x) (if (atom x) x (car x))) (cadr form)))))
> > (when r `((declare (special ,@r)))))
> > ,@(ndbctxt (portable-source (cddr form) t))))
> > ((quote function) form)
> > (declare
> > (let ((opts (mapcan (lambda (x) (if (eq (car x) 'optimize)
> (cdr x) (list x)))
> > (remove-if-not
> > (lambda (x) (and (consp x) (member (car
> x) '(optimize notinline))))
> > (cdr form)))))
> > (when opts (local-compile-decls opts)))
> > form)
> > (the `(,(car form) ,(cadr form) ,@(portable-source (cddr
> form) t)))
> > ((and or) `(,(car form) ,@(portable-source (cdr form) t)))
> > (check-type form)
> > ((flet labels macrolet)
> > `(,(car form)
> > ,(mapcar (lambda (x) `(,(car x) ,@(cdr (portable-source
> `(lambda ,@(cdr x)))))) (cadr form))
> > ,@(let ((*mlts* *mlts*))
> > (when (eq (car form) 'macrolet)
> > (dolist (l (cadr form)) (push (car l) *mlts*)))
> > (ndbctxt (portable-source (cddr form) t)))))
> > (multiple-value-setq (portable-source
> (multiple-value-setq-expander (cdr form))))
> > (multiple-value-bind `(,(car form) ,(cadr form)
> ,(portable-source (caddr form))
> > ,@(let ((r (remove-if-not
> 'si::specialp (cadr form))))
> > (when r `((declare (special
> ,@r)))))
> > ,@(ndbctxt (portable-source (cdddr
> form) t))))
> > ((case ccase ecase) `(,(car form) ,(portable-source (cadr
> form))
> > ,@(mapcar (lambda (x) `(,(car x)
> ,@(portable-source (cdr x) t))) (cddr form))))))
> > ((let* ((fd (and (symbolp (car form)) (not (member (car form)
> *mlts*))
> > (or (unless (member (car form) *notinline*) (get
> (car form) 'si::compiler-macro-prop))
> > (macro-function (car form)))))
> > (nf (if fd (cmp-expand-macro fd (car form) (cdr form))
> form)))
> > (portable-source nf (equal form nf))))))
> >
> > (defun this-safety-level nil
> > (cond (*compiler-push-events* 3)
> > (*safe-compile* 2)
> > (*compiler-check-args* 1)
> > (0)))
> >
> > (defun local-compile-decls (decls)
> > (dolist**
> > (decl decls)
> > (unless (consp decl) (setq decl (list decl 3)))
> > (case (car decl)
> > (safety
> > (let ((level (cadr decl)))
> > (declare (fixnum level))
> > (setq *compiler-check-args* (>= level 1)
> > *safe-compile* (>= level 2)
> > *compiler-push-events* (>= level 3))))
> > (space (setq *space* (cadr decl)))
> > (notinline (push (cadr decl) *notinline*))
> > (speed) ;;FIXME
> > (compilation-speed) ;;FIXME
> > (inline
> > (setq *notinline* (remove (cadr decl) *notinline*)))
> > (otherwise (baboon)))))
> >
> > (defun pd (fname ll args)
> > (let (decls ctps doc)
> > (when (and (consp args) (stringp (car args)) (cdr args) (not
> doc)) (push (pop args) doc))
> > (do nil ((or (not args) (not (consp (car args))) (not (eq (caar
> args) 'declare))))
> > (push (pop args) decls))
> > (do nil ((or (not args) (not (consp (car args))) (not (eq (caar
> args) 'check-type))))
> > (push (pop args) ctps))
> > (let* ((nal (do (r (y ll)) ((or (not y) (eq (car y) '&aux))
> (nreverse r)) (push (pop y) r)))
> > (al (cdr (member '&aux ll)))
> > (ax (mapcar (lambda (x) (if (atom x) x (car x))) al))
> > (dd (aux-decls ax decls))
> > (cc (aux-ctps ax ctps))
> > (sd `(declare (optimize (safety ,(this-safety-level))))))
> > (portable-source `(lambda ,nal
> > ,@doc
> > ,@(let ((r (nreverse (cadr dd))))
> > (unless (and (consp r) (consp (car r)) (eq
> (caar r) 'declare)
> > (consp (cadar r)) (eq (caadar r)
> 'optimize)
> > (consp (cadr (cadar r))) (eq
> (caadr (cadar r)) 'safety))
> > (push sd r))
> > (nconc r (cadr cc)))
> > ,@(let* ((r args)
> > (r (if (or al (car dd)) `((let* ,al
> ,@(append (car dd) (car cc)) ,@r)) r))
> > (r (if (and (consp (car r)) (eq (caar r)
> 'block) (eq (cadar r) fname))
> > r `((block ,fname ,@r)))))
> > r))))))
> >
> > (defun aux-decls (auxs decls)
> > (let (ad dd)
> > (dolist (l decls)
> > (let* ((b (cadr l))
> > (b (if (eq (car b) 'type) (cdr b) b)))
> > (cond ((eq (car b) 'optimize) (push l dd))
> > ((eq (car b) 'class)
> > (unless (<= (length b) 3)
> > (cmperr "Unknown class declaration: ~s" b))
> > (if (member (cadr b) auxs) (push l ad) (push l dd)))
> > ((let ((tt (intersection (cdr b) auxs)))
> > (cond ((not tt) (push l dd))
> > ((let ((z (if (eq b (cadr l)) (list (caadr l)) (list
> (caadr l) (cadadr l)))))
> > (push `(declare (,@z ,@tt)) ad)
> > (let ((q (set-difference (cdr b) auxs)))
> > (when q
> > (push `(declare (,@z ,@q)) dd)))))))))))
> > (list (nreverse ad) (nreverse dd))))
> >
> > (defun aux-ctps (auxs ctps)
> > (let (ad dd)
> > (dolist (l ctps) (if (member (cadr l) auxs) (push l ad) (push l
> dd)))
> > (list (nreverse ad) (nreverse dd))))
> >
> > (defun ppd (form)
> > (ecase (car form)
> > (lambda (pd 'cmp-anon (cadr form) (cddr form)))
> > (lambda-block (pd (cadr form) (caddr form) (cdddr form)))
> > (lambda-closure (pd 'cmp-anon (caddr (cddr form)) (cdddr (cddr
> form))))
> > (lambda-block-closure (pd (cadr (cdddr form)) (caddr (cdddr form))
> (cdddr (cdddr form))))))
> >
> >
> > (defun wrap-literals (form &optional n)
> > (if (not n)
> > (wrap-literals (ppd form) t)
> > (cond ((and (consp form) (eq (car form) 'quote))
> > (let ((x (cadr form)))
> > (if (and (symbolp x)
> > (eq :external (cadr (multiple-value-list (find-symbol
> (symbol-name x) 'lisp)))))
> > form
> > `(load-time-value (si::nani ,(si::address x))))))
> > ((consp form)
> > (cons (wrap-literals (car form) t) (wrap-literals (cdr form) t)))
> > ((or (symbolp form) (numberp form) (characterp form))
> > form)
> > (`(load-time-value (si::nani ,(si::address form)))))))
> >
> =============================================================================
> >
> > Take care,
> >
> > Matt Kaufmann <address@hidden> writes:
> >
> > > Hi, Camm --
> > >
> > > I needed to add this:
> > >
> > > compiler::(defvar *tmp-pack* nil)
> > >
> > > Actually I got through much of the regression suite before hitting
> an
> > > error when I had instead just declared *tmp-pack* special in the
> > > definition of wrap-literals. I think that I only hit an error when
> > > the compiler was called using compile rather than compile-file.
> > >
> > > But then the regression failed. I distilled the following small
> > > example to illustrate the problem. I haven't investigated in depth
> > > but I suspect you'll figure it out quickly by tracing
> > > compiler::wrap-literals. It appears that a variable binding is
> being
> > > treated as a macro call.
> > >
> > > sundance:~> gcl-2.6.7
> > > GCL (GNU Common Lisp) 2.6.7 CLtL1 Sep 15 2005 12:36:56
> > > Source License: LGPL(gcl,gmp), GPL(unexec,bfd)
> > > Binary License: GPL due to GPL'ed components: (BFD UNEXEC)
> > > Modifications of this banner must retain notice of a compatible
> license
> > > Dedicated to the memory of W. Schelter
> > >
> > > Use (help) to get some basic information on how to use GCL.
> > >
> > > >compiler::(defvar *tmp-pack* nil)
> > >
> > > COMPILER::*TMP-PACK*
> > >
> > > >compiler::(defun wrap-literals (form &aux fd)
> > > (cond ((and (consp form) (eq (car form) 'quote))
> > > (let ((x (cadr form)))
> > > (if (and (symbolp x)
> > > (eq :external (cadr (multiple-value-list
> (find-symbol (symbol-name x) 'lisp)))))
> > > form
> > > `(load-time-value (si::nani ,(si::address x))))))
> > > ((and (consp form) (symbolp (car form)) (not (eq 'lambda (car
> form))) (setq fd (macro-function (car form))))
> > > (wrap-literals (cmp-expand-macro fd (car form) (cdr form))))
> > > ((consp form)
> > > (cons (wrap-literals (car form)) (wrap-literals (cdr form))))
> > > ((symbolp form)
> > > (unless (symbol-package form)
> > > (unless *tmp-pack*
> > > (setq *tmp-pack* (make-package (symbol-name (gensym)))))
> > > (import form *tmp-pack*))
> > > form)
> > > ((or (rationalp form) (characterp form))
> > > form)
> > > (`(load-time-value (si::nani ,(si::address form))))))
> > >
> > > COMPILER::WRAP-LITERALS
> > >
> > > >(defmacro my-cons2 (name)
> > > (list 'cons name name))
> > >
> > > MY-CONS2
> > >
> > > >(defun foo (x)
> > > (let ((my-cons2 (cdr x)))
> > > (equal my-cons2 nil)))
> > >
> > > FOO
> > >
> > > >(compile 'foo)
> > >
> > > Compiling gazonk8.lsp.
> > > ; (DEFUN FOO ...) is being compiled.
> > > ;;; The variable binding (CONS (CDR X) (CDR X)) is illegal.;;
> Warning: The variable X is not used.
> > > No FASL generated.
> > >
> > > Error: Cannot open the file NIL..
> > > Fast links are on: do (si::use-fast-links nil) for debugging
> > > Error signalled by LET.
> > > Broken at LOAD. Type :H for Help.
> > > >>
> > >
> > > -- Matt
> > > Sender: address@hidden
> > > Cc: address@hidden
> > > From: Camm Maguire <address@hidden>
> > > Date: 01 May 2007 14:07:41 -0400
> > > X-SpamAssassin-Status: No, hits=-2.5 required=5.0
> > > X-UTCS-Spam-Status: No, hits=-310 required=200
> > >
> > > Greetings! I'm not very happy about the (not (eq 'lambda (car
> > > form))), but it might be worth testing this:
> > >
> > > (defun wrap-literals (form &aux fd)
> > > (cond ((and (consp form) (eq (car form) 'quote))
> > > (let ((x (cadr form)))
> > > (if (and (symbolp x)
> > > (eq :external (cadr (multiple-value-list
> (find-symbol (symbol-name x) 'lisp)))))
> > > form
> > > `(load-time-value (si::nani ,(si::address x))))))
> > > ((and (consp form) (symbolp (car form)) (not (eq 'lambda
> (car form))) (setq fd (macro-function (car form))))
> > > (wrap-literals (cmp-expand-macro fd (car form) (cdr form))))
> > > ((consp form)
> > > (cons (wrap-literals (car form)) (wrap-literals (cdr
> form))))
> > > ((symbolp form)
> > > (unless (symbol-package form)
> > > (unless *tmp-pack*
> > > (setq *tmp-pack* (make-package (symbol-name (gensym)))))
> > > (import form *tmp-pack*))
> > > form)
> > > ((or (rationalp form) (characterp form))
> > > form)
> > > (`(load-time-value (si::nani ,(si::address form))))))
> > >
> > > Take care,
> > >
> > >
> > > Matt Kaufmann <address@hidden> writes:
> > >
> > > > By the way, the times for the ACL2 regression suite are
> virtually
> > > > identical before and after the following change (added to a
> compiled
> > > > ACL2 source file):
> > > >
> > > > #+(and gcl (not ansi-cl)) (defun compiler::wrap-literals (x) x)
> > > >
> > > > ; Before above addition:
> > > > 12990.367u 274.629s 3:46:08.34 97.7% 0+0k 0+0io 5pf+0w
> > > > ; After above addition:
> > > > 12987.607u 275.321s 3:45:30.28 98.0% 0+0k 0+0io 0pf+0w
> > > >
> > > > I've saved a copy of the development sources that I used, so
> that I
> > > > can test an alternate wrap-literals that you send me.
> > > >
> > > > -- Matt
> > > > Sender: address@hidden
> > > > Cc: address@hidden
> > > > From: Camm Maguire <address@hidden>
> > > > Date: 30 Apr 2007 13:35:32 -0400
> > > > X-SpamAssassin-Status: No, hits=-2.5 required=5.0
> > > > X-UTCS-Spam-Status: No, hits=-310 required=200
> > > >
> > > > Greetings! This should work. Would you be willing to test
> an
> > > > alternate wrap-literals if I get one together in the
> near-future?
> > > >
> > > > Take care,
> > > >
> > > > Matt Kaufmann <address@hidden> writes:
> > > >
> > > > > Thank you, Camm. Unfortunately, after (setq
> compiler::*keep-gaz* t),
> > > > > then all the gazonk*.lsp files are left around. So I'm
> wondering if
> > > > > it would safe to do the following instead:
> > > > >
> > > > > #+(and gcl (not ansi-cl)) (defun compiler::wrap-literals
> (x) x)
> > > > > #+(and gcl (not ansi-cl)) (compile
> 'compiler::wrap-literals)
> > > > >
> > > > > A small test suggests that this may work, though I have
> no idea really
> > > > > what I'm doing. Should I expect the above solution to be
> OK?
> > > > >
> > > > > Thanks --
> > > > > -- Matt
> > > > > Sender: address@hidden
> > > > > Cc: address@hidden
> > > > > From: Camm Maguire <address@hidden>
> > > > > Date: 30 Apr 2007 12:16:06 -0400
> > > > > X-SpamAssassin-Status: No, hits=-2.5 required=5.0
> > > > > X-UTCS-Spam-Status: No, hits=-310 required=200
> > > > >
> > > > > Greetings, and thanks so much for this report!
> > > > >
> > > > > The issue in brief stems from ansification --
> compile'ed forms must
> > > > > refer to the exact object literally referred to in the
> form, not a
> > > > > copy, so the traditional GCL print and compile-file
> won't work. The
> > > > > function is compiler::wrap-literals, which you can
> trace if
> > > > > interested. There is obviously a bug here -- most
> likely
> > > > > wrap-literals should do some selective
> macro-expansion, perhaps along
> > > > > the lines of compiler::portable-source in 2.7.0. I
> will see if I can
> > > > > come up with a solution which also retains our current
> (2.7.0)
> > > > > compatibility with the ansi tests for compile. If you
> have any
> > > > > suggestions, they are of course most appreciated. The
> tests in
> > > > > question as run thus:
> > > > >
> > > > > cd ansi-tests
> > > > > ../unixport/saved_ansi_gcl
> > > > > >(load "gclload1")
> > > > > >(load "compile")
> > > > > >(load "compile-file")
> > > > > >(rt:do-tests)
> > > > >
> > > > > There is an immediate work-around. Set the variable
> > > > > compiler::*keep-gaz* to t -- this avoids wrap-literals
> and behaves as
> > > > > the traditional compile via print/compile-file did.
> The idea is that
> > > > > there are certain packages in the ansi build, notably
> pcl, which
> > > > > compile functions which need to be linked later in
> gazonk files at the
> > > > > raw build stage. Even though pcl uses compile here,
> literal object
> > > > > reference is impossible as the running image at
> compile time is gone.
> > > > > So qualitatively if one needs to keep the gazonk files
> around, they
> > > > > better not refer to objects only available in the
> compiling image.
> > > > >
> > > > > This exception in all likelihood should not be there
> eventually, but I
> > > > > can't at the moment envision a bridge between ansi
> compile and
> > > > > traditional gcl compile without one.
> > > > >
> > > > > Comments/suggestions as always most welcome.
> > > > >
> > > > > Take care,
> > > > >
> > > > > Matt Kaufmann <address@hidden> writes:
> > > > >
> > > > > > Hello --
> > > > > >
> > > > > > It appears that the GCL compiler (at least: version
> 2.6.7 CLtL1, and
> > > > > > also version 2.7.0 ANSI as of about 11/27/06) is
> laying down calls of
> > > > > > lisp::load-time-value that are interfering with
> macro expansion.
> > > > > > Below is an example exhibiting the problem.
> > > > > >
> > > > > > Is there any simple workaround, such as (setq
> *some-compiler-switch*
> > > > > > nil)? By the way, the actual (much bigger) failure
> I had, from which
> > > > > > the example below is extracted, was only an explicit
> error when
> > > > > > calling COMPILE as shown below. When I put the
> function into a file,
> > > > > > I didn't see any problem with COMPILE-FILE, but I
> found bizarre and
> > > > > > somewhat nondeterministic behavior that went away
> when I avoided
> > > > > > compiling that function by loading the .lisp file
> instead.
> > > > > >
> > > > > > .....
> > > > > >
> > > > > > >(defmacro my-mac (b)
> > > > > > (list 'list
> > > > > > (if (and (consp b)
> > > > > > (stringp (car b)))
> > > > > > (list 'quote b)
> > > > > > b)))
> > > > > >
> > > > > > MY-MAC
> > > > > >
> > > > > > >(defun foo ()
> > > > > > (my-mac ("Guards")))
> > > > > >
> > > > > > FOO
> > > > > >
> > > > > > >(foo)
> > > > > >
> > > > > > (("Guards"))
> > > > > >
> > > > > > >(compile 'foo)
> > > > > >
> > > > > > Compiling gazonk4.lsp.
> > > > > > ; (DEFUN FOO ...) is being compiled.
> > > > > > ;;; The function (LOAD-TIME-VALUE (SYSTEM:NANI
> 139732192)) is illegal.
> > > > > > No FASL generated.
> > > > > >
> > > > > > Error: Cannot open the file NIL..
> > > > > > Fast links are on: do (si::use-fast-links nil) for
> debugging
> > > > > > Error signalled by LET.
> > > > > > Broken at LOAD. Type :H for Help.
> > > > > > >>(quit)
> > > > > > sundance:~> cat gazonk4.lsp
> > > > > >
> > > > > > (lisp::defun user::foo lisp::nil (user::my-mac
> ((lisp::load-time-value (system::nani 139732192)))))sundance:~>
> > > > > >
> > > > > > Thanks --
> > > > > > -- Matt
> > > > > >
> > > > > >
> > > > > >
> > > > >
> > > > > --
> > > > > Camm Maguire
> address@hidden
> > > > >
> ==========================================================================
> > > > > "The earth is but one country, and mankind its
> citizens." -- Baha'u'llah
> > > > >
> > > > >
> > > > >
> > > >
> > > > --
> > > > Camm Maguire
> address@hidden
> > > >
> ==========================================================================
> > > > "The earth is but one country, and mankind its citizens."
> -- Baha'u'llah
> > > >
> > > >
> > > >
> > >
> > > --
> > > Camm Maguire
> address@hidden
> > >
> ==========================================================================
> > > "The earth is but one country, and mankind its citizens." --
> Baha'u'llah
> > >
> > >
> > >
> >
> > --
> > Camm Maguire address@hidden
> >
> ==========================================================================
> > "The earth is but one country, and mankind its citizens." --
> Baha'u'llah
> >
> >
> >
>
> --
> Camm Maguire address@hidden
> ==========================================================================
> "The earth is but one country, and mankind its citizens." -- Baha'u'llah
>
>
>
--
Camm Maguire address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens." -- Baha'u'llah