compile.scm 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381
  1. ;;; High-level compiler interface
  2. ;; Copyright (C) 2001,2005,2008-2013,2016,2020,2021 Free Software Foundation, Inc.
  3. ;;; This library is free software; you can redistribute it and/or modify it
  4. ;;; under the terms of the GNU Lesser General Public License as published by
  5. ;;; the Free Software Foundation; either version 3 of the License, or (at
  6. ;;; your option) any later version.
  7. ;;;
  8. ;;; This library is distributed in the hope that it will be useful, but
  9. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
  11. ;;; General Public License for more details.
  12. ;;;
  13. ;;; You should have received a copy of the GNU Lesser General Public License
  14. ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  15. ;;; Code:
  16. (define-module (system base compile)
  17. #:use-module (system base language)
  18. #:use-module (system base message)
  19. #:use-module (ice-9 receive)
  20. #:use-module (ice-9 match)
  21. #:use-module (srfi srfi-11)
  22. #:export (compiled-file-name
  23. compile-file
  24. compile-and-load
  25. compute-compiler
  26. read-and-compile
  27. compile
  28. decompile
  29. default-warning-level
  30. default-optimization-level))
  31. (define (level-validator x)
  32. (unless (and (exact-integer? x) (<= 0 x 9))
  33. (error
  34. "bad warning or optimization level: expected integer between 0 and 9"
  35. x))
  36. x)
  37. (define default-warning-level (make-parameter 1 level-validator))
  38. (define default-optimization-level (make-parameter 2 level-validator))
  39. ;;;
  40. ;;; Compiler
  41. ;;;
  42. (define (call-once thunk)
  43. (let ((entered #f))
  44. (dynamic-wind
  45. (lambda ()
  46. (when entered
  47. (error (format #f "thunk may only be entered once: ~a" thunk)))
  48. (set! entered #t))
  49. thunk
  50. (lambda () #t))))
  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* ((tmp (mkstemp (string-append filename ".XXXXXX") "wb"))
  54. (tmpname (port-filename tmp)))
  55. (call-once
  56. (lambda ()
  57. (with-throw-handler #t
  58. (lambda ()
  59. (proc tmp)
  60. ;; Chmodding by name instead of by port allows this chmod to
  61. ;; work on systems without fchmod, like MinGW.
  62. (let ((perms (or (false-if-exception (stat:perms (stat reference)))
  63. (lognot (umask)))))
  64. (chmod tmpname (logand #o0666 perms)))
  65. (close-port tmp)
  66. (rename-file tmpname filename))
  67. (lambda args
  68. (close-port tmp)
  69. (delete-file tmpname)))))))
  70. (define (ensure-language x)
  71. (if (language? x)
  72. x
  73. (lookup-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
  76. ;; compilation).
  77. ;;
  78. (define (ensure-directory dir)
  79. (catch 'system-error
  80. (lambda ()
  81. (mkdir dir))
  82. (lambda (k subr fmt args rest)
  83. (let ((errno (and (pair? rest) (car rest))))
  84. (cond
  85. ((eqv? errno EEXIST)
  86. ;; Assume it's a writable directory, to avoid TOCTOU errors,
  87. ;; as well as UID/EUID mismatches that occur with access(2).
  88. #t)
  89. ((eqv? errno ENOENT)
  90. (ensure-directory (dirname dir))
  91. (ensure-directory dir))
  92. (else
  93. (throw k subr fmt args rest)))))))
  94. ;;; This function is among the trickiest I've ever written. I tried many
  95. ;;; variants. In the end, simple is best, of course.
  96. ;;;
  97. ;;; After turning this around a number of times, it seems that the
  98. ;;; desired behavior is that .go files should exist in a path, for
  99. ;;; searching. That is orthogonal to this function. For writing .go
  100. ;;; files, either you know where they should go, in which case you tell
  101. ;;; compile-file explicitly, as in the srcdir != builddir case; or you
  102. ;;; don't know, in which case this function is called, and we just put
  103. ;;; them in your own ccache dir in ~/.cache/guile/ccache.
  104. ;;;
  105. ;;; See also boot-9.scm:load.
  106. (define (compiled-file-name file)
  107. ;; FIXME: would probably be better just to append SHA1(canon-path)
  108. ;; to the %compile-fallback-path, to avoid deep directory stats.
  109. (define (canonical->suffix canon)
  110. (cond
  111. ((string-prefix? "/" canon) canon)
  112. ((and (> (string-length canon) 2)
  113. (eqv? (string-ref canon 1) #\:))
  114. ;; Paths like C:... transform to /C...
  115. (string-append "/" (substring canon 0 1) (substring canon 2)))
  116. (else canon)))
  117. (define (compiled-extension)
  118. (cond ((or (null? %load-compiled-extensions)
  119. (string-null? (car %load-compiled-extensions)))
  120. (warn "invalid %load-compiled-extensions"
  121. %load-compiled-extensions)
  122. ".go")
  123. (else (car %load-compiled-extensions))))
  124. (and %compile-fallback-path
  125. (let ((f (string-append
  126. %compile-fallback-path
  127. (canonical->suffix (canonicalize-path file))
  128. (compiled-extension))))
  129. (and (false-if-exception (ensure-directory (dirname f)))
  130. f))))
  131. (define (validate-options opts)
  132. (define (validate-warnings warnings)
  133. (match warnings
  134. (() (values))
  135. ((w . warnings)
  136. (unless (lookup-warning-type w)
  137. (warning 'unsupported-warning #f w))
  138. (validate-warnings warnings))))
  139. (match opts
  140. (() (values))
  141. ((kw arg . opts)
  142. (match kw
  143. (#:warnings (validate-warnings arg))
  144. ((? keyword?) (values))
  145. (_
  146. ;; Programming error.
  147. (warn "malformed options list: not a keyword" kw)))
  148. (validate-options opts))
  149. (_
  150. ;; Programming error.
  151. (warn "malformed options list: expected keyword and arg pair" opts))))
  152. (define* (compile-file file #:key
  153. (output-file #f)
  154. (from (current-language))
  155. (to 'bytecode)
  156. (env (default-environment from))
  157. (optimization-level (default-optimization-level))
  158. (warning-level (default-warning-level))
  159. (opts '())
  160. (canonicalization 'relative))
  161. (validate-options opts)
  162. (with-fluids ((%file-port-name-canonicalization canonicalization))
  163. (let* ((comp (or output-file (compiled-file-name file)
  164. (error "failed to create path for auto-compiled file"
  165. file)))
  166. (in (open-input-file file))
  167. (enc (file-encoding in)))
  168. ;; Choose the input encoding deterministically.
  169. (set-port-encoding! in (or enc "UTF-8"))
  170. (ensure-directory (dirname comp))
  171. (call-with-output-file/atomic comp
  172. (lambda (port)
  173. ((language-printer (ensure-language to))
  174. (read-and-compile in #:env env #:from from #:to to
  175. #:optimization-level optimization-level
  176. #:warning-level warning-level
  177. #:opts (cons* #:to-file? #t opts))
  178. port))
  179. file)
  180. comp)))
  181. (define* (compile-and-load file #:key (from (current-language)) (to 'value)
  182. (env (current-module))
  183. (optimization-level (default-optimization-level))
  184. (warning-level (default-warning-level))
  185. (opts '())
  186. (canonicalization 'relative))
  187. (validate-options opts)
  188. (with-fluids ((%file-port-name-canonicalization canonicalization))
  189. (read-and-compile (open-input-file file)
  190. #:from from #:to to #:opts opts
  191. #:optimization-level optimization-level
  192. #:warning-level warning-level
  193. #:env env)))
  194. ;;;
  195. ;;; Compiler interface
  196. ;;;
  197. (define (compute-analyzer lang warning-level opts)
  198. (level-validator warning-level)
  199. (match (language-analyzer lang)
  200. (#f (lambda (exp env) (values)))
  201. (proc (proc warning-level
  202. (let lp ((opts opts))
  203. (match opts
  204. (() '())
  205. ((#:warnings warnings . _) warnings)
  206. ((_ _ . opts) (lp opts))))))))
  207. (define (compute-lowerer lang optimization-level opts)
  208. (level-validator optimization-level)
  209. (match (language-lowerer lang)
  210. (#f (lambda (exp env) exp))
  211. (proc (proc optimization-level opts))))
  212. (define (next-pass from lang to optimization-level opts)
  213. (if (eq? lang to)
  214. #f ;; Done.
  215. (match (language-compilers lang)
  216. (((name . pass))
  217. (cons (lookup-language name) pass))
  218. (compilers
  219. (let ((chooser (language-compiler-chooser lang)))
  220. (unless chooser
  221. (if (null? compilers)
  222. (error "no way to compile" from "to" to)
  223. (error "multiple compilers; language should supply chooser")))
  224. (match (chooser to optimization-level opts)
  225. ((name . pass)
  226. (cons (lookup-language name) pass))))))))
  227. (define (compute-compiler from to optimization-level warning-level opts)
  228. (let ((from (ensure-language from))
  229. (to (ensure-language to)))
  230. (let lp ((lang from))
  231. (match (next-pass from lang to optimization-level opts)
  232. (#f (lambda (exp env) (values exp env env)))
  233. ((next . pass)
  234. (let* ((analyze (compute-analyzer lang warning-level opts))
  235. (lower (compute-lowerer lang optimization-level opts))
  236. (compile (lambda (exp env)
  237. (analyze exp env)
  238. (pass (lower exp env) env opts)))
  239. (tail (lp next)))
  240. (lambda (exp env)
  241. (let*-values (((exp env cenv) (compile exp env))
  242. ((exp env cenv*) (tail exp env)))
  243. ;; Return continuation environment from first pass, to
  244. ;; compile an additional expression in the same compilation
  245. ;; unit.
  246. (values exp env cenv)))))))))
  247. (define (find-language-joint from to optimization-level opts)
  248. (let ((from (ensure-language from))
  249. (to (ensure-language to)))
  250. (let lp ((lang from))
  251. (match (next-pass from lang to optimization-level opts)
  252. (#f #f)
  253. ((next . pass)
  254. (or (lp next)
  255. (and (language-joiner next)
  256. next)))))))
  257. (define (default-language-joiner lang)
  258. (lambda (exps env)
  259. (match exps
  260. ((exp) exp)
  261. (_
  262. (error
  263. "Multiple expressions read and compiled, but language has no joiner"
  264. lang)))))
  265. (define (read-and-parse lang port cenv)
  266. (let ((exp ((language-reader lang) port cenv)))
  267. (cond
  268. ((eof-object? exp) exp)
  269. ((language-parser lang) => (lambda (parse) (parse exp)))
  270. (else exp))))
  271. (define* (read-and-compile port #:key
  272. (from (current-language))
  273. (to 'bytecode)
  274. (env (default-environment from))
  275. (optimization-level (default-optimization-level))
  276. (warning-level (default-warning-level))
  277. (opts '()))
  278. (let* ((from (ensure-language from))
  279. (to (ensure-language to))
  280. (joint (find-language-joint from to optimization-level opts)))
  281. (parameterize ((current-language from))
  282. (let lp ((exps '()) (env #f) (cenv env) (from #f) (compile1 #f))
  283. (match (read-and-parse (current-language) port cenv)
  284. ((? eof-object?)
  285. (close-port port)
  286. (if joint
  287. (compile ((or (language-joiner joint)
  288. (default-language-joiner joint))
  289. (reverse exps)
  290. env)
  291. #:from joint #:to to
  292. ;; env can be false if no expressions were read.
  293. #:env (or env (default-environment joint))
  294. #:optimization-level optimization-level
  295. #:warning-level warning-level
  296. #:opts opts)
  297. ((default-language-joiner to)
  298. (reverse exps)
  299. env)))
  300. (exp
  301. (let with-compiler ((from from) (compile1 compile1))
  302. (cond
  303. ((eq? from (current-language))
  304. (receive (exp env cenv) (compile1 exp cenv)
  305. (lp (cons exp exps) env cenv from compile1)))
  306. (else
  307. ;; compute-compiler instead of compile so we get the
  308. ;; env too.
  309. (let ((from (current-language)))
  310. (with-compiler
  311. from
  312. (compute-compiler from (or joint to) optimization-level
  313. warning-level opts))))))))))))
  314. (define* (compile x #:key
  315. (from (current-language))
  316. (to 'value)
  317. (env (default-environment from))
  318. (optimization-level (default-optimization-level))
  319. (warning-level (default-warning-level))
  320. (opts '()))
  321. (validate-options opts)
  322. (let ((compile1 (compute-compiler from to optimization-level
  323. warning-level opts)))
  324. (receive (exp env cenv) (compile1 x env)
  325. exp)))
  326. ;;;
  327. ;;; Decompiler interface
  328. ;;;
  329. (define (decompile-passes from to opts)
  330. (match (lookup-decompilation-order from to)
  331. (((langs . passes) ...) passes)
  332. (_ (error "no way to decompile" from "to" to))))
  333. (define (decompile-fold passes exp env opts)
  334. (match passes
  335. (() (values exp env))
  336. ((pass . passes)
  337. (receive (exp env) (pass exp env opts)
  338. (decompile-fold passes exp env opts)))))
  339. (define* (decompile x #:key
  340. (env #f)
  341. (from 'tree-il)
  342. (to 'scheme)
  343. (opts '()))
  344. (decompile-fold (decompile-passes from to opts)
  345. x
  346. env
  347. opts))