module/system/base/compile.scm

   1 ;;; High-level compiler interface
   2
   3 ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program 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
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (system base compile)
  23   #:use-module (system base syntax)
  24   #:use-module (system base language)
  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 "/" (canonicalize-path file)
 135                  (compiled-extension))))
 136          (and (false-if-exception (ensure-writable-dir (dirname f)))
 137               f))))
 138
 139 (define* (compile-file file #:key
 140                        (output-file #f)
 141                        (env #f)
 142                        (from (current-language))
 143                        (to 'objcode)
 144                        (opts '()))
 145   (let ((comp (or output-file (compiled-file-name file)))
 146         (in (open-input-file file)))
 147     (ensure-writable-dir (dirname comp))
 148     (call-with-output-file/atomic comp
 149       (lambda (port)
 150         ((language-printer (ensure-language to))
 151          (read-and-compile in #:env env #:from from #:to to #:opts opts)
 152          port))
 153       file)
 154     comp))
 155
 156 (define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
 157   (read-and-compile (open-input-file file)
 158                     #:from from #:to to #:opts opts))
 159
 160 \f
 161 ;;;
 162 ;;; Compiler interface
 163 ;;;
 164
 165 (define (compile-passes from to opts)
 166   (map cdr
 167        (or (lookup-compilation-order from to)
 168            (error "no way to compile" from "to" to))))
 169
 170 (define (compile-fold passes exp env opts)
 171   (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
 172     (if (null? passes)
 173         (values x e cenv)
 174         (receive (x e new-cenv) ((car passes) x e opts)
 175           (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
 176
 177 (define (find-language-joint from to)
 178   (let lp ((in (reverse (or (lookup-compilation-order from to)
 179                             (error "no way to compile" from "to" to))))
 180            (lang to))
 181     (cond ((null? in)
 182            (error "don't know how to join expressions" from to))
 183           ((language-joiner lang) lang)
 184           (else
 185            (lp (cdr in) (caar in))))))
 186
 187 (define* (read-and-compile port #:key
 188                            (env #f)
 189                            (from (current-language))
 190                            (to 'objcode)
 191                            (opts '()))
 192   (let ((from (ensure-language from))
 193         (to (ensure-language to)))
 194     (let ((joint (find-language-joint from to)))
 195       (with-fluids ((*current-language* from))
 196         (let lp ((exps '()) (env #f) (cenv env))
 197           (let ((x ((language-reader (current-language)) port)))
 198             (cond
 199              ((eof-object? x)
 200               (compile ((language-joiner joint) (reverse exps) env)
 201                        #:from joint #:to to #:env env #:opts opts))
 202              (else
 203               ;; compile-fold instead of compile so we get the env too
 204               (receive (jexp jenv jcenv)
 205                   (compile-fold (compile-passes (current-language) joint opts)
 206                                 x cenv opts)
 207                 (lp (cons jexp exps) jenv jcenv))))))))))
 208
 209 (define* (compile x #:key
 210                   (env #f)
 211                   (from (current-language))
 212                   (to 'value)
 213                   (opts '()))
 214   (receive (exp env cenv)
 215       (compile-fold (compile-passes from to opts) x env opts)
 216     exp))
 217
 218 \f
 219 ;;;
 220 ;;; Decompiler interface
 221 ;;;
 222
 223 (define (decompile-passes from to opts)
 224   (map cdr
 225        (or (lookup-decompilation-order from to)
 226            (error "no way to decompile" from "to" to))))
 227
 228 (define (decompile-fold passes exp env opts)
 229   (if (null? passes)
 230       (values exp env)
 231       (receive (exp env) ((car passes) exp env opts)
 232         (decompile-fold (cdr passes) exp env opts))))
 233
 234 (define* (decompile x #:key
 235                     (env #f)
 236                     (from 'value)
 237                     (to 'assembly)
 238                     (opts '()))
 239   (decompile-fold (decompile-passes from to opts)
 240                   x
 241                   env
 242                   opts))