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