mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
f3130a2ecf
* module/system/base/compile.scm (ensure-writable-dir): Rename from ensure-directory. (dsu-sort): Helper, does a decorate / sort / undecorate. (compiled-file-name): Refactor to only return a writable filename. The readable case is handled by load.c now, and the other case was silly. Hopefully it will do the right thing. (load-ensuring-compiled): Remove, load.c will call out to compile-file if necessary. (ensure-fallback-path): Remove, load.c will add the ~/.guile-ccache dir to the load-compiled path, which will prompt its creation if necessary.
256 lines
8.8 KiB
Scheme
256 lines
8.8 KiB
Scheme
;;; High-level compiler interface
|
||
|
||
;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
|
||
|
||
;; This program is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation; either version 2, or (at your option)
|
||
;; any later version.
|
||
;;
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program; see the file COPYING. If not, write to
|
||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||
;; Boston, MA 02111-1307, USA.
|
||
|
||
;;; Code:
|
||
|
||
(define-module (system base compile)
|
||
#:use-module (system base syntax)
|
||
#:use-module (system base language)
|
||
#:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
|
||
#:use-module (ice-9 regex)
|
||
#:use-module (ice-9 optargs)
|
||
#:use-module (ice-9 receive)
|
||
#:export (syntax-error
|
||
*current-language*
|
||
compiled-file-name compile-file compile-and-load
|
||
compile
|
||
decompile)
|
||
#:export-syntax (call-with-compile-error-catch))
|
||
|
||
;;;
|
||
;;; Compiler environment
|
||
;;;
|
||
|
||
(define (syntax-error loc msg exp)
|
||
(throw 'syntax-error-compile-time loc msg exp))
|
||
|
||
(define-macro (call-with-compile-error-catch thunk)
|
||
`(catch 'syntax-error-compile-time
|
||
,thunk
|
||
(lambda (key loc msg exp)
|
||
(if (pair? loc)
|
||
(let ((file (or (assq-ref loc 'filename) "unknown file"))
|
||
(line (assq-ref loc 'line))
|
||
(col (assq-ref loc 'column)))
|
||
(format (current-error-port)
|
||
"~A:~A:~A: ~A: ~A~%" file line col msg exp))
|
||
(format (current-error-port)
|
||
"unknown location: ~A: ~S~%" msg exp)))))
|
||
|
||
|
||
;;;
|
||
;;; Compiler
|
||
;;;
|
||
|
||
(define *current-language* (make-fluid))
|
||
(fluid-set! *current-language* 'scheme)
|
||
(define (current-language)
|
||
(fluid-ref *current-language*))
|
||
|
||
(define (call-once thunk)
|
||
(let ((entered #f))
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(if entered
|
||
(error "thunk may only be entered once: ~a" thunk))
|
||
(set! entered #t))
|
||
thunk
|
||
(lambda () #t))))
|
||
|
||
(define (call-with-output-file/atomic filename proc)
|
||
(let* ((template (string-append filename ".XXXXXX"))
|
||
(tmp (mkstemp! template)))
|
||
(call-once
|
||
(lambda ()
|
||
(with-throw-handler #t
|
||
(lambda ()
|
||
(proc tmp)
|
||
(chmod tmp (logand #o0666 (lognot (umask))))
|
||
(close-port tmp)
|
||
(rename-file template filename))
|
||
(lambda args
|
||
(delete-file template)))))))
|
||
|
||
(define (ensure-language x)
|
||
(if (language? x)
|
||
x
|
||
(lookup-language x)))
|
||
|
||
;; Throws an exception if `dir' is not writable. The double-stat is OK,
|
||
;; as this is only used during compilation.
|
||
(define (ensure-writable-dir dir)
|
||
(if (file-exists? dir)
|
||
(if (access? dir W_OK)
|
||
#t
|
||
(error "directory not writable" dir))
|
||
(begin
|
||
(ensure-writable-dir (dirname dir))
|
||
(mkdir dir))))
|
||
|
||
(define (dsu-sort list key less)
|
||
(map cdr
|
||
(stable-sort (map (lambda (x) (cons (key x) x)) list)
|
||
(lambda (x y) (less (car x) (car y))))))
|
||
|
||
(define (compiled-file-name file)
|
||
(let ((cext (cond ((or (null? %load-compiled-extensions)
|
||
(string-null? (car %load-compiled-extensions)))
|
||
(warn "invalid %load-compiled-extensions"
|
||
%load-compiled-extensions)
|
||
".go")
|
||
(else (car %load-compiled-extensions)))))
|
||
(define (strip-source-extension path)
|
||
(let lp ((exts %load-extensions))
|
||
(cond ((null? exts) file)
|
||
((string-null? (car exts)) (lp (cdr exts)))
|
||
((string-suffix? (car exts) path)
|
||
(substring path 0
|
||
(- (string-length path)
|
||
(string-length (car exts)))))
|
||
(else (lp (cdr exts))))))
|
||
;; there is some trickery here. if no %load-compiled-path is a
|
||
;; prefix of `file', the stability of the sort makes us end up
|
||
;; trying to write first to last dir in the path, which is usually
|
||
;; the $HOME ccache dir.
|
||
(let lp ((paths (dsu-sort (reverse %load-compiled-path)
|
||
(lambda (x)
|
||
(if (string-prefix? x file)
|
||
(string-length x)
|
||
0))
|
||
>)))
|
||
(if (null? paths)
|
||
(error "no writable path when compiling" file)
|
||
(let ((rpath (in-vicinity
|
||
(car paths)
|
||
(string-append
|
||
(strip-source-extension
|
||
(if (string-prefix? (car paths) file)
|
||
(substring file (1+ (string-length (car paths))))
|
||
(substring file 1)))
|
||
cext))))
|
||
(if (and (false-if-exception
|
||
(ensure-writable-dir (dirname rpath)))
|
||
(or (not (file-exists? rpath))
|
||
(access? rpath W_OK)))
|
||
rpath
|
||
(lp (cdr paths))))))))
|
||
|
||
(define* (compile-file file #:key
|
||
(output-file #f)
|
||
(env #f)
|
||
(from (current-language))
|
||
(to 'objcode)
|
||
(opts '()))
|
||
(let ((comp (or output-file (compiled-file-name file)))
|
||
(in (open-input-file file)))
|
||
(ensure-writable-dir (dirname comp))
|
||
(call-with-output-file/atomic comp
|
||
(lambda (port)
|
||
((language-printer (ensure-language to))
|
||
(read-and-compile in #:env env #:from from #:to to #:opts opts)
|
||
port)))
|
||
comp))
|
||
|
||
(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
|
||
(read-and-compile (open-input-file file)
|
||
#:from from #:to to #:opts opts))
|
||
|
||
|
||
;;;
|
||
;;; Compiler interface
|
||
;;;
|
||
|
||
(define (compile-passes from to opts)
|
||
(map cdr
|
||
(or (lookup-compilation-order from to)
|
||
(error "no way to compile" from "to" to))))
|
||
|
||
(define (compile-fold passes exp env opts)
|
||
(let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
|
||
(if (null? passes)
|
||
(values x e cenv)
|
||
(receive (x e new-cenv) ((car passes) x e opts)
|
||
(lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
|
||
|
||
(define (find-language-joint from to)
|
||
(let lp ((in (reverse (or (lookup-compilation-order from to)
|
||
(error "no way to compile" from "to" to))))
|
||
(lang to))
|
||
(cond ((null? in)
|
||
(error "don't know how to join expressions" from to))
|
||
((language-joiner lang) lang)
|
||
(else
|
||
(lp (cdr in) (caar in))))))
|
||
|
||
(define* (read-and-compile port #:key
|
||
(env #f)
|
||
(from (current-language))
|
||
(to 'objcode)
|
||
(opts '()))
|
||
(let ((from (ensure-language from))
|
||
(to (ensure-language to)))
|
||
(let ((joint (find-language-joint from to)))
|
||
(with-fluids ((*current-language* from))
|
||
(let lp ((exps '()) (env #f) (cenv env))
|
||
(let ((x ((language-reader (current-language)) port)))
|
||
(cond
|
||
((eof-object? x)
|
||
(compile ((language-joiner joint) (reverse exps) env)
|
||
#:from joint #:to to #:env env #:opts opts))
|
||
(else
|
||
;; compile-fold instead of compile so we get the env too
|
||
(receive (jexp jenv jcenv)
|
||
(compile-fold (compile-passes (current-language) joint opts)
|
||
x cenv opts)
|
||
(lp (cons jexp exps) jenv jcenv))))))))))
|
||
|
||
(define* (compile x #:key
|
||
(env #f)
|
||
(from (current-language))
|
||
(to 'value)
|
||
(opts '()))
|
||
(receive (exp env cenv)
|
||
(compile-fold (compile-passes from to opts) x env opts)
|
||
exp))
|
||
|
||
|
||
;;;
|
||
;;; Decompiler interface
|
||
;;;
|
||
|
||
(define (decompile-passes from to opts)
|
||
(map cdr
|
||
(or (lookup-decompilation-order from to)
|
||
(error "no way to decompile" from "to" to))))
|
||
|
||
(define (decompile-fold passes exp env opts)
|
||
(if (null? passes)
|
||
(values exp env)
|
||
(receive (exp env) ((car passes) exp env opts)
|
||
(decompile-fold (cdr passes) exp env opts))))
|
||
|
||
(define* (decompile x #:key
|
||
(env #f)
|
||
(from 'value)
|
||
(to 'assembly)
|
||
(opts '()))
|
||
(decompile-fold (decompile-passes from to opts)
|
||
x
|
||
env
|
||
opts))
|