module/system/base/compile.scm

   1 ;;; High-level compiler interface
   2
   3 ;; Copyright (C) 2001, 2009 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 (syntax-error
  30             *current-language*
  31             current-compilation-environment
  32             compiled-file-name compile-file compile-and-load
  33             compile
  34             decompile)
  35   #:export-syntax (call-with-compile-error-catch))
  36
  37 ;;;
  38 ;;; Compiler environment
  39 ;;;
  40
  41 (define (syntax-error loc msg exp)
  42   (throw 'syntax-error-compile-time loc msg exp))
  43
  44 (define-macro (call-with-compile-error-catch thunk)
  45   `(catch 'syntax-error-compile-time
  46          ,thunk
  47          (lambda (key loc msg exp)
  48            (if (pair? loc)
  49                (let ((file (or (assq-ref loc 'filename) "unknown file"))
  50                      (line (assq-ref loc 'line))
  51                      (col (assq-ref loc 'column)))
  52                  (format (current-error-port)
  53                          "~A:~A:~A: ~A: ~A~%" file line col msg exp))
  54                (format (current-error-port)
  55                        "unknown location: ~A: ~S~%" msg exp)))))
  56
  57 \f
  58 ;;;
  59 ;;; Compiler
  60 ;;;
  61
  62 (define *current-language* (make-fluid))
  63 (fluid-set! *current-language* 'scheme)
  64 (define (current-language)
  65   (fluid-ref *current-language*))
  66
  67 (define *compilation-environment* (make-fluid))
  68 (define (current-compilation-environment)
  69   "Return the current compilation environment (a module) or #f.  This
  70 function should only be called from stages in the compiler tower."
  71   (fluid-ref *compilation-environment*))
  72
  73 (define (call-once thunk)
  74   (let ((entered #f))
  75     (dynamic-wind
  76         (lambda ()
  77           (if entered
  78               (error "thunk may only be entered once: ~a" thunk))
  79           (set! entered #t))
  80         thunk
  81         (lambda () #t))))
  82
  83 (define* (call-with-output-file/atomic filename proc #:optional reference)
  84   (let* ((template (string-append filename ".XXXXXX"))
  85          (tmp (mkstemp! template)))
  86     (call-once
  87      (lambda ()
  88        (with-throw-handler #t
  89          (lambda ()
  90            (proc tmp)
  91            (chmod tmp (logand #o0666 (lognot (umask))))
  92            (close-port tmp)
  93            (if reference
  94                (let ((st (stat reference)))
  95                  (utime template (stat:atime st) (stat:mtime st))))
  96            (rename-file template filename))
  97          (lambda args
  98            (delete-file template)))))))
  99
 100 (define (ensure-language x)
 101   (if (language? x)
 102       x
 103       (lookup-language x)))
 104
 105 ;; Throws an exception if `dir' is not writable. The double-stat is OK,
 106 ;; as this is only used during compilation.
 107 (define (ensure-writable-dir dir)
 108   (if (file-exists? dir)
 109       (if (access? dir W_OK)
 110           #t
 111           (error "directory not writable" dir))
 112       (begin
 113         (ensure-writable-dir (dirname dir))
 114         (mkdir dir))))
 115
 116 (define (dsu-sort list key less)
 117   (map cdr
 118        (stable-sort (map (lambda (x) (cons (key x) x)) list)
 119                     (lambda (x y) (less (car x) (car y))))))
 120
 121 ;;; This function is among the trickiest I've ever written. I tried many
 122 ;;; variants. In the end, simple is best, of course.
 123 ;;;
 124 ;;; After turning this around a number of times, it seems that the the
 125 ;;; desired behavior is that .go files should exist in a path, for
 126 ;;; searching. That is orthogonal to this function. For writing .go
 127 ;;; files, either you know where they should go, in which case you tell
 128 ;;; compile-file explicitly, as in the srcdir != builddir case; or you
 129 ;;; don't know, in which case this function is called, and we just put
 130 ;;; them in your own ccache dir in ~/.guile-ccache.
 131 (define (compiled-file-name file)
 132   (define (compiled-extension)
 133     (cond ((or (null? %load-compiled-extensions)
 134                (string-null? (car %load-compiled-extensions)))
 135            (warn "invalid %load-compiled-extensions"
 136                  %load-compiled-extensions)
 137            ".go")
 138           (else (car %load-compiled-extensions))))
 139   (and %compile-fallback-path
 140        (let ((f (string-append
 141                  %compile-fallback-path
 142                  ;; no need for '/' separator here, canonicalize-path
 143                  ;; will give us an absolute path
 144                  (canonicalize-path file)
 145                  (compiled-extension))))
 146          (and (false-if-exception (ensure-writable-dir (dirname f)))
 147               f))))
 148
 149 (define* (compile-file file #:key
 150                        (output-file #f)
 151                        (env #f)
 152                        (from (current-language))
 153                        (to 'objcode)
 154                        (opts '()))
 155   (let* ((comp (or output-file (compiled-file-name file)))
 156          (in (open-input-file file))
 157          (enc (file-encoding in)))
 158     (if enc
 159         (set-port-encoding! in enc))
 160     (ensure-writable-dir (dirname comp))
 161     (call-with-output-file/atomic comp
 162       (lambda (port)
 163         ((language-printer (ensure-language to))
 164          (read-and-compile in #:env env #:from from #:to to #:opts opts)
 165          port))
 166       file)
 167     comp))
 168
 169 (define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
 170   (read-and-compile (open-input-file file)
 171                     #:from from #:to to #:opts opts
 172                     #:env (current-module)))
 173
 174 \f
 175 ;;;
 176 ;;; Compiler interface
 177 ;;;
 178
 179 (define (compile-passes from to opts)
 180   (map cdr
 181        (or (lookup-compilation-order from to)
 182            (error "no way to compile" from "to" to))))
 183
 184 (define (compile-fold passes exp env opts)
 185   (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
 186     (if (null? passes)
 187         (values x e cenv)
 188         (receive (x e new-cenv) ((car passes) x e opts)
 189           (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
 190
 191 (define (find-language-joint from to)
 192   (let lp ((in (reverse (or (lookup-compilation-order from to)
 193                             (error "no way to compile" from "to" to))))
 194            (lang to))
 195     (cond ((null? in)
 196            (error "don't know how to join expressions" from to))
 197           ((language-joiner lang) lang)
 198           (else
 199            (lp (cdr in) (caar in))))))
 200
 201 (define (make-compilation-module)
 202   "Return a fresh module to be used as the compilation environment."
 203
 204   ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
 205   ;; `fluid-set!', etc. don't have any effect in the current environment.
 206
 207   (let ((m (make-module)))
 208     (beautify-user-module! m)
 209
 210     ;; Provide a separate `current-reader' fluid so that the Scheme language
 211     ;; reader doesn't get to see the REPL's settings for `current-reader',
 212     ;; which would lead to an infinite loop.
 213     (module-define! m 'current-reader (make-fluid))
 214
 215     m))
 216
 217 (define (language-default-environment lang)
 218   "Return the default compilation environment for source language LANG."
 219   (if (or (eq? lang 'scheme)
 220           (eq? lang (lookup-language 'scheme)))
 221       (make-compilation-module)
 222       #f))
 223
 224 (define* (read-and-compile port #:key
 225                            (env #f)
 226                            (from (current-language))
 227                            (to 'objcode)
 228                            (opts '()))
 229   (let ((from (ensure-language from))
 230         (to (ensure-language to)))
 231     (let ((joint (find-language-joint from to)))
 232       (with-fluids ((*current-language* from)
 233                     (*compilation-environment*
 234                      (or env
 235                          (language-default-environment from))))
 236         (let lp ((exps '()) (env #f)
 237                  (cenv (fluid-ref *compilation-environment*)))
 238           (let ((x ((language-reader (current-language)) port env)))
 239             (cond
 240              ((eof-object? x)
 241               (compile ((language-joiner joint) (reverse exps) env)
 242                        #:from joint #:to to #:env env #:opts opts))
 243              (else
 244               ;; compile-fold instead of compile so we get the env too
 245               (receive (jexp jenv jcenv)
 246                   (compile-fold (compile-passes (current-language) joint opts)
 247                                 x cenv opts)
 248                 (lp (cons jexp exps) jenv jcenv))))))))))
 249
 250 (define* (compile x #:key
 251                   (env #f)
 252                   (from (current-language))
 253                   (to 'value)
 254                   (opts '()))
 255
 256   (let ((warnings (memq #:warnings opts)))
 257     (if (pair? warnings)
 258         (let ((warnings (cadr warnings)))
 259           ;; Sanity-check the requested warnings.
 260           (for-each (lambda (w)
 261                       (or (lookup-warning-type w)
 262                           (warning 'unsupported-warning #f w)))
 263                     warnings))))
 264
 265   (receive (exp env cenv)
 266       (let ((env (or env (language-default-environment from))))
 267         (with-fluids ((*compilation-environment* env))
 268           (compile-fold (compile-passes from to opts) x env opts)))
 269     exp))
 270
 271 \f
 272 ;;;
 273 ;;; Decompiler interface
 274 ;;;
 275
 276 (define (decompile-passes from to opts)
 277   (map cdr
 278        (or (lookup-decompilation-order from to)
 279            (error "no way to decompile" from "to" to))))
 280
 281 (define (decompile-fold passes exp env opts)
 282   (if (null? passes)
 283       (values exp env)
 284       (receive (exp env) ((car passes) exp env opts)
 285         (decompile-fold (cdr passes) exp env opts))))
 286
 287 (define* (decompile x #:key
 288                     (env #f)
 289                     (from 'value)
 290                     (to 'assembly)
 291                     (opts '()))
 292   (decompile-fold (decompile-passes from to opts)
 293                   x
 294                   env
 295                   opts))