Re: Guile build failure

[David Pirotte <david@altosw.be>]

[-- Attachment #1: Type: text/plain, Size: 2918 bytes --]

Hi Andy,

> > ‘load.test’ uses ‘compile-file’, and it seems that ‘compile-file’ does
> > an ‘open-input-file’ with no corresponding ‘close-port’.  That may be
> > the problem.
> 
> Can you try the following patch?  ./check-guile load.test on your NFS
> machine should do it.

I did try and it still raise a bug. I had to manually apply the patch[*] and could
have missed a place though: to make sure, here is the compile.scm i used [attached].

note that since the close-port have been added, [1] the remaining trace shows one .nfs* file
- there were two in the trace I sent to Ludovic - and [2] checking manually the directory just
after the trace, it is empty [see below]

Cheers,
David

[*]	i did a git pull before and compile.scm changed ... i could only find one
place to add, (close-port in) [in (define (compile-file ...))], it seems you already
added the other (close-port port).

;;
;; trace ...
;;

david@idefix:/usr/local/src/guile/git-clone 61 $ ./check-guile load.test
Testing /usr/local/src/guile/git-clone/meta/guile ... load.test
with GUILE_LOAD_PATH=/usr/local/src/guile/git-clone/test-suite
Running load.test

;;; (remaining "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir/dir3" ("." ".."))

;;; (remaining "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir/dir2" ("." ".."))

;;; (remaining "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir/dir1/subdir1" ("." ".."))

;;; (remaining "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir/dir1" ("." ".."))

;;; (remaining "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir" ("." ".." ".nfs00000000138c196300000041"))
Backtrace:
In ice-9/boot-9.scm:
 157: 12 [catch #t #<catch-closure baf280> ...]
In unknown file:
   ?: 11 [apply-smob/1 #<catch-closure baf280>]
In ice-9/boot-9.scm:
  63: 10 [call-with-prompt prompt0 ...]
In ice-9/eval.scm:
 432: 9 [eval # #]
 432: 8 [eval # #]
In ice-9/boot-9.scm:
 696: 7 [for-each #<procedure cb1f60 at ice-9/eval.scm:416:20 (a)> ("load.test")]
In ice-9/eval.scm:
 481: 6 [lp (#<fluid 23>) (("load.test"))]
In ice-9/boot-9.scm:
2131: 5 [save-module-excursion #<procedure f53380 at ice-9/boot-9.scm:3771:3 ()>]
3776: 4 [#<procedure f53380 at ice-9/boot-9.scm:3771:3 ()>]
1456: 3 [%start-stack load-stack #<procedure f579c0 at ice-9/boot-9.scm:3767:10 ()>]
1461: 2 [#<procedure cb1cf0 ()>]
In unknown file:
   ?: 1 [primitive-load "/usr/local/src/guile/git-clone/test-suite/tests/load.test"]
   ?: 0 [rmdir "/mnt/galia/linux/64/local/src/guile/git-clone/load-test.dir"]

ERROR: In procedure rmdir:
ERROR: In procedure rmdir: Directory not empty
david@idefix:/usr/local/src/guile/git-clone 62 $ ls -lsa load-test.dir/
total 8
4 drwxrwxr-x  2 david alto 4096 Jan 22 14:35 ./
4 drwxr-xr-x 21 david alto 4096 Jan 22 14:35 ../
david@idefix:/usr/local/src/guile/git-clone 63 $ 

[-- Attachment #2: compile.scm --]
[-- Type: text/x-scheme, Size: 9898 bytes --]

;;; High-level compiler interface

;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (system base compile)
  #:use-module (system base syntax)
  #:use-module (system base language)
  #:use-module (system base message)
  #:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
  #:use-module (ice-9 regex)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:export (compiled-file-name
            compile-file
            compile-and-load
            read-and-compile
            compile
            decompile))


;;;
;;; Compiler
;;;

(define (call-once thunk)
  (let ((entered #f))
    (dynamic-wind
        (lambda ()
          (if entered
              (error "thunk may only be entered once: ~a" thunk))
          (set! entered #t))
        thunk
        (lambda () #t))))

;; (put 'call-with-output-file/atomic 'scheme-indent-function 1)
(define* (call-with-output-file/atomic filename proc #:optional reference)
  (let* ((template (string-append filename ".XXXXXX"))
         (tmp (mkstemp! template)))
    (call-once
     (lambda ()
       (with-throw-handler #t
         (lambda ()
           (proc tmp)
           (chmod tmp (logand #o0666 (lognot (umask))))
           (close-port tmp)
           (rename-file template filename))
         (lambda args
           (delete-file template)))))))

(define (ensure-language x)
  (if (language? x)
      x
      (lookup-language x)))

;; Throws an exception if `dir' is not writable.  The mkdir occurs
;; before the check, so that we avoid races (possibly due to parallel
;; compilation).
;;
(define (ensure-directory dir)
  (catch 'system-error
    (lambda ()
      (mkdir dir))
    (lambda (k subr fmt args rest)
      (let ((errno (and (pair? rest) (car rest))))
        (cond
         ((eqv? errno EEXIST)
          ;; Assume it's a writable directory, to avoid TOCTOU errors,
          ;; as well as UID/EUID mismatches that occur with access(2).
          #t)
         ((eqv? errno ENOENT)
          (ensure-directory (dirname dir))
          (ensure-directory dir))
         (else
          (throw k subr fmt args rest)))))))

;;; This function is among the trickiest I've ever written. I tried many
;;; variants. In the end, simple is best, of course.
;;;
;;; After turning this around a number of times, it seems that the
;;; desired behavior is that .go files should exist in a path, for
;;; searching. That is orthogonal to this function. For writing .go
;;; files, either you know where they should go, in which case you tell
;;; compile-file explicitly, as in the srcdir != builddir case; or you
;;; don't know, in which case this function is called, and we just put
;;; them in your own ccache dir in ~/.cache/guile/ccache.
;;;
;;; See also boot-9.scm:load.
(define (compiled-file-name file)
  ;; FIXME: would probably be better just to append SHA1(canon-path)
  ;; to the %compile-fallback-path, to avoid deep directory stats.
  (define (canonical->suffix canon)
    (cond
     ((string-prefix? "/" canon) canon)
     ((and (> (string-length canon) 2)
           (eqv? (string-ref canon 1) #\:))
      ;; Paths like C:... transform to /C...
      (string-append "/" (substring canon 0 1) (substring canon 2)))
     (else canon)))
  (define (compiled-extension)
    (cond ((or (null? %load-compiled-extensions)
               (string-null? (car %load-compiled-extensions)))
           (warn "invalid %load-compiled-extensions"
                 %load-compiled-extensions)
           ".go")
          (else (car %load-compiled-extensions))))
  (and %compile-fallback-path
       (let ((f (string-append
                 %compile-fallback-path
                 (canonical->suffix (canonicalize-path file))
                 (compiled-extension))))
         (and (false-if-exception (ensure-directory (dirname f)))
              f))))

(define* (compile-file file #:key
                       (output-file #f)
                       (from (current-language))
                       (to 'objcode)
                       (env (default-environment from))
                       (opts '())
                       (canonicalization 'relative))
  (with-fluids ((%file-port-name-canonicalization canonicalization))
    (let* ((comp (or output-file (compiled-file-name file)
                     (error "failed to create path for auto-compiled file"
                            file)))
           (in (open-input-file file))
           (enc (file-encoding in)))
      ;; Choose the input encoding deterministically.
      (set-port-encoding! in (or enc "UTF-8"))

      (ensure-directory (dirname comp))
      (call-with-output-file/atomic comp
        (lambda (port)
          ((language-printer (ensure-language to))
           (read-and-compile in #:env env #:from from #:to to #:opts opts)
           port))
        file)
      (close-port in)
      comp)))

(define* (compile-and-load file #:key (from (current-language)) (to 'value)
                           (env (current-module)) (opts '())
                           (canonicalization 'relative))
  (with-fluids ((%file-port-name-canonicalization canonicalization))
    (read-and-compile (open-input-file file)
                      #:from from #:to to #:opts opts
                      #:env env)))

\f
;;;
;;; Compiler interface
;;;

(define (compile-passes from to opts)
  (map cdr
       (or (lookup-compilation-order from to)
           (error "no way to compile" from "to" to))))

(define (compile-fold passes exp env opts)
  (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
    (if (null? passes)
        (values x e cenv)
        (receive (x e new-cenv) ((car passes) x e opts)
          (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))

(define (find-language-joint from to)
  (let lp ((in (reverse (or (lookup-compilation-order from to)
                            (error "no way to compile" from "to" to))))
           (lang to))
    (cond ((null? in) to)
          ((language-joiner lang) lang)
          (else
           (lp (cdr in) (caar in))))))

(define (default-language-joiner lang)
  (lambda (exps env)
    (if (and (pair? exps) (null? (cdr exps)))
        (car exps)
        (error
         "Multiple expressions read and compiled, but language has no joiner"
         lang))))

(define (read-and-parse lang port cenv)
  (let ((exp ((language-reader lang) port cenv)))
    (cond
     ((eof-object? exp) exp)
     ((language-parser lang) => (lambda (parse) (parse exp)))
     (else exp))))

(define* (read-and-compile port #:key
                           (from (current-language))
                           (to 'objcode)
                           (env (default-environment from))
                           (opts '()))
  (let ((from (ensure-language from))
        (to (ensure-language to)))
    (let ((joint (find-language-joint from to)))
      (parameterize ((current-language from))
        (let lp ((exps '()) (env #f) (cenv env))
          (let ((x (read-and-parse (current-language) port cenv)))
            (cond
             ((eof-object? x)
              (close-port port)
              (compile ((or (language-joiner joint)
                            (default-language-joiner joint))
                        (reverse exps)
                        env)
                       #:from joint #:to to
                       ;; env can be false if no expressions were read.
                       #:env (or env (default-environment joint))
                       #:opts opts))
             (else
              ;; compile-fold instead of compile so we get the env too
              (receive (jexp jenv jcenv)
                  (compile-fold (compile-passes (current-language) joint opts)
                                x cenv opts)
                (lp (cons jexp exps) jenv jcenv))))))))))

(define* (compile x #:key
                  (from (current-language))
                  (to 'value)
                  (env (default-environment from))
                  (opts '()))

  (let ((warnings (memq #:warnings opts)))
    (if (pair? warnings)
        (let ((warnings (cadr warnings)))
          ;; Sanity-check the requested warnings.
          (for-each (lambda (w)
                      (or (lookup-warning-type w)
                          (warning 'unsupported-warning #f w)))
                    warnings))))

  (receive (exp env cenv)
      (compile-fold (compile-passes from to opts) x env opts)
    exp))

\f
;;;
;;; Decompiler interface
;;;

(define (decompile-passes from to opts)
  (map cdr
       (or (lookup-decompilation-order from to)
           (error "no way to decompile" from "to" to))))

(define (decompile-fold passes exp env opts)
  (if (null? passes)
      (values exp env)
      (receive (exp env) ((car passes) exp env opts)
        (decompile-fold (cdr passes) exp env opts))))

(define* (decompile x #:key
                    (env #f)
                    (from 'value)
                    (to 'assembly)
                    (opts '()))
  (decompile-fold (decompile-passes from to opts)
                  x
                  env
                  opts))