module/system/base/compile.scm

   1 ;;; High-level compiler interface
   2
   3 ;; Copyright (C) 2001, 2009, 2010, 2011 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 ;; (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            (chmod tmp (logand #o0666 (lognot (umask))))
  61            (close-port tmp)
  62            (rename-file template filename))
  63          (lambda args
  64            (delete-file template)))))))
  65
  66 (define (ensure-language x)
  67   (if (language? x)
  68       x
  69       (lookup-language x)))
  70
  71 ;; Throws an exception if `dir' is not writable.  The mkdir occurs
  72 ;; before the check, so that we avoid races (possibly due to parallel
  73 ;; compilation).
  74 ;;
  75 (define (ensure-writable-dir dir)
  76   (catch 'system-error
  77     (lambda ()
  78       (mkdir dir))
  79     (lambda (k subr fmt args rest)
  80       (let ((errno (and (pair? rest) (car rest))))
  81         (cond
  82          ((eqv? errno EEXIST)
  83           (let ((st (stat dir)))
  84             (if (or (not (eq? (stat:type st) 'directory))
  85                     (not (access? dir W_OK)))
  86                 (error "directory not writable" dir))))
  87          ((eqv? errno ENOENT)
  88           (ensure-writable-dir (dirname dir))
  89           (ensure-writable-dir dir))
  90          (else
  91           (throw k subr fmt args rest)))))))
  92
  93 ;;; This function is among the trickiest I've ever written. I tried many
  94 ;;; variants. In the end, simple is best, of course.
  95 ;;;
  96 ;;; After turning this around a number of times, it seems that the the
  97 ;;; desired behavior is that .go files should exist in a path, for
  98 ;;; searching. That is orthogonal to this function. For writing .go
  99 ;;; files, either you know where they should go, in which case you tell
 100 ;;; compile-file explicitly, as in the srcdir != builddir case; or you
 101 ;;; don't know, in which case this function is called, and we just put
 102 ;;; them in your own ccache dir in ~/.guile-ccache.
 103 ;;;
 104 ;;; See also boot-9.scm:load.
 105 (define (compiled-file-name file)
 106   (define (compiled-extension)
 107     (cond ((or (null? %load-compiled-extensions)
 108                (string-null? (car %load-compiled-extensions)))
 109            (warn "invalid %load-compiled-extensions"
 110                  %load-compiled-extensions)
 111            ".go")
 112           (else (car %load-compiled-extensions))))
 113   (and %compile-fallback-path
 114        (let ((f (string-append
 115                  %compile-fallback-path
 116                  ;; no need for '/' separator here, canonicalize-path
 117                  ;; will give us an absolute path
 118                  (canonicalize-path file)
 119                  (compiled-extension))))
 120          (and (false-if-exception (ensure-writable-dir (dirname f)))
 121               f))))
 122
 123 (define* (compile-file file #:key
 124                        (output-file #f)
 125                        (from (current-language))
 126                        (to 'objcode)
 127                        (env (default-environment from))
 128                        (opts '())
 129                        (canonicalization 'relative))
 130   (with-fluids ((%file-port-name-canonicalization canonicalization))
 131     (let* ((comp (or output-file (compiled-file-name file)
 132                      (error "failed to create path for auto-compiled file"
 133                             file)))
 134            (in (open-input-file file))
 135            (enc (file-encoding in)))
 136       ;; Choose the input encoding deterministically.
 137       (set-port-encoding! in (or enc "UTF-8"))
 138
 139       (ensure-writable-dir (dirname comp))
 140       (call-with-output-file/atomic comp
 141         (lambda (port)
 142           ((language-printer (ensure-language to))
 143            (read-and-compile in #:env env #:from from #:to to #:opts opts)
 144            port))
 145         file)
 146       comp)))
 147
 148 (define* (compile-and-load file #:key (from 'scheme) (to 'value)
 149                            (env (current-module)) (opts '())
 150                            (canonicalization 'relative))
 151   (with-fluids ((%file-port-name-canonicalization canonicalization))
 152     (read-and-compile (open-input-file file)
 153                       #:from from #:to to #:opts opts
 154                       #:env env)))
 155
 156 \f
 157 ;;;
 158 ;;; Compiler interface
 159 ;;;
 160
 161 (define (compile-passes from to opts)
 162   (map cdr
 163        (or (lookup-compilation-order from to)
 164            (error "no way to compile" from "to" to))))
 165
 166 (define (compile-fold passes exp env opts)
 167   (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
 168     (if (null? passes)
 169         (values x e cenv)
 170         (receive (x e new-cenv) ((car passes) x e opts)
 171           (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
 172
 173 (define (find-language-joint from to)
 174   (let lp ((in (reverse (or (lookup-compilation-order from to)
 175                             (error "no way to compile" from "to" to))))
 176            (lang to))
 177     (cond ((null? in)
 178            (error "don't know how to join expressions" from to))
 179           ((language-joiner lang) lang)
 180           (else
 181            (lp (cdr in) (caar in))))))
 182
 183 (define* (read-and-compile port #:key
 184                            (from (current-language))
 185                            (to 'objcode)
 186                            (env (default-environment from))
 187                            (opts '()))
 188   (let ((from (ensure-language from))
 189         (to (ensure-language to)))
 190     (let ((joint (find-language-joint from to)))
 191       (with-fluids ((*current-language* from))
 192         (let lp ((exps '()) (env #f) (cenv env))
 193           (let ((x ((language-reader (current-language)) port cenv)))
 194             (cond
 195              ((eof-object? x)
 196               (compile ((language-joiner joint) (reverse exps) env)
 197                        #:from joint #:to to
 198                        ;; env can be false if no expressions were read.
 199                        #:env (or env (default-environment joint))
 200                        #:opts opts))
 201              (else
 202               ;; compile-fold instead of compile so we get the env too
 203               (receive (jexp jenv jcenv)
 204                   (compile-fold (compile-passes (current-language) joint opts)
 205                                 x cenv opts)
 206                 (lp (cons jexp exps) jenv jcenv))))))))))
 207
 208 (define* (compile x #:key
 209                   (from (current-language))
 210                   (to 'value)
 211                   (env (default-environment from))
 212                   (opts '()))
 213
 214   (let ((warnings (memq #:warnings opts)))
 215     (if (pair? warnings)
 216         (let ((warnings (cadr warnings)))
 217           ;; Sanity-check the requested warnings.
 218           (for-each (lambda (w)
 219                       (or (lookup-warning-type w)
 220                           (warning 'unsupported-warning #f w)))
 221                     warnings))))
 222
 223   (receive (exp env cenv)
 224       (compile-fold (compile-passes from to opts) x env opts)
 225     exp))
 226
 227 \f
 228 ;;;
 229 ;;; Decompiler interface
 230 ;;;
 231
 232 (define (decompile-passes from to opts)
 233   (map cdr
 234        (or (lookup-decompilation-order from to)
 235            (error "no way to decompile" from "to" to))))
 236
 237 (define (decompile-fold passes exp env opts)
 238   (if (null? passes)
 239       (values exp env)
 240       (receive (exp env) ((car passes) exp env opts)
 241         (decompile-fold (cdr passes) exp env opts))))
 242
 243 (define* (decompile x #:key
 244                     (env #f)
 245                     (from 'value)
 246                     (to 'assembly)
 247                     (opts '()))
 248   (decompile-fold (decompile-passes from to opts)
 249                   x
 250                   env
 251                   opts))