module/system/base/compile.scm

   1 ;;; High-level compiler interface
   2
   3 ;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
   4
   5 ;;; This library is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Lesser General Public
   7 ;;; License as published by the Free Software Foundation; either
   8 ;;; version 3 of the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This library is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Lesser General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Lesser General Public
  16 ;;; License along with this library; if not, write to the Free Software
  17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (system base compile)
  22   #:use-module (system base syntax)
  23   #:use-module (system base language)
  24   #:use-module (system base message)
  25   #:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
  26   #:use-module (ice-9 regex)
  27   #:use-module (ice-9 optargs)
  28   #:use-module (ice-9 receive)
  29   #:export (compiled-file-name
  30             compile-file
  31             compile-and-load
  32             read-and-compile
  33             compile
  34             decompile))
  35
  36
  37 ;;;
  38 ;;; Compiler
  39 ;;;
  40
  41 (define (call-once thunk)
  42   (let ((entered #f))
  43     (dynamic-wind
  44         (lambda ()
  45           (if entered
  46               (error "thunk may only be entered once: ~a" thunk))
  47           (set! entered #t))
  48         thunk
  49         (lambda () #t))))
  50
  51 ;; emacs: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
  52 (define* (call-with-output-file/atomic filename proc #:optional reference)
  53   (let* ((template (string-append filename ".XXXXXX"))
  54          (tmp (mkstemp! template)))
  55     (call-once
  56      (lambda ()
  57        (with-throw-handler #t
  58          (lambda ()
  59            (proc tmp)
  60            ;; Chmodding by name instead of by port allows this chmod to
  61            ;; work on systems without fchmod, like MinGW.
  62            (chmod template (logand #o0666 (lognot (umask))))
  63            (close-port tmp)
  64            (rename-file template filename))
  65          (lambda args
  66            (close-port tmp)
  67            (delete-file template)))))))
  68
  69 (define (ensure-language x)
  70   (if (language? x)
  71       x
  72       (lookup-language x)))
  73
  74 ;; Throws an exception if `dir' is not writable.  The mkdir occurs
  75 ;; before the check, so that we avoid races (possibly due to parallel
  76 ;; compilation).
  77 ;;
  78 (define (ensure-directory dir)
  79   (catch 'system-error
  80     (lambda ()
  81       (mkdir dir))
  82     (lambda (k subr fmt args rest)
  83       (let ((errno (and (pair? rest) (car rest))))
  84         (cond
  85          ((eqv? errno EEXIST)
  86           ;; Assume it's a writable directory, to avoid TOCTOU errors,
  87           ;; as well as UID/EUID mismatches that occur with access(2).
  88           #t)
  89          ((eqv? errno ENOENT)
  90           (ensure-directory (dirname dir))
  91           (ensure-directory dir))
  92          (else
  93           (throw k subr fmt args rest)))))))
  94
  95 ;;; This function is among the trickiest I've ever written. I tried many
  96 ;;; variants. In the end, simple is best, of course.
  97 ;;;
  98 ;;; After turning this around a number of times, it seems that the
  99 ;;; desired behavior is that .go files should exist in a path, for
 100 ;;; searching. That is orthogonal to this function. For writing .go
 101 ;;; files, either you know where they should go, in which case you tell
 102 ;;; compile-file explicitly, as in the srcdir != builddir case; or you
 103 ;;; don't know, in which case this function is called, and we just put
 104 ;;; them in your own ccache dir in ~/.cache/guile/ccache.
 105 ;;;
 106 ;;; See also boot-9.scm:load.
 107 (define (compiled-file-name file)
 108   ;; FIXME: would probably be better just to append SHA1(canon-path)
 109   ;; to the %compile-fallback-path, to avoid deep directory stats.
 110   (define (canonical->suffix canon)
 111     (cond
 112      ((string-prefix? "/" canon) canon)
 113      ((and (> (string-length canon) 2)
 114            (eqv? (string-ref canon 1) #\:))
 115       ;; Paths like C:... transform to /C...
 116       (string-append "/" (substring canon 0 1) (substring canon 2)))
 117      (else canon)))
 118   (define (compiled-extension)
 119     (cond ((or (null? %load-compiled-extensions)
 120                (string-null? (car %load-compiled-extensions)))
 121            (warn "invalid %load-compiled-extensions"
 122                  %load-compiled-extensions)
 123            ".go")
 124           (else (car %load-compiled-extensions))))
 125   (and %compile-fallback-path
 126        (let ((f (string-append
 127                  %compile-fallback-path
 128                  (canonical->suffix (canonicalize-path file))
 129                  (compiled-extension))))
 130          (and (false-if-exception (ensure-directory (dirname f)))
 131               f))))
 132
 133 (define* (compile-file file #:key
 134                        (output-file #f)
 135                        (from (current-language))
 136                        (to 'bytecode)
 137                        (env (default-environment from))
 138                        (opts '())
 139                        (canonicalization 'relative))
 140   (with-fluids ((%file-port-name-canonicalization canonicalization))
 141     (let* ((comp (or output-file (compiled-file-name file)
 142                      (error "failed to create path for auto-compiled file"
 143                             file)))
 144            (in (open-input-file file))
 145            (enc (file-encoding in)))
 146       ;; Choose the input encoding deterministically.
 147       (set-port-encoding! in (or enc "UTF-8"))
 148
 149       (ensure-directory (dirname comp))
 150       (call-with-output-file/atomic comp
 151         (lambda (port)
 152           ((language-printer (ensure-language to))
 153            (read-and-compile in #:env env #:from from #:to to #:opts
 154                              (cons* #:to-file? #t opts))
 155            port))
 156         file)
 157       comp)))
 158
 159 (define* (compile-and-load file #:key (from (current-language)) (to 'value)
 160                            (env (current-module)) (opts '())
 161                            (canonicalization 'relative))
 162   (with-fluids ((%file-port-name-canonicalization canonicalization))
 163     (read-and-compile (open-input-file file)
 164                       #:from from #:to to #:opts opts
 165                       #:env env)))
 166
 167 \f
 168 ;;;
 169 ;;; Compiler interface
 170 ;;;
 171
 172 (define (compile-passes from to opts)
 173   (map cdr
 174        (or (lookup-compilation-order from to)
 175            (error "no way to compile" from "to" to))))
 176
 177 (define (compile-fold passes exp env opts)
 178   (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
 179     (if (null? passes)
 180         (values x e cenv)
 181         (receive (x e new-cenv) ((car passes) x e opts)
 182           (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
 183
 184 (define (find-language-joint from to)
 185   (let lp ((in (reverse (or (lookup-compilation-order from to)
 186                             (error "no way to compile" from "to" to))))
 187            (lang to))
 188     (cond ((language-joiner lang) lang)
 189           ((null? in) to)
 190           (else
 191            (lp (cdr in) (caar in))))))
 192
 193 (define (default-language-joiner lang)
 194   (lambda (exps env)
 195     (if (and (pair? exps) (null? (cdr exps)))
 196         (car exps)
 197         (error
 198          "Multiple expressions read and compiled, but language has no joiner"
 199          lang))))
 200
 201 (define (read-and-parse lang port cenv)
 202   (let ((exp ((language-reader lang) port cenv)))
 203     (cond
 204      ((eof-object? exp) exp)
 205      ((language-parser lang) => (lambda (parse) (parse exp)))
 206      (else exp))))
 207
 208 (define* (read-and-compile port #:key
 209                            (from (current-language))
 210                            (to 'bytecode)
 211                            (env (default-environment from))
 212                            (opts '()))
 213   (let ((from (ensure-language from))
 214         (to (ensure-language to)))
 215     (let ((joint (find-language-joint from to)))
 216       (parameterize ((current-language from))
 217         (let lp ((exps '()) (env #f) (cenv env))
 218           (let ((x (read-and-parse (current-language) port cenv)))
 219             (cond
 220              ((eof-object? x)
 221               (close-port port)
 222               (compile ((or (language-joiner joint)
 223                             (default-language-joiner joint))
 224                         (reverse exps)
 225                         env)
 226                        #:from joint #:to to
 227                        ;; env can be false if no expressions were read.
 228                        #:env (or env (default-environment joint))
 229                        #:opts opts))
 230              (else
 231               ;; compile-fold instead of compile so we get the env too
 232               (receive (jexp jenv jcenv)
 233                   (compile-fold (compile-passes (current-language) joint opts)
 234                                 x cenv opts)
 235                 (lp (cons jexp exps) jenv jcenv))))))))))
 236
 237 (define* (compile x #:key
 238                   (from (current-language))
 239                   (to 'value)
 240                   (env (default-environment from))
 241                   (opts '()))
 242
 243   (let ((warnings (memq #:warnings opts)))
 244     (if (pair? warnings)
 245         (let ((warnings (cadr warnings)))
 246           ;; Sanity-check the requested warnings.
 247           (for-each (lambda (w)
 248                       (or (lookup-warning-type w)
 249                           (warning 'unsupported-warning #f w)))
 250                     warnings))))
 251
 252   (receive (exp env cenv)
 253       (compile-fold (compile-passes from to opts) x env opts)
 254     exp))
 255
 256 \f
 257 ;;;
 258 ;;; Decompiler interface
 259 ;;;
 260
 261 (define (decompile-passes from to opts)
 262   (map cdr
 263        (or (lookup-decompilation-order from to)
 264            (error "no way to decompile" from "to" to))))
 265
 266 (define (decompile-fold passes exp env opts)
 267   (if (null? passes)
 268       (values exp env)
 269       (receive (exp env) ((car passes) exp env opts)
 270         (decompile-fold (cdr passes) exp env opts))))
 271
 272 (define* (decompile x #:key
 273                     (env #f)
 274                     (from 'tree-il)
 275                     (to 'scheme)
 276                     (opts '()))
 277   (decompile-fold (decompile-passes from to opts)
 278                   x
 279                   env
 280                   opts))