1 ;;; High-level compiler interface
3 ;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
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.
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.
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
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 (compiled-file-name
41 (define (call-once thunk)
46 (error "thunk may only be entered once: ~a" thunk))
51 ;; emacs: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
52 (define* (call-with-output-file/atomic filename proc #:optional reference)
53 (let* ((template (string-append filename ".XXXXXX"))
54 (tmp (mkstemp! template)))
57 (with-throw-handler #t
60 ;; Chmodding by name instead of by port allows this chmod to
61 ;; work on systems without fchmod, like MinGW.
62 (chmod template (logand #o0666 (lognot (umask))))
64 (rename-file template filename))
67 (delete-file template)))))))
69 (define (ensure-language x)
74 ;; Throws an exception if `dir' is not writable. The mkdir occurs
75 ;; before the check, so that we avoid races (possibly due to parallel
78 (define (ensure-directory dir)
82 (lambda (k subr fmt args rest)
83 (let ((errno (and (pair? rest) (car rest))))
86 ;; Assume it's a writable directory, to avoid TOCTOU errors,
87 ;; as well as UID/EUID mismatches that occur with access(2).
90 (ensure-directory (dirname dir))
91 (ensure-directory dir))
93 (throw k subr fmt args rest)))))))
95 ;;; This function is among the trickiest I've ever written. I tried many
96 ;;; variants. In the end, simple is best, of course.
98 ;;; After turning this around a number of times, it seems that the
99 ;;; desired behavior is that .go files should exist in a path, for
100 ;;; searching. That is orthogonal to this function. For writing .go
101 ;;; files, either you know where they should go, in which case you tell
102 ;;; compile-file explicitly, as in the srcdir != builddir case; or you
103 ;;; don't know, in which case this function is called, and we just put
104 ;;; them in your own ccache dir in ~/.cache/guile/ccache.
106 ;;; See also boot-9.scm:load.
107 (define (compiled-file-name file)
108 ;; FIXME: would probably be better just to append SHA1(canon-path)
109 ;; to the %compile-fallback-path, to avoid deep directory stats.
110 (define (canonical->suffix canon)
112 ((string-prefix? "/" canon) canon)
113 ((and (> (string-length canon) 2)
114 (eqv? (string-ref canon 1) #\:))
115 ;; Paths like C:... transform to /C...
116 (string-append "/" (substring canon 0 1) (substring canon 2)))
118 (define (compiled-extension)
119 (cond ((or (null? %load-compiled-extensions)
120 (string-null? (car %load-compiled-extensions)))
121 (warn "invalid %load-compiled-extensions"
122 %load-compiled-extensions)
124 (else (car %load-compiled-extensions))))
125 (and %compile-fallback-path
126 (let ((f (string-append
127 %compile-fallback-path
128 (canonical->suffix (canonicalize-path file))
129 (compiled-extension))))
130 (and (false-if-exception (ensure-directory (dirname f)))
133 (define* (compile-file file #:key
135 (from (current-language))
137 (env (default-environment from))
139 (canonicalization 'relative))
140 (with-fluids ((%file-port-name-canonicalization canonicalization))
141 (let* ((comp (or output-file (compiled-file-name file)
142 (error "failed to create path for auto-compiled file"
144 (in (open-input-file file))
145 (enc (file-encoding in)))
146 ;; Choose the input encoding deterministically.
147 (set-port-encoding! in (or enc "UTF-8"))
149 (ensure-directory (dirname comp))
150 (call-with-output-file/atomic comp
152 ((language-printer (ensure-language to))
153 (read-and-compile in #:env env #:from from #:to to #:opts
154 (cons* #:to-file? #t opts))
159 (define* (compile-and-load file #:key (from (current-language)) (to 'value)
160 (env (current-module)) (opts '())
161 (canonicalization 'relative))
162 (with-fluids ((%file-port-name-canonicalization canonicalization))
163 (read-and-compile (open-input-file file)
164 #:from from #:to to #:opts opts
169 ;;; Compiler interface
172 (define (compile-passes from to opts)
174 (or (lookup-compilation-order from to)
175 (error "no way to compile" from "to" to))))
177 (define (compile-fold passes exp env opts)
178 (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
181 (receive (x e new-cenv) ((car passes) x e opts)
182 (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
184 (define (find-language-joint from to)
185 (let lp ((in (reverse (or (lookup-compilation-order from to)
186 (error "no way to compile" from "to" to))))
188 (cond ((null? in) to)
189 ((language-joiner lang) lang)
191 (lp (cdr in) (caar in))))))
193 (define (default-language-joiner lang)
195 (if (and (pair? exps) (null? (cdr exps)))
198 "Multiple expressions read and compiled, but language has no joiner"
201 (define (read-and-parse lang port cenv)
202 (let ((exp ((language-reader lang) port cenv)))
204 ((eof-object? exp) exp)
205 ((language-parser lang) => (lambda (parse) (parse exp)))
208 (define* (read-and-compile port #:key
209 (from (current-language))
211 (env (default-environment from))
213 (let ((from (ensure-language from))
214 (to (ensure-language to)))
215 (let ((joint (find-language-joint from to)))
216 (parameterize ((current-language from))
217 (let lp ((exps '()) (env #f) (cenv env))
218 (let ((x (read-and-parse (current-language) port cenv)))
222 (compile ((or (language-joiner joint)
223 (default-language-joiner joint))
227 ;; env can be false if no expressions were read.
228 #:env (or env (default-environment joint))
231 ;; compile-fold instead of compile so we get the env too
232 (receive (jexp jenv jcenv)
233 (compile-fold (compile-passes (current-language) joint opts)
235 (lp (cons jexp exps) jenv jcenv))))))))))
237 (define* (compile x #:key
238 (from (current-language))
240 (env (default-environment from))
243 (let ((warnings (memq #:warnings opts)))
245 (let ((warnings (cadr warnings)))
246 ;; Sanity-check the requested warnings.
247 (for-each (lambda (w)
248 (or (lookup-warning-type w)
249 (warning 'unsupported-warning #f w)))
252 (receive (exp env cenv)
253 (compile-fold (compile-passes from to opts) x env opts)
258 ;;; Decompiler interface
261 (define (decompile-passes from to opts)
263 (or (lookup-decompilation-order from to)
264 (error "no way to decompile" from "to" to))))
266 (define (decompile-fold passes exp env opts)
269 (receive (exp env) ((car passes) exp env opts)
270 (decompile-fold (cdr passes) exp env opts))))
272 (define* (decompile x #:key
277 (decompile-fold (decompile-passes from to opts)