[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: |
16 May 2007 12:01:57 -0400 |
|
User-agent: |
Gnus/5.09 (Gnus v5.9.0) Emacs/21.2 |
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