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             load-ensuring-compiled
  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 (call-once thunk)
  68   (let ((entered #f))
  69     (dynamic-wind
  70         (lambda ()
  71           (if entered
  72               (error "thunk may only be entered once: ~a" thunk))
  73           (set! entered #t))
  74         thunk
  75         (lambda () #t))))
  76
  77 (define (call-with-output-file/atomic filename proc)
  78   (let* ((template (string-append filename ".XXXXXX"))
  79          (tmp (mkstemp! template)))
  80     (call-once
  81      (lambda ()
  82        (with-throw-handler #t
  83          (lambda ()
  84            (proc tmp)
  85            (chmod tmp (logand #o0666 (lognot (umask))))
  86            (close-port tmp)
  87            (rename-file template filename))
  88          (lambda args
  89            (delete-file template)))))))
  90
  91 (define (ensure-language x)
  92   (if (language? x)
  93       x
  94       (lookup-language x)))
  95
  96 (define (ensure-directory dir)
  97   (or (file-exists? dir)
  98       (begin
  99         (ensure-directory (dirname dir))
 100         (mkdir dir))))
 101
 102 (define* (compile-file file #:key
 103                        (output-file #f)
 104                        (env #f)
 105                        (from (current-language))
 106                        (to 'objcode)
 107                        (opts '()))
 108   (let ((comp (or output-file (compiled-file-name file)))
 109         (in (open-input-file file)))
 110     (ensure-directory (dirname comp))
 111     (call-with-output-file/atomic comp
 112       (lambda (port)
 113         ((language-printer (ensure-language to))
 114          (read-and-compile in #:env env #:from from #:to to #:opts opts)
 115          port)))
 116     comp))
 117
 118 (define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
 119   (read-and-compile (open-input-file file)
 120                     #:from from #:to to #:opts opts))
 121
 122 (define* (load-ensuring-compiled source #:key (from 'scheme)
 123                                            (to 'value) (opts '()))
 124   (let ((compiled (compiled-file-name source #:readable #t)))
 125     (load-compiled
 126      (if (and compiled
 127               (>= (stat:mtime (stat compiled)) (stat:mtime (stat source))))
 128          compiled
 129          (let ((to-compile (compiled-file-name source #:writable #t)))
 130            (if compiled
 131                (warn "source file" source "newer than" compiled))
 132            (if (and compiled
 133                     (not (string-equal? compiled to-compile))
 134                     (file-exists? to-compile)
 135                     (>= (stat:mtime (stat to-compile))
 136                         (stat:mtime (stat compiled))))
 137                (warn "using local compiled copy" to-compile)
 138                (begin
 139                  (format (current-error-port) ";;; Compiling ~s\n" source)
 140                  (compile-file source #:output-file to-compile)
 141                  (format (current-error-port) ";;; Success: ~s\n" to-compile)))
 142            to-compile)))))
 143
 144 (define (ensure-fallback-path)
 145   (let ((home (or (getenv "HOME")
 146                           (false-if-exception
 147                            (passwd:dir (getpwuid (getuid)))))))
 148     (and home
 149          (let ((cache (in-vicinity home ".guile-ccache")))
 150            (cond
 151             ((and (access? cache (logior W_OK X_OK))
 152                   (file-is-directory? cache))
 153              cache)
 154             ((not (file-exists? cache))
 155              (and (false-if-exception (mkdir cache))
 156                   cache))
 157             (else #f))))))
 158
 159 (define load-compiled-path
 160   (let ((fallback-path #f))
 161     (lambda ()
 162       (if (not fallback-path)
 163           (let ((cache-path (ensure-fallback-path)))
 164             (set! fallback-path
 165                   (if cache-path
 166                       (list cache-path)
 167                       '()))))
 168       (append %load-path fallback-path))))
 169
 170 (define* (compiled-file-name file #:key (writable #f) (readable #f))
 171   (let ((base (basename file))
 172         (cext (cond ((or (null? %load-compiled-extensions)
 173                          (string-null? (car %load-compiled-extensions)))
 174                      (warn "invalid %load-compiled-extensions"
 175                            %load-compiled-extensions)
 176                      ".go")
 177                     (else (car %load-compiled-extensions)))))
 178     (define (strip-source-extension base)
 179       (let lp ((exts %load-extensions))
 180         (cond ((null? exts) (string-append file cext))
 181               ((string-null? (car exts)) (lp (cdr exts)))
 182               ((string-suffix? (car exts) base)
 183                (substring source 0
 184                           (- (string-length source)
 185                              (string-length (car exts)))))
 186               (else (lp (cdr exts))))))
 187     (define (strip-path file paths)
 188       (let lp ((paths paths))
 189         (cond ((null? paths) file)
 190               ((string-prefix? (car paths) file)
 191                (substring file (1+ (string-length (car paths)))))
 192               (else (lp (cdr paths))))))
 193     (let ((sibling (string-append (strip-source-extension file) cext)))
 194       (cond
 195        (writable
 196         ;; either put it right beside the original file, or in our
 197         ;; ccache. other things wind up not making sense.
 198         (cond
 199          ((or (not (file-exists? sibling)) (access? sibling W_OK))
 200           sibling)
 201          ((ensure-fallback-path)
 202           => (lambda (p)
 203                (string-append p "/" (strip-path sibling))))
 204          (else #f)))
 205        (readable
 206         (if (access? sibling R_OK)
 207             sibling
 208             (search-path (load-compiled-path)
 209                          (strip-path (strip-source-extension file))
 210                          %load-compiled-extensions #t)))
 211        (else
 212         sibling)))))
 213
 214
 215 \f
 216 ;;;
 217 ;;; Compiler interface
 218 ;;;
 219
 220 (define (compile-passes from to opts)
 221   (map cdr
 222        (or (lookup-compilation-order from to)
 223            (error "no way to compile" from "to" to))))
 224
 225 (define (compile-fold passes exp env opts)
 226   (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
 227     (if (null? passes)
 228         (values x e cenv)
 229         (receive (x e new-cenv) ((car passes) x e opts)
 230           (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
 231
 232 (define (find-language-joint from to)
 233   (let lp ((in (reverse (or (lookup-compilation-order from to)
 234                             (error "no way to compile" from "to" to))))
 235            (lang to))
 236     (cond ((null? in)
 237            (error "don't know how to join expressions" from to))
 238           ((language-joiner lang) lang)
 239           (else
 240            (lp (cdr in) (caar in))))))
 241
 242 (define* (read-and-compile port #:key
 243                            (env #f)
 244                            (from (current-language))
 245                            (to 'objcode)
 246                            (opts '()))
 247   (let ((from (ensure-language from))
 248         (to (ensure-language to)))
 249     (let ((joint (find-language-joint from to)))
 250       (with-fluids ((*current-language* from))
 251         (let lp ((exps '()) (env #f) (cenv env))
 252           (let ((x ((language-reader (current-language)) port)))
 253             (cond
 254              ((eof-object? x)
 255               (compile ((language-joiner joint) (reverse exps) env)
 256                        #:from joint #:to to #:env env #:opts opts))
 257              (else
 258               ;; compile-fold instead of compile so we get the env too
 259               (receive (jexp jenv jcenv)
 260                   (compile-fold (compile-passes (current-language) joint opts)
 261                                 x cenv opts)
 262                 (lp (cons jexp exps) jenv jcenv))))))))))
 263
 264 (define* (compile x #:key
 265                   (env #f)
 266                   (from (current-language))
 267                   (to 'value)
 268                   (opts '()))
 269   (receive (exp env cenv)
 270       (compile-fold (compile-passes from to opts) x env opts)
 271     exp))
 272
 273 \f
 274 ;;;
 275 ;;; Decompiler interface
 276 ;;;
 277
 278 (define (decompile-passes from to opts)
 279   (map cdr
 280        (or (lookup-decompilation-order from to)
 281            (error "no way to decompile" from "to" to))))
 282
 283 (define (decompile-fold passes exp env opts)
 284   (if (null? passes)
 285       (values exp env)
 286       (receive (exp env) ((car passes) exp env opts)
 287         (decompile-fold (cdr passes) exp env opts))))
 288
 289 (define* (decompile x #:key
 290                     (env #f)
 291                     (from 'value)
 292                     (to 'assembly)
 293                     (opts '()))
 294   (decompile-fold (decompile-passes from to opts)
 295                   x
 296                   env
 297                   opts))