module/system/base/compile.scm

   1 ;;; High-level compiler interface
   2
   3 ;; Copyright (C) 2001, 2009, 2010 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            (in (open-input-file file))
 122            (enc (file-encoding in)))
 123       (if enc
 124           (set-port-encoding! in enc))
 125       (ensure-writable-dir (dirname comp))
 126       (call-with-output-file/atomic comp
 127         (lambda (port)
 128           ((language-printer (ensure-language to))
 129            (read-and-compile in #:env env #:from from #:to to #:opts opts)
 130            port))
 131         file)
 132       comp)))
 133
 134 (define* (compile-and-load file #:key (from 'scheme) (to 'value)
 135                            (env (current-module)) (opts '())
 136                            (canonicalization 'relative))
 137   (with-fluids ((%file-port-name-canonicalization canonicalization))
 138     (read-and-compile (open-input-file file)
 139                       #:from from #:to to #:opts opts
 140                       #:env env)))
 141
 142 \f
 143 ;;;
 144 ;;; Compiler interface
 145 ;;;
 146
 147 (define (compile-passes from to opts)
 148   (map cdr
 149        (or (lookup-compilation-order from to)
 150            (error "no way to compile" from "to" to))))
 151
 152 (define (compile-fold passes exp env opts)
 153   (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
 154     (if (null? passes)
 155         (values x e cenv)
 156         (receive (x e new-cenv) ((car passes) x e opts)
 157           (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
 158
 159 (define (find-language-joint from to)
 160   (let lp ((in (reverse (or (lookup-compilation-order from to)
 161                             (error "no way to compile" from "to" to))))
 162            (lang to))
 163     (cond ((null? in)
 164            (error "don't know how to join expressions" from to))
 165           ((language-joiner lang) lang)
 166           (else
 167            (lp (cdr in) (caar in))))))
 168
 169 (define* (read-and-compile port #:key
 170                            (from (current-language))
 171                            (to 'objcode)
 172                            (env (default-environment from))
 173                            (opts '()))
 174   (let ((from (ensure-language from))
 175         (to (ensure-language to)))
 176     (let ((joint (find-language-joint from to)))
 177       (with-fluids ((*current-language* from))
 178         (let lp ((exps '()) (env #f) (cenv env))
 179           (let ((x ((language-reader (current-language)) port cenv)))
 180             (cond
 181              ((eof-object? x)
 182               (compile ((language-joiner joint) (reverse exps) env)
 183                        #:from joint #:to to
 184                        ;; env can be false if no expressions were read.
 185                        #:env (or env (default-environment joint))
 186                        #:opts opts))
 187              (else
 188               ;; compile-fold instead of compile so we get the env too
 189               (receive (jexp jenv jcenv)
 190                   (compile-fold (compile-passes (current-language) joint opts)
 191                                 x cenv opts)
 192                 (lp (cons jexp exps) jenv jcenv))))))))))
 193
 194 (define* (compile x #:key
 195                   (from (current-language))
 196                   (to 'value)
 197                   (env (default-environment from))
 198                   (opts '()))
 199
 200   (let ((warnings (memq #:warnings opts)))
 201     (if (pair? warnings)
 202         (let ((warnings (cadr warnings)))
 203           ;; Sanity-check the requested warnings.
 204           (for-each (lambda (w)
 205                       (or (lookup-warning-type w)
 206                           (warning 'unsupported-warning #f w)))
 207                     warnings))))
 208
 209   (receive (exp env cenv)
 210       (compile-fold (compile-passes from to opts) x env opts)
 211     exp))
 212
 213 \f
 214 ;;;
 215 ;;; Decompiler interface
 216 ;;;
 217
 218 (define (decompile-passes from to opts)
 219   (map cdr
 220        (or (lookup-decompilation-order from to)
 221            (error "no way to decompile" from "to" to))))
 222
 223 (define (decompile-fold passes exp env opts)
 224   (if (null? passes)
 225       (values exp env)
 226       (receive (exp env) ((car passes) exp env opts)
 227         (decompile-fold (cdr passes) exp env opts))))
 228
 229 (define* (decompile x #:key
 230                     (env #f)
 231                     (from 'value)
 232                     (to 'assembly)
 233                     (opts '()))
 234   (decompile-fold (decompile-passes from to opts)
 235                   x
 236                   env
 237                   opts))