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