[Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-321-g14b9aa9

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=14b9aa95e61e2d593bd96ab0a7675ed72d55503c

The branch, wip-rtl-halloween has been updated
       via  14b9aa95e61e2d593bd96ab0a7675ed72d55503c (commit)
       via  b681671ede9cefcbfa9d59169030b013f5ddfc6a (commit)
      from  d258fcccee2d96dc3cf90cecf3f3ee9ebb25b9db (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 14b9aa95e61e2d593bd96ab0a7675ed72d55503c
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 1 18:23:51 2013 +0100

    Fix order of evaluation in elisp lexer
    
    * module/language/elisp/lexer.scm (lex): Use let*, to ensure that the
      port position is read before reading the next char.

commit b681671ede9cefcbfa9d59169030b013f5ddfc6a
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 1 18:22:58 2013 +0100

    Fix contification of non-recursive closures
    
    * module/language/cps/contification.scm (compute-contification): When
      eliding let-bound functions, also record the cont that declares the
      function.
      (apply-contification): Instead of reifying ($values ()) gotos instead
      of the elided function, inline the body that binds the function
      directly.  This ensures that the function gets contified in its own
      scope.

-----------------------------------------------------------------------

Summary of changes:
 module/language/cps/contification.scm |   33 ++++++++++++++++++---------------
 module/language/elisp/lexer.scm       |   30 +++++++++++++++---------------
 2 files changed, 33 insertions(+), 30 deletions(-)

diff --git a/module/language/cps/contification.scm 
b/module/language/cps/contification.scm
index 970432a..aa162e0 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -30,7 +30,7 @@
 
 (define-module (language cps contification)
   #:use-module (ice-9 match)
-  #:use-module ((srfi srfi-1) #:select (concatenate))
+  #:use-module ((srfi srfi-1) #:select (concatenate filter-map))
   #:use-module (srfi srfi-26)
   #:use-module (language cps)
   #:use-module (language cps dfg)
@@ -49,8 +49,8 @@
       (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
     (define (subst-return! old-tail new-tail)
       (set! cont-substs (acons old-tail new-tail cont-substs)))
-    (define (elide-function! k)
-      (set! fun-elisions (cons k fun-elisions)))
+    (define (elide-function! k cont)
+      (set! fun-elisions (acons k cont fun-elisions)))
     (define (splice-conts! scope conts)
       (hashq-set! cont-splices scope
                   (append conts (hashq-ref cont-splices scope '()))))
@@ -230,7 +230,7 @@
             (if (and=> (bound-symbol k)
                        (lambda (sym)
                          (contify-fun term-k sym self tail-k arity body)))
-                (elide-function! k)
+                (elide-function! k (lookup-cont k cont-table))
                 (visit-fun exp)))
            (_ #t)))))
 
@@ -276,10 +276,10 @@
            (($ $letrec names syms funs body)
             ($letrec names syms funs ,(lp body)))
            (($ $letk conts* body)
-            ($letk ,(append conts* (map visit-cont cont))
+            ($letk ,(append conts* (filter-map visit-cont cont))
               ,body))
            (body
-            ($letk ,(map visit-cont cont)
+            ($letk ,(filter-map visit-cont cont)
               ,body)))))))
   (define (visit-fun term)
     (rewrite-cps-exp term
@@ -287,9 +287,9 @@
        ($fun meta free ,(visit-cont body)))))
   (define (visit-cont cont)
     (rewrite-cps-cont cont
-      (($ $cont (and k (? (cut memq <> fun-elisions))) src
-          ($ $kargs (_) (_) body))
-       (k src ($kargs () () ,(visit-term body k))))
+      (($ $cont (? (cut assq <> fun-elisions)))
+       ;; This cont gets inlined in place of the $fun.
+       ,#f)
       (($ $cont sym src ($ $kargs names syms body))
        (sym src ($kargs names syms ,(visit-term body sym))))
       (($ $cont sym src ($ $kentry self tail clauses))
@@ -312,10 +312,10 @@
            (($ $letrec names syms funs body)
             ($letrec names syms funs ,(lp body)))
            (($ $letk conts* body)
-            ($letk ,(append conts* (map visit-cont conts))
+            ($letk ,(append conts* (filter-map visit-cont conts))
               ,body))
            (body
-            ($letk ,(map visit-cont conts)
+            ($letk ,(filter-map visit-cont conts)
               ,body)))))
       (($ $letrec names syms funs body)
        (rewrite-cps-term (filter (match-lambda
@@ -329,10 +329,13 @@
         term-k
         (match exp
           (($ $fun)
-           (if (memq k fun-elisions)
-               (build-cps-term
-                 ($continue k ($values ())))
-               (continue k (visit-fun exp))))
+           (cond
+            ((assq-ref fun-elisions k)
+             => (match-lambda
+                 (($ $kargs (_) (_) body)
+                  (visit-term body k))))
+            (else
+             (continue k (visit-fun exp)))))
           (($ $call proc args)
            (or (contify-call proc args)
                (continue k exp)))
diff --git a/module/language/elisp/lexer.scm b/module/language/elisp/lexer.scm
index 1933ff3..5a0e6b3 100644
--- a/module/language/elisp/lexer.scm
+++ b/module/language/elisp/lexer.scm
@@ -1,6 +1,6 @@
 ;;; Guile Emacs Lisp
 
-;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010, 2013 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -261,20 +261,20 @@
     (and=> (regexp-exec lexical-binding-regexp string)
            (lambda (match)
              (not (member (match:substring match 2) '("nil" "()"))))))
-  (let ((return (let ((file (if (file-port? port)
-                                (port-filename port)
-                                #f))
-                      (line (1+ (port-line port)))
-                      (column (1+ (port-column port))))
-                  (lambda (token value)
-                    (let ((obj (cons token value)))
-                      (set-source-property! obj 'filename file)
-                      (set-source-property! obj 'line line)
-                      (set-source-property! obj 'column column)
-                      obj))))
-        ;; Read afterwards so the source-properties are correct above
-        ;; and actually point to the very character to be read.
-        (c (read-char port)))
+  (let* ((return (let ((file (if (file-port? port)
+                                 (port-filename port)
+                                 #f))
+                       (line (1+ (port-line port)))
+                       (column (1+ (port-column port))))
+                   (lambda (token value)
+                     (let ((obj (cons token value)))
+                       (set-source-property! obj 'filename file)
+                       (set-source-property! obj 'line line)
+                       (set-source-property! obj 'column column)
+                       obj))))
+         ;; Read afterwards so the source-properties are correct above
+         ;; and actually point to the very character to be read.
+         (c (read-char port)))
     (cond
      ;; End of input must be specially marked to the parser.
      ((eof-object? c) (return 'eof c))


hooks/post-receive
-- 
GNU Guile