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