compile.scm 9.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281
  1. ;;; High-level compiler interface
  2. ;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
  3. ;;; This library is free software; you can redistribute it and/or
  4. ;;; modify it under the terms of the GNU Lesser General Public
  5. ;;; License as published by the Free Software Foundation; either
  6. ;;; version 3 of the License, or (at your option) any later version.
  7. ;;;
  8. ;;; This library is distributed in the hope that it will be useful,
  9. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;;; Lesser General Public License for more details.
  12. ;;;
  13. ;;; You should have received a copy of the GNU Lesser General Public
  14. ;;; License along with this library; if not, write to the Free Software
  15. ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;; Code:
  17. (define-module (system base compile)
  18. #:use-module (system base syntax)
  19. #:use-module (system base language)
  20. #:use-module (system base message)
  21. #:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
  22. #:use-module (ice-9 regex)
  23. #:use-module (ice-9 optargs)
  24. #:use-module (ice-9 receive)
  25. #:export (compiled-file-name
  26. compile-file
  27. compile-and-load
  28. read-and-compile
  29. compile
  30. decompile))
  31. ;;;
  32. ;;; Compiler
  33. ;;;
  34. (define (call-once thunk)
  35. (let ((entered #f))
  36. (dynamic-wind
  37. (lambda ()
  38. (if entered
  39. (error "thunk may only be entered once: ~a" thunk))
  40. (set! entered #t))
  41. thunk
  42. (lambda () #t))))
  43. ;; emacs: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
  44. (define* (call-with-output-file/atomic filename proc #:optional reference)
  45. (let* ((template (string-append filename ".XXXXXX"))
  46. (tmp (mkstemp! template)))
  47. (call-once
  48. (lambda ()
  49. (with-throw-handler #t
  50. (lambda ()
  51. (proc tmp)
  52. ;; Chmodding by name instead of by port allows this chmod to
  53. ;; work on systems without fchmod, like MinGW.
  54. (chmod template (logand #o0666 (lognot (umask))))
  55. (close-port tmp)
  56. (rename-file template filename))
  57. (lambda args
  58. (close-port tmp)
  59. (delete-file template)))))))
  60. (define (ensure-language x)
  61. (if (language? x)
  62. x
  63. (lookup-language x)))
  64. ;; Throws an exception if `dir' is not writable. The mkdir occurs
  65. ;; before the check, so that we avoid races (possibly due to parallel
  66. ;; compilation).
  67. ;;
  68. (define (ensure-directory dir)
  69. (catch 'system-error
  70. (lambda ()
  71. (mkdir dir))
  72. (lambda (k subr fmt args rest)
  73. (let ((errno (and (pair? rest) (car rest))))
  74. (cond
  75. ((eqv? errno EEXIST)
  76. ;; Assume it's a writable directory, to avoid TOCTOU errors,
  77. ;; as well as UID/EUID mismatches that occur with access(2).
  78. #t)
  79. ((eqv? errno ENOENT)
  80. (ensure-directory (dirname dir))
  81. (ensure-directory dir))
  82. (else
  83. (throw k subr fmt args rest)))))))
  84. ;;; This function is among the trickiest I've ever written. I tried many
  85. ;;; variants. In the end, simple is best, of course.
  86. ;;;
  87. ;;; After turning this around a number of times, it seems that the
  88. ;;; desired behavior is that .go files should exist in a path, for
  89. ;;; searching. That is orthogonal to this function. For writing .go
  90. ;;; files, either you know where they should go, in which case you tell
  91. ;;; compile-file explicitly, as in the srcdir != builddir case; or you
  92. ;;; don't know, in which case this function is called, and we just put
  93. ;;; them in your own ccache dir in ~/.cache/guile/ccache.
  94. ;;;
  95. ;;; See also boot-9.scm:load.
  96. (define (compiled-file-name file)
  97. ;; FIXME: would probably be better just to append SHA1(canon-path)
  98. ;; to the %compile-fallback-path, to avoid deep directory stats.
  99. (define (canonical->suffix canon)
  100. (cond
  101. ((string-prefix? "/" canon) canon)
  102. ((and (> (string-length canon) 2)
  103. (eqv? (string-ref canon 1) #\:))
  104. ;; Paths like C:... transform to /C...
  105. (string-append "/" (substring canon 0 1) (substring canon 2)))
  106. (else canon)))
  107. (define (compiled-extension)
  108. (cond ((or (null? %load-compiled-extensions)
  109. (string-null? (car %load-compiled-extensions)))
  110. (warn "invalid %load-compiled-extensions"
  111. %load-compiled-extensions)
  112. ".go")
  113. (else (car %load-compiled-extensions))))
  114. (and %compile-fallback-path
  115. (let ((f (string-append
  116. %compile-fallback-path
  117. (canonical->suffix (canonicalize-path file))
  118. (compiled-extension))))
  119. (and (false-if-exception (ensure-directory (dirname f)))
  120. f))))
  121. (define* (compile-file file #:key
  122. (output-file #f)
  123. (from (current-language))
  124. (to 'objcode)
  125. (env (default-environment from))
  126. (opts '())
  127. (canonicalization 'relative))
  128. (with-fluids ((%file-port-name-canonicalization canonicalization))
  129. (let* ((comp (or output-file (compiled-file-name file)
  130. (error "failed to create path for auto-compiled file"
  131. file)))
  132. (in (open-input-file file))
  133. (enc (file-encoding in)))
  134. ;; Choose the input encoding deterministically.
  135. (set-port-encoding! in (or enc "UTF-8"))
  136. (ensure-directory (dirname comp))
  137. (call-with-output-file/atomic comp
  138. (lambda (port)
  139. ((language-printer (ensure-language to))
  140. (read-and-compile in #:env env #:from from #:to to #:opts
  141. (cons* #:to-file? #t opts))
  142. port))
  143. file)
  144. comp)))
  145. (define* (compile-and-load file #:key (from (current-language)) (to 'value)
  146. (env (current-module)) (opts '())
  147. (canonicalization 'relative))
  148. (with-fluids ((%file-port-name-canonicalization canonicalization))
  149. (read-and-compile (open-input-file file)
  150. #:from from #:to to #:opts opts
  151. #:env env)))
  152. ;;;
  153. ;;; Compiler interface
  154. ;;;
  155. (define (compile-passes from to opts)
  156. (map cdr
  157. (or (lookup-compilation-order from to)
  158. (error "no way to compile" from "to" to))))
  159. (define (compile-fold passes exp env opts)
  160. (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
  161. (if (null? passes)
  162. (values x e cenv)
  163. (receive (x e new-cenv) ((car passes) x e opts)
  164. (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
  165. (define (find-language-joint from to)
  166. (let lp ((in (reverse (or (lookup-compilation-order from to)
  167. (error "no way to compile" from "to" to))))
  168. (lang to))
  169. (cond ((null? in) to)
  170. ((language-joiner lang) lang)
  171. (else
  172. (lp (cdr in) (caar in))))))
  173. (define (default-language-joiner lang)
  174. (lambda (exps env)
  175. (if (and (pair? exps) (null? (cdr exps)))
  176. (car exps)
  177. (error
  178. "Multiple expressions read and compiled, but language has no joiner"
  179. lang))))
  180. (define (read-and-parse lang port cenv)
  181. (let ((exp ((language-reader lang) port cenv)))
  182. (cond
  183. ((eof-object? exp) exp)
  184. ((language-parser lang) => (lambda (parse) (parse exp)))
  185. (else exp))))
  186. (define* (read-and-compile port #:key
  187. (from (current-language))
  188. (to 'objcode)
  189. (env (default-environment from))
  190. (opts '()))
  191. (let ((from (ensure-language from))
  192. (to (ensure-language to)))
  193. (let ((joint (find-language-joint from to)))
  194. (parameterize ((current-language from))
  195. (let lp ((exps '()) (env #f) (cenv env))
  196. (let ((x (read-and-parse (current-language) port cenv)))
  197. (cond
  198. ((eof-object? x)
  199. (close-port port)
  200. (compile ((or (language-joiner joint)
  201. (default-language-joiner joint))
  202. (reverse exps)
  203. env)
  204. #:from joint #:to to
  205. ;; env can be false if no expressions were read.
  206. #:env (or env (default-environment joint))
  207. #:opts opts))
  208. (else
  209. ;; compile-fold instead of compile so we get the env too
  210. (receive (jexp jenv jcenv)
  211. (compile-fold (compile-passes (current-language) joint opts)
  212. x cenv opts)
  213. (lp (cons jexp exps) jenv jcenv))))))))))
  214. (define* (compile x #:key
  215. (from (current-language))
  216. (to 'value)
  217. (env (default-environment from))
  218. (opts '()))
  219. (let ((warnings (memq #:warnings opts)))
  220. (if (pair? warnings)
  221. (let ((warnings (cadr warnings)))
  222. ;; Sanity-check the requested warnings.
  223. (for-each (lambda (w)
  224. (or (lookup-warning-type w)
  225. (warning 'unsupported-warning #f w)))
  226. warnings))))
  227. (receive (exp env cenv)
  228. (compile-fold (compile-passes from to opts) x env opts)
  229. exp))
  230. ;;;
  231. ;;; Decompiler interface
  232. ;;;
  233. (define (decompile-passes from to opts)
  234. (map cdr
  235. (or (lookup-decompilation-order from to)
  236. (error "no way to decompile" from "to" to))))
  237. (define (decompile-fold passes exp env opts)
  238. (if (null? passes)
  239. (values exp env)
  240. (receive (exp env) ((car passes) exp env opts)
  241. (decompile-fold (cdr passes) exp env opts))))
  242. (define* (decompile x #:key
  243. (env #f)
  244. (from 'value)
  245. (to 'assembly)
  246. (opts '()))
  247. (decompile-fold (decompile-passes from to opts)
  248. x
  249. env
  250. opts))