[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: |
17 May 2007 09:26:03 -0400 |
|
User-agent: |
Gnus/5.09 (Gnus v5.9.0) Emacs/21.2 |
Greetings! Looks good.
Take care,
Matt Kaufmann <address@hidden> writes:
> Hi, Camm --
>
> Thanks. OK then, in order to get this patch just to apply to GCL
> 2.6.7 (and perhaps before), I've changed my one-liner patch to the
> following. Please let me know if you see a problem with it.
>
> #+(and gcl (not ansi-cl))
> (when (and (fboundp 'compiler::wrap-literals)
> (not (gcl-version-> 2 6 7)))
> (setf (symbol-function 'compiler::wrap-literals)
> (symbol-function 'identity)))
>
> ; where [this is old code so I'm pretty sure it's OK]:
>
> #+gcl
> (defun gcl-version-> (major minor extra &optional weak)
>
> ; When true, this guarantees that the current GCL version is greater than
> ; major.minor.extra (or if weak is non-nil, than greater than or equal to).
> ; The converse holds for versions of GCL past perhaps 2.0.
>
> (and (boundp 'si::*gcl-major-version*)
> (integerp si::*gcl-major-version*)
> (if (= si::*gcl-major-version* major)
> (and (boundp 'si::*gcl-minor-version*)
> (integerp si::*gcl-minor-version*)
> (if (= si::*gcl-minor-version* minor)
> (and (boundp 'si::*gcl-extra-version*)
> (integerp si::*gcl-extra-version*)
> (if weak
> (>= si::*gcl-extra-version* extra)
> (> si::*gcl-extra-version* extra)))
> (if weak
> (>= si::*gcl-minor-version* minor)
> (> si::*gcl-minor-version* minor))))
> (if weak
> (>= si::*gcl-major-version* major)
> (> si::*gcl-major-version* major)))))
>
> Thanks --
> -- Matt
> Sender: address@hidden
> Cc: address@hidden
> From: Camm Maguire <address@hidden>
> Date: 16 May 2007 12:01:57 -0400
> X-SpamAssassin-Status: Yes, hits=6.7 required=5.0
> X-UTCS-Spam-Status: No, hits=-120 required=200
>
> Greetings!
>
> Matt Kaufmann <address@hidden> writes:
>
> > Hi, Camm --
> >
> > Nice work!
> >
> > I tried your latest patch, nc1.l, by loading and compiling it in GCL
> > 2.6.7 and then loading the .o file as part of the ACL2 build process.
> > Then I ran my local regression (which includes a little more than the
> > distributed and workshop books), which passed. I got these results.
> >
> > Using only (defun compiler::wrap-literals (x) x):
> > 12987.607u 275.321s 3:45:30.28 98.0% 0+0k 0+0io 0pf+0w
> >
> > Using nc1.o:
> > 12874.456u 279.197s 3:46:40.46 96.7% 0+0k 0+0io 1pf+0w
> >
> > Speedup: almost 1%.
> > (/ (- (+ 12874.456 279.197) (+ 12987.607 275.321))
> > (+ 12987.607 275.321))
> > -0.008239130906840452
> >
> > Still, I'm tempted to distribute only the one-line patch with ACL2,
> > since otherwise it seems I'd need to automate the compiling of your
> > new compiler file as part of the ACL2 build process. Alternatively, I
> > could perhaps prefix each of your new three forms with compiler:: so
> > that they can go into existing ACL2 source file acl2-fns.lisp, or even
> > put in compiler::(progn <form1> <form2> <form3>). Thoughts?
> >
> > Either way, should I make loading of the (one-line or three-function)
> > patch conditional on being GCL Version 2.6.7, or would this be
> > suitable for any 2.6.* version?
> >
>
> I think your one-liner is good for <= 2.6.7. I've committed the 3-fn
> patch to 2.6.8pre, and it is already in cvs head (2.7.0).
>
> compile can likely be sped up a bit further by eliding all i/o before
> the c file is output.
>
> Take care,
>
> > Thanks --
> > -- Matt
> > Cc: address@hidden
> > From: Camm Maguire <address@hidden>
> > Date: 07 May 2007 16:09:14 -0400
> > X-SpamAssassin-Status: No, hits=1.3 required=5.0
> > X-UTCS-Spam-Status: No, hits=-240 required=200
> >
> > 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
> >
> >
> >
> >
>
> --
> 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