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