gcl-devel
[Top][All Lists]
Advanced

[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: 02 May 2007 17:17:25 -0400
User-agent: Gnus/5.09 (Gnus v5.9.0) Emacs/21.2

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




reply via email to

[Prev in Thread] Current Thread [Next in Thread]