d0b405ac8b
- added invoke-library
syntax.ss, primdata.ss,
8.ms, root-experr*,
libraries.stex, release_notes.stex
- updated the date
release_notes.stex
- libraries contained within a whole program or library are now
marked pending before their invoke code is run so that invoke
cycles are reported as such rather than as attempts to invoke
while still loading.
compile.ss, syntax.ss, primdata.ss,
7.ms, root-experr*
- the library manager now protects against unbound references
from separately compiled libraries or programs to identifiers
ostensibly but not actually exported by (invisible) libraries
that exist only locally within a whole program. this is done by
marking the invisibility of the library in the library-info and
propagating it to libdesc records; the latter is checked upon
library import, visit, and invoke as well as by verify-loadability.
the import and visit code of each invisible no longer complains
about invisibility since it shouldn't be reachable.
syntax.ss, compile.ss, expand-lang.ss,
7.ms, 8.ms, root-experr*, patch*
- documented that compile-whole-xxx's linearization of the
library initialization code based on static dependencies might
not work for dynamic dependencies.
system.stex
- optimized bignum right shifts so the code (1) doesn't look at
shifted-off bigits if the bignum is positive, since it doesn't
need to know in that case if any bits are set; (2) doesn't look
at shifted-off bigits if the bignum is negative if it determines
that at least one bit is set in the bits shifted off the low-order
partially retained bigit; (3) quits looking, if it must look, for
one bits as soon as it finds one; (4) looks from both ends under
the assumption that set bits, if any, are most likely to be found
toward the high or low end of the bignum rather than just in the
middle; and (5) doesn't copy the retained bigits and then shift;
rather shifts as it copies. This leads to dramatic improvements
when the shift count is large and often significant improvements
otherwise.
number.c,
5_3.ms,
release_notes.stex
- threaded tc argument through to all calls to S_bignum and
S_trunc_rem so they don't have to call get_thread_context()
when it might already have been called.
alloc.c, number.c, fasl.c, print.c, prim5.c, externs.h
- added an expand-primitive handler to partially inline integer?.
cpnanopass.ss
- added some special cases for basic arithmetic operations (+, -, *,
/, quotient, remainder, and the div/div0/mod/mod0 operations) to
avoid doing unnecessary work for large bignums when the result
will be zero (e.g,. multiplying by 0), the same as one of the
inputs (e.g., adding 0 or multiplying by 1), or the additive
inverse of one of the inputs (e.g., subtracting from 0, dividing
by -1). This can have a major beneficial affect when operating
on large bignums in the cases handled. also converted some uses
of / into integer/ where going through the former would just add
overhead without the possibility of optimization.
5_3.ss,
number.c, externs.h, prim5.c,
5_3.ms, root-experr, patch*,
release_notes.stex
- added a queue to hold pending signals for which handlers have
been registered via register-signal-handler so up to 63 (configurable
in the source code) unhandled signals are buffered before the
handler has to start dropping them.
cmacros.ss, library.ss, prims.ss, primdata.ss,
schsig.c, externs.h, prim5.c, thread.c, gc.c,
unix.ms,
system.stex, release_notes.stex
- bytevector-compress now selects the level of compression based
on the compress-level parameter. Prior to this it always used a
default setting for compression. the compress-level parameter
can now take on the new minimum in addition to low, medium, high,
and maximum. minimum is presently treated the same as low
except in the case of lz4 bytevector compression, where it
results in the use of LZ4_compress_default rather than the
slower but more effective LZ4_compress_HC.
cmacros,ss, back.ss,
compress_io.c, new_io.c, externs.h,
bytevector.ms, mats/Mf-base, root-experr*
io.stex, objects.stex, release_notes.stex
original commit: 72d90e4c67849908da900d0b6249a1dedb5f8c7f
2139 lines
104 KiB
Scheme
2139 lines
104 KiB
Scheme
"compile.ss"
|
|
;;; compile.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
;;; use fixnum arithmetic in code building & output routines
|
|
|
|
(define compile)
|
|
(define $compile-backend)
|
|
(define compile-file)
|
|
(define $c-make-code)
|
|
(define make-boot-header)
|
|
(define make-boot-file)
|
|
|
|
(let ()
|
|
(import (nanopass))
|
|
(include "types.ss")
|
|
(include "base-lang.ss")
|
|
(include "expand-lang.ss")
|
|
|
|
; for tracing:
|
|
#;(define-syntax do-trace
|
|
(syntax-rules ()
|
|
((_ . r) (trace-output . r))))
|
|
; no tracing:
|
|
(define-syntax do-trace
|
|
(syntax-rules ()
|
|
((_ . r) r)))
|
|
|
|
(define trace-output
|
|
(lambda (fun . args)
|
|
(when ($assembly-output)
|
|
(fprintf ($assembly-output) "~s ====>~%" ($procedure-name fun)))
|
|
(let ([x (apply fun args)])
|
|
(when ($assembly-output)
|
|
(parameterize ([print-graph #t])
|
|
(pretty-print x ($assembly-output))
|
|
(newline ($assembly-output))))
|
|
x)))
|
|
|
|
(define cheat?
|
|
(lambda (x)
|
|
(nanopass-case (Lsrc Expr) x
|
|
[,pr #t]
|
|
[(quote ,d) #t]
|
|
[(if ,e0 ,e1 ,e2) (and (cheat? e0) (cheat? e1) (cheat? e2))]
|
|
[(seq ,e1 ,e2) (and (cheat? e1) (cheat? e2))]
|
|
[(call ,preinfo ,e ,e* ...)
|
|
(and (andmap cheat? e*) (cheat? e))]
|
|
[else #f])))
|
|
|
|
(define cheat-eval
|
|
(rec compile
|
|
(lambda (x)
|
|
(nanopass-case (Lsrc Expr) x
|
|
[,pr ($top-level-value (primref-name pr))]
|
|
[(quote ,d) d]
|
|
[(if ,e0 ,e1 ,e2)
|
|
(compile (if (compile e0) e1 e2))]
|
|
[(seq ,e1 ,e2) (compile e1) (compile e2)]
|
|
[(call ,preinfo ,e ,e* ...)
|
|
(#2%apply (compile e) (map compile e*))]
|
|
[else ($oops #f "unexpected form ~s" x)]))))
|
|
|
|
(define c-compile
|
|
(lambda (x)
|
|
(with-output-language (Lsrc Expr)
|
|
($c-make-closure
|
|
; pretending main is a library routine to avoid argument-count check
|
|
(let ([x `(case-lambda ,(make-preinfo-lambda #f #f (lookup-libspec main)) (clause () 0 ,x))])
|
|
($np-compile x #f))))))
|
|
|
|
(define c-set-code-quad!
|
|
(foreign-procedure "(cs)s_set_code_quad"
|
|
(scheme-object scheme-object scheme-object)
|
|
void))
|
|
|
|
(define lookup-c-entry-index
|
|
(foreign-procedure "(cs)lookup_c_entry"
|
|
(iptr)
|
|
scheme-object))
|
|
|
|
(define-who (c-mkcode x)
|
|
(define (mkcode x)
|
|
(record-case x
|
|
[(object) (x) x]
|
|
[(entry) (i) (lookup-c-entry-index i)]
|
|
[(library) (x) ($lookup-library-entry (libspec-index x) #t)]
|
|
[(library-code) (x)
|
|
($closure-code ($lookup-library-entry (libspec-index x) #t))]
|
|
[(closure) func
|
|
; call mkcode on code record first or we might set func-closure field multiple times
|
|
(let ([cp (mkcode ($c-func-code-record func))])
|
|
; i.e., the remainder must be atomic wrt mkcode
|
|
(or ($c-func-closure func)
|
|
(let ([p ($make-closure (constant code-data-disp) cp)])
|
|
(set-$c-func-closure! func p)
|
|
p)))]
|
|
[(code) (func subtype free name arity-mask size code-list info pinfo*)
|
|
(or ($c-func-code-object func)
|
|
(let ([p ($make-code-object subtype free name arity-mask size info pinfo*)])
|
|
(set-$c-func-code-object! func p)
|
|
(let mkc0 ([c* code-list]
|
|
[a (constant code-data-disp)]
|
|
[r* '()]
|
|
[ra 0]
|
|
[x* '()])
|
|
(if (null? c*)
|
|
($make-relocation-table! p (reverse r*) (reverse x*))
|
|
(let ([c (car c*)])
|
|
(record-case c
|
|
[(word) n
|
|
($set-code-word! p a n)
|
|
(mkc0 (cdr c*) (fx+ a 2) r* ra x*)]
|
|
[(byte) n
|
|
($set-code-byte! p a n)
|
|
(mkc0 (cdr c*) (fx+ a 1) r* ra x*)]
|
|
[(long) n
|
|
($set-code-long! p a n)
|
|
(mkc0 (cdr c*) (fx+ a 4) r* ra x*)]
|
|
[(quad) n
|
|
($set-code-quad! p a n)
|
|
(mkc0 (cdr c*) (fx+ a 8) r* ra x*)]
|
|
[(code-top-link) ()
|
|
(constant-case ptr-bits
|
|
[(64)
|
|
($set-code-quad! p a a)
|
|
(mkc0 (cdr c*) (fx+ a 8) r* ra x*)]
|
|
[(32)
|
|
($set-code-long! p a a)
|
|
(mkc0 (cdr c*) (fx+ a 4) r* ra x*)])]
|
|
[(abs) (n x)
|
|
(let ([x* (cons (mkcode x) x*)])
|
|
(let ([r ($reloc (constant reloc-abs) n (fx- a ra))])
|
|
(constant-case ptr-bits
|
|
[(64) (mkc0 (cdr c*) (fx+ a 8) (cons r r*) a x*)]
|
|
[(32) (mkc0 (cdr c*) (fx+ a 4) (cons r r*) a x*)])))]
|
|
[else
|
|
(constant-case architecture
|
|
[(x86)
|
|
(record-case c
|
|
[(rel) (n x)
|
|
(let ([x* (cons (mkcode x) x*)])
|
|
(let ([r ($reloc (constant reloc-rel) n (fx- a ra))])
|
|
(mkc0 (cdr c*) (fx+ a 4) (cons r r*) a x*)))]
|
|
[else (c-assembler-output-error c)])]
|
|
[(arm32)
|
|
(record-case c
|
|
[(arm32-abs) (n x)
|
|
; on ARMV7 would be 8: 4-byte movi, 4-byte movt
|
|
(let ([a1 (fx- a 12)]) ; 4-byte ldr, 4-byte bra, 4-byte value
|
|
(let ([x* (cons (mkcode x) x*)])
|
|
(let ([r ($reloc (constant reloc-arm32-abs) n (fx- a1 ra))])
|
|
(mkc0 (cdr c*) a (cons r r*) a1 x*))))]
|
|
[(arm32-call) (n x)
|
|
; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte blx
|
|
(let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte blx
|
|
(let ([x* (cons (mkcode x) x*)])
|
|
(let ([r ($reloc (constant reloc-arm32-call) n (fx- a1 ra))])
|
|
(mkc0 (cdr c*) a (cons r r*) a1 x*))))]
|
|
[(arm32-jump) (n x)
|
|
; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte bx
|
|
(let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte bx
|
|
(let ([x* (cons (mkcode x) x*)])
|
|
(let ([r ($reloc (constant reloc-arm32-jump) n (fx- a1 ra))])
|
|
(mkc0 (cdr c*) a (cons r r*) a1 x*))))]
|
|
[else (c-assembler-output-error c)])]
|
|
[(ppc32)
|
|
(record-case c
|
|
[(ppc32-abs) (n x)
|
|
(let ([a1 (fx- a 8)])
|
|
(let ([x* (cons (mkcode x) x*)])
|
|
(let ([r ($reloc (constant reloc-ppc32-abs) n (fx- a1 ra))])
|
|
(mkc0 (cdr c*) a (cons r r*) a1 x*))))]
|
|
[(ppc32-call) (n x)
|
|
(let ([a1 (fx- a 16)])
|
|
(let ([x* (cons (mkcode x) x*)])
|
|
(let ([r ($reloc (constant reloc-ppc32-call) n (fx- a1 ra))])
|
|
(mkc0 (cdr c*) a (cons r r*) a1 x*))))]
|
|
[(ppc32-jump) (n x)
|
|
(let ([a1 (fx- a 16)])
|
|
(let ([x* (cons (mkcode x) x*)])
|
|
(let ([r ($reloc (constant reloc-ppc32-jump) n (fx- a1 ra))])
|
|
(mkc0 (cdr c*) a (cons r r*) a1 x*))))]
|
|
[else (c-assembler-output-error c)])]
|
|
[(x86_64)
|
|
(record-case c
|
|
[(x86_64-jump) (n x)
|
|
(let ([a1 (fx- a 12)] [x* (cons (mkcode x) x*)])
|
|
(let ([r ($reloc (constant reloc-x86_64-jump) n (fx- a1 ra))])
|
|
(mkc0 (cdr c*) a (cons r r*) a1 x*)))]
|
|
[(x86_64-call) (n x)
|
|
(let ([a1 (fx- a 12)] [x* (cons (mkcode x) x*)])
|
|
(let ([r ($reloc (constant reloc-x86_64-call) n (fx- a1 ra))])
|
|
(mkc0 (cdr c*) a (cons r r*) a1 x*)))]
|
|
[else (c-assembler-output-error c)])]
|
|
[else (c-assembler-output-error c)])]))))
|
|
p))]
|
|
[else (c-assembler-output-error x)]))
|
|
; rationale for the critical section:
|
|
; (1) the code objects we create here may be mutually recursive, and we
|
|
; need for them all to be in the same generation.
|
|
; (2) code objects are created without relocation tables, and linked
|
|
; after relocation tables are added, potentially confusing the
|
|
; collector. this could be addressed by maintaining a LINKED flag
|
|
; in the code-object header.
|
|
; (3) we record code modifications as code objects are allocated, then
|
|
; flush once at the end to avoid multiple flushes.
|
|
; rationale for the dynamic-wind:
|
|
; we have to flush the instruction cache even if mkcode errors out or is
|
|
; interrupted with a noncontinuable interrupt so that no code modifications
|
|
; are recorded for code objects that have been dropped and for which the
|
|
; memory containing them has been returned to the O/S.
|
|
(critical-section
|
|
(dynamic-wind
|
|
void
|
|
(lambda () (mkcode x))
|
|
$flush-instruction-cache)))
|
|
|
|
(define c-build-fasl
|
|
(lambda (x t a?)
|
|
(let build ([x x])
|
|
(record-case x
|
|
[(object) (x) ($fasl-enter x t a?)]
|
|
[(closure) func
|
|
($fasl-bld-graph x t a?
|
|
(lambda (x t a?)
|
|
(build ($c-func-code-record func))))]
|
|
[(code) stuff
|
|
($fasl-bld-graph x t a?
|
|
(lambda (x t a?)
|
|
(record-case x
|
|
[(code) (func subtype free name arity-mask size code-list info pinfo*)
|
|
($fasl-enter name t a?)
|
|
($fasl-enter arity-mask t a?)
|
|
($fasl-enter info t a?)
|
|
($fasl-enter pinfo* t a?)
|
|
(for-each
|
|
(lambda (x)
|
|
(record-case x
|
|
[(abs) (n x) (build x)]
|
|
[else
|
|
(constant-case architecture
|
|
[(x86)
|
|
(record-case x
|
|
[(rel) (n x) (build x)]
|
|
[else (void)])]
|
|
[(x86_64)
|
|
(record-case x
|
|
[(x86_64-jump x86_64-call) (n x) (build x)]
|
|
[else (void)])]
|
|
[(arm32)
|
|
(record-case x
|
|
[(arm32-abs arm32-call arm32-jump) (n x) (build x)]
|
|
[else (void)])]
|
|
[(ppc32)
|
|
(record-case x
|
|
[(ppc32-abs ppc32-call ppc32-jump) (n x) (build x)]
|
|
[else (void)])])]))
|
|
code-list)])))]))))
|
|
|
|
(include "fasl-helpers.ss")
|
|
|
|
(define c-assembler-output-error
|
|
(lambda (x)
|
|
($oops 'compile-internal
|
|
"invalid assembler output ~s"
|
|
x)))
|
|
|
|
(define (c-faslobj x t p a?)
|
|
(let faslobj ([x x])
|
|
(record-case x
|
|
[(object) (x) ($fasl-out x p t a?)]
|
|
[(entry) (i)
|
|
(put-u8 p (constant fasl-type-entry))
|
|
(put-uptr p i)]
|
|
[(library) (x)
|
|
(put-u8 p (constant fasl-type-library))
|
|
(put-uptr p (libspec-index x))]
|
|
[(library-code) (x)
|
|
(put-u8 p (constant fasl-type-library-code))
|
|
(put-uptr p (libspec-index x))]
|
|
[(closure) func
|
|
($fasl-wrf-graph x p t a?
|
|
(lambda (x p t a?)
|
|
(put-u8 p (constant fasl-type-closure))
|
|
(put-uptr p (constant code-data-disp))
|
|
(faslobj ($c-func-code-record func))))]
|
|
[(code) (func subtype free name arity-mask size code-list info pinfo*)
|
|
($fasl-wrf-graph x p t a?
|
|
(lambda (x p t a?)
|
|
(put-u8 p (constant fasl-type-code))
|
|
(put-u8 p subtype)
|
|
(put-uptr p free)
|
|
(put-uptr p size)
|
|
($fasl-out name p t a?)
|
|
($fasl-out arity-mask p t a?)
|
|
($fasl-out info p t a?)
|
|
($fasl-out pinfo* p t a?)
|
|
(let prf0 ([c* code-list]
|
|
[a (constant code-data-disp)]
|
|
[r* '()]
|
|
[ra 0]
|
|
[x* '()])
|
|
(if (null? c*)
|
|
(begin
|
|
(let ([actual-size (- a (constant code-data-disp))])
|
|
(unless (= actual-size size)
|
|
($oops 'c-faslcode
|
|
"wrote ~s bytes, expected ~s bytes"
|
|
actual-size size)))
|
|
(put-uptr p (fold-left (lambda (m r) (fx+ m (if (reloc-long? r) 3 1))) 0 r*))
|
|
(for-each
|
|
(lambda (r x)
|
|
(let ([item-offset (reloc-item-offset r)])
|
|
(put-u8 p
|
|
(let* ([k (fxsll (reloc-type r) 2)]
|
|
[k (if (eqv? item-offset 0) k (fxlogor k 2))])
|
|
(if (reloc-long? r) (fxlogor k 1) k)))
|
|
(put-uptr p (reloc-code-offset r))
|
|
(unless (eqv? item-offset 0) (put-uptr p item-offset))
|
|
(faslobj x)))
|
|
(reverse r*)
|
|
(reverse x*)))
|
|
(let ([c (car c*)])
|
|
(record-case c
|
|
[(word) n
|
|
(put16 p n)
|
|
(prf0 (cdr c*) (fx+ a 2) r* ra x*)]
|
|
[(byte) n
|
|
(put8 p n)
|
|
(prf0 (cdr c*) (fx+ a 1) r* ra x*)]
|
|
[(long) n
|
|
(put32 p n)
|
|
(prf0 (cdr c*) (fx+ a 4) r* ra x*)]
|
|
[(quad) n
|
|
(put64 p n)
|
|
(prf0 (cdr c*) (fx+ a 8) r* ra x*)]
|
|
[(code-top-link) ()
|
|
(constant-case ptr-bits
|
|
[(64)
|
|
(put64 p a)
|
|
(prf0 (cdr c*) (fx+ a 8) r* ra x*)]
|
|
[(32)
|
|
(put32 p a)
|
|
(prf0 (cdr c*) (fx+ a 4) r* ra x*)])]
|
|
[(abs) (n x)
|
|
(let ([r ($reloc (constant reloc-abs) n (fx- a ra))])
|
|
(constant-case ptr-bits
|
|
[(64)
|
|
(put64 p 0)
|
|
(prf0 (cdr c*) (fx+ a 8) (cons r r*) a (cons x x*))]
|
|
[(32)
|
|
(put32 p 0)
|
|
(prf0 (cdr c*) (fx+ a 4) (cons r r*) a (cons x x*))]))]
|
|
[else
|
|
(constant-case architecture
|
|
[(x86)
|
|
(record-case c
|
|
[(rel) (n x)
|
|
(put32 p 0)
|
|
(let ([r ($reloc (constant reloc-rel) n (fx- a ra))])
|
|
(prf0 (cdr c*) (fx+ a 4) (cons r r*) a (cons x x*)))]
|
|
[else (c-assembler-output-error c)])]
|
|
[(arm32)
|
|
(record-case c
|
|
[(arm32-abs) (n x)
|
|
; on ARMV7 would be 8: 4-byte movi, 4-byte movt
|
|
(let ([a1 (fx- a 12)]) ; 4-byte ldr, 4-byte bra, 4-byte value
|
|
(let ([r ($reloc (constant reloc-arm32-abs) n (fx- a1 ra))])
|
|
(prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
|
|
[(arm32-call) (n x)
|
|
; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte blx
|
|
(let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte blx
|
|
(let ([r ($reloc (constant reloc-arm32-call) n (fx- a1 ra))])
|
|
(prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
|
|
[(arm32-jump) (n x)
|
|
; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte bx
|
|
(let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte bx
|
|
(let ([r ($reloc (constant reloc-arm32-jump) n (fx- a1 ra))])
|
|
(prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
|
|
[else (c-assembler-output-error c)])]
|
|
[(ppc32)
|
|
(record-case c
|
|
[(ppc32-abs) (n x)
|
|
(let ([a1 (fx- a 8)])
|
|
(let ([r ($reloc (constant reloc-ppc32-abs) n (fx- a1 ra))])
|
|
(prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
|
|
[(ppc32-call) (n x)
|
|
(let ([a1 (fx- a 16)])
|
|
(let ([r ($reloc (constant reloc-ppc32-call) n (fx- a1 ra))])
|
|
(prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
|
|
[(ppc32-jump) (n x)
|
|
(let ([a1 (fx- a 16)])
|
|
(let ([r ($reloc (constant reloc-ppc32-jump) n (fx- a1 ra))])
|
|
(prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
|
|
[else (c-assembler-output-error c)])]
|
|
[(x86_64)
|
|
(record-case c
|
|
[(x86_64-jump) (n x)
|
|
(let ([a1 (fx- a 12)]) ; 10-byte moviq followed by 2-byte jmp
|
|
(let ([r ($reloc (constant reloc-x86_64-jump) n (fx- a1 ra))])
|
|
(prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
|
|
[(x86_64-call) (n x)
|
|
(let ([a1 (fx- a 12)]) ; 10-byte moviq followed by 2-byte call
|
|
(let ([r ($reloc (constant reloc-x86_64-call) n (fx- a1 ra))])
|
|
(prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
|
|
[else (c-assembler-output-error c)])]
|
|
[else (c-assembler-output-error c)])]))))))]
|
|
[else (c-assembler-output-error x)])))
|
|
|
|
(define (c-print-fasl x p situation)
|
|
(let ([t ($fasl-table)]
|
|
[a? (let ([flags (fxlogor
|
|
(if (generate-inspector-information) (constant annotation-debug) 0)
|
|
(if (eq? ($compile-profile) 'source) (constant annotation-profile) 0))])
|
|
(and (not (fx= flags 0)) flags))])
|
|
(c-build-fasl x t a?)
|
|
($fasl-start p t situation
|
|
(lambda (p) (c-faslobj x t p a?)))))
|
|
|
|
(define-record-type visit-chunk
|
|
(nongenerative)
|
|
(fields chunk))
|
|
|
|
(define-record-type revisit-chunk
|
|
(nongenerative)
|
|
(fields chunk))
|
|
|
|
(define-who (host-machine-type)
|
|
(let ([m (machine-type)])
|
|
(let lookup ([ra* (constant machine-type-alist)])
|
|
(if (null? ra*)
|
|
($oops who "unrecognized machine type ~s" m)
|
|
(if (eq? (cdar ra*) m) (caar ra*) (lookup (cdr ra*)))))))
|
|
|
|
(define with-whacked-optimization-locs
|
|
(lambda (x1 th)
|
|
(define ht (make-eq-hashtable))
|
|
(define-pass whack! : Lexpand (ir f) -> * ()
|
|
(Outer : Outer (ir) -> * ()
|
|
[,inner (Inner ir)]
|
|
[(group ,[] ,[]) (values)]
|
|
[(visit-only ,[]) (values)]
|
|
[(revisit-only ,[]) (values)]
|
|
[else (values)])
|
|
(Inner : Inner (ir) -> * ()
|
|
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
|
(for-each f db*)
|
|
(values)]
|
|
[else (values)]))
|
|
(whack! x1
|
|
(lambda (db)
|
|
(when db
|
|
(eq-hashtable-set! ht db (unbox db))
|
|
(set-box! db '()))))
|
|
(th)
|
|
(whack! x1
|
|
(lambda (db)
|
|
(when db
|
|
(set-box! db (eq-hashtable-ref ht db '())))))))
|
|
|
|
(define check-prelex-flags
|
|
(lambda (x after)
|
|
(when ($enable-check-prelex-flags)
|
|
($pass-time 'cpcheck-prelex-flags (lambda () (do-trace $cpcheck-prelex-flags x after))))))
|
|
|
|
(define compile-file-help
|
|
(lambda (op hostop wpoop source-table machine sfd do-read outfn)
|
|
(parameterize ([$target-machine machine]
|
|
[$sfd sfd]
|
|
[$current-mso ($current-mso)]
|
|
[$block-counter 0]
|
|
[optimize-level (optimize-level)]
|
|
[debug-level (debug-level)]
|
|
[run-cp0 (run-cp0)]
|
|
[cp0-effort-limit (cp0-effort-limit)]
|
|
[cp0-score-limit (cp0-score-limit)]
|
|
[cp0-outer-unroll-limit (cp0-outer-unroll-limit)]
|
|
[generate-inspector-information (generate-inspector-information)]
|
|
[generate-procedure-source-information (generate-procedure-source-information)]
|
|
[$compile-profile ($compile-profile)]
|
|
[generate-interrupt-trap (generate-interrupt-trap)]
|
|
[$optimize-closures ($optimize-closures)]
|
|
[enable-cross-library-optimization (enable-cross-library-optimization)]
|
|
[generate-covin-files (generate-covin-files)])
|
|
(emit-header op (constant machine-type))
|
|
(when hostop (emit-header hostop (host-machine-type)))
|
|
(when wpoop (emit-header wpoop (host-machine-type)))
|
|
(let cfh0 ([n 1] [rrcinfo** '()] [rlpinfo** '()] [rfinal** '()])
|
|
(let ([x0 ($pass-time 'read do-read)])
|
|
(if (eof-object? x0)
|
|
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**))
|
|
(let ()
|
|
(define source-info-string
|
|
(and (or ($assembly-output) (expand-output) (expand/optimize-output))
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(printf "expression #~s" n)
|
|
(when (and (annotation? x0) (fxlogtest (annotation-flags x0) (constant annotation-debug)))
|
|
(let ((s (annotation-source x0)))
|
|
(call-with-values
|
|
(lambda () ((current-locate-source-object-source) s #t #t))
|
|
(case-lambda
|
|
[() (void)]
|
|
[(path line char) (printf " on line ~s" line)]))))))))
|
|
(when ($assembly-output)
|
|
(when source-info-string
|
|
(fprintf ($assembly-output) "~%;; ~a\n" source-info-string))
|
|
(parameterize ([print-graph #t])
|
|
(pretty-print (if (annotation? x0) (annotation-stripped x0) x0)
|
|
($assembly-output)))
|
|
(flush-output-port ($assembly-output)))
|
|
(let ([x1 ($pass-time 'expand
|
|
(lambda ()
|
|
(expand x0 (if (eq? (subset-mode) 'system) ($system-environment) (interaction-environment)) #t #t outfn)))])
|
|
(check-prelex-flags x1 'expand)
|
|
($uncprep x1 #t) ; populate preinfo sexpr fields
|
|
(check-prelex-flags x1 'uncprep)
|
|
(when source-table ($insert-profile-src! source-table x1))
|
|
(when wpoop
|
|
; cross-library optimization locs might be set by cp0 during the expander's compile-time
|
|
; evaluation of library forms. since we have no need for the optimization information in
|
|
; the wpo file, we temporarily whack the optimization locs while writing the wpo file.
|
|
(with-whacked-optimization-locs x1
|
|
(lambda ()
|
|
($with-fasl-target (host-machine-type)
|
|
(lambda ()
|
|
(parameterize ([$target-machine (machine-type)])
|
|
(let ([t ($fasl-table)])
|
|
($fasl-enter x1 t (constant annotation-all))
|
|
($fasl-start wpoop t (constant fasl-type-visit-revisit) (lambda (p) ($fasl-out x1 p t (constant annotation-all)))))))))))
|
|
(let-values ([(rcinfo* lpinfo* final*) (compile-file-help1 x1 source-info-string)])
|
|
(when hostop
|
|
; the host library file contains expander output possibly augmented with
|
|
; cross-library optimization information inserted by cp0. this write must come
|
|
; after cp0, at least, so that cp0 has a chance to insert that information.
|
|
($with-fasl-target (host-machine-type)
|
|
(lambda ()
|
|
(parameterize ([$target-machine (machine-type)])
|
|
(let ([t ($fasl-table)])
|
|
($fasl-enter x1 t (constant annotation-all))
|
|
($fasl-start hostop t (constant fasl-type-visit-revisit) (lambda (p) ($fasl-out x1 p t (constant annotation-all)))))))))
|
|
(cfh0 (+ n 1) (cons rcinfo* rrcinfo**) (cons lpinfo* rlpinfo**) (cons final* rfinal**)))))))))))
|
|
|
|
(define library/program-info?
|
|
(lambda (x)
|
|
(or (program-info? x) (library-info? x))))
|
|
|
|
(define-who compile-file-help1
|
|
(lambda (x1 source-info-string)
|
|
(define-who expand-Lexpand
|
|
(lambda (e)
|
|
; we might want to export expand-Inner from syntax.ss instead of $build-install-library/ct-code
|
|
; and $build-install-library/rt-code
|
|
(define-pass expand-Inner : Lexpand (ir) -> Lexpand ()
|
|
(Inner : Inner (ir) -> Inner ()
|
|
[,lsrc lsrc] ; NB: workaround for nanopass tag snafu
|
|
[(program ,uid ,body) ($build-invoke-program uid body)]
|
|
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
|
|
($build-install-library/ct-code uid export-id* import-code visit-code)]
|
|
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
|
($build-install-library/rt-code uid dl* db* dv* de* body)]
|
|
[else ir]))
|
|
(with-output-language (Lsrc Expr)
|
|
(define (lambda-chunk lsrc)
|
|
; pretending main is a library routine to avoid argument-count check
|
|
`(case-lambda ,(make-preinfo-lambda #f #f (lookup-libspec main))
|
|
(clause () 0 ,lsrc)))
|
|
(define (visit lsrc e* rchunk*)
|
|
(define (rchunks) (cons (make-visit-chunk (lambda-chunk lsrc)) rchunk*))
|
|
(if (null? e*)
|
|
(rchunks)
|
|
(let f ([e (car e*)] [e* (cdr e*)])
|
|
(nanopass-case (Lexpand Outer) e
|
|
[(group ,outer1 ,outer2) (f outer1 (cons outer2 e*))]
|
|
[(visit-only ,lsrc2) (visit `(seq ,lsrc ,lsrc2) e* rchunk*)]
|
|
[else (common e e* (rchunks))]))))
|
|
(define (revisit lsrc e* rchunk*)
|
|
(define (rchunks) (cons (make-revisit-chunk (lambda-chunk lsrc)) rchunk*))
|
|
(if (null? e*)
|
|
(rchunks)
|
|
(let f ([e (car e*)] [e* (cdr e*)])
|
|
(nanopass-case (Lexpand Outer) e
|
|
[(group ,outer1 ,outer2) (f outer1 (cons outer2 e*))]
|
|
[(revisit-only ,lsrc2) (revisit `(seq ,lsrc ,lsrc2) e* rchunk*)]
|
|
[else (common e e* (rchunks))]))))
|
|
(define (visit-revisit lsrc e* rchunk*)
|
|
(define (rchunks) (cons (lambda-chunk lsrc) rchunk*))
|
|
(if (null? e*)
|
|
(rchunks)
|
|
(let f ([e (car e*)] [e* (cdr e*)])
|
|
(nanopass-case (Lexpand Outer) e
|
|
[(group ,outer1 ,outer2) (f outer1 (cons outer2 e*))]
|
|
[,lsrc2 (visit-revisit `(seq ,lsrc ,lsrc2) e* rchunk*)]
|
|
[else (common e e* (rchunks))]))))
|
|
(define (unwrap-inner e)
|
|
(nanopass-case (Lexpand Inner) e
|
|
[(library/ct-info ,linfo/ct) linfo/ct]
|
|
[(library/rt-info ,linfo/rt) linfo/rt]
|
|
[(program-info ,pinfo) pinfo]
|
|
[else e]))
|
|
(define (common e e* rchunk*)
|
|
(nanopass-case (Lexpand Outer) e
|
|
[(visit-only ,lsrc) (visit lsrc e* rchunk*)]
|
|
[(revisit-only ,lsrc) (revisit lsrc e* rchunk*)]
|
|
[,lsrc (visit-revisit lsrc e* rchunk*)]
|
|
[else (let ([rchunk* (cons (nanopass-case (Lexpand Outer) e
|
|
[(visit-only ,inner) (make-visit-chunk (unwrap-inner inner))]
|
|
[(revisit-only ,inner) (make-revisit-chunk (unwrap-inner inner))]
|
|
[(recompile-info ,rcinfo) rcinfo]
|
|
[,inner (unwrap-inner inner)]
|
|
[else (sorry! who "unexpected Outer ~s" e)])
|
|
rchunk*)])
|
|
(if (null? e*) rchunk* (start (car e*) (cdr e*) rchunk*)))]))
|
|
(define (start e e* rchunk*)
|
|
(nanopass-case (Lexpand Outer) e
|
|
[(group ,outer1 ,outer2) (start outer1 (cons outer2 e*) rchunk*)]
|
|
[else (common e e* rchunk*)]))
|
|
(reverse (start (expand-Inner e) '() '())))))
|
|
(when (expand-output)
|
|
(when source-info-string
|
|
(fprintf (expand-output) "~%;; expand output for ~a\n" source-info-string))
|
|
(pretty-print ($uncprep x1) (expand-output))
|
|
(flush-output-port (expand-output)))
|
|
(let loop ([chunk* (expand-Lexpand x1)] [rx2b* '()] [rfinal* '()] [rlpinfo* '()] [rrcinfo* '()])
|
|
(if (null? chunk*)
|
|
(begin
|
|
(when (expand/optimize-output)
|
|
(when source-info-string
|
|
(fprintf (expand/optimize-output) "~%;; expand/optimize output for ~a\n" source-info-string))
|
|
(let ([e* (map (lambda (x2b)
|
|
(define (finish x2b)
|
|
($uncprep
|
|
(cond
|
|
[(recompile-info? x2b) (with-output-language (Lexpand Outer) `(recompile-info ,x2b))]
|
|
[(library/ct-info? x2b) (with-output-language (Lexpand Inner) `(library/ct-info ,x2b))]
|
|
[(library/rt-info? x2b) (with-output-language (Lexpand Inner) `(library/rt-info ,x2b))]
|
|
[(program-info? x2b) (with-output-language (Lexpand Inner) `(program-info ,x2b))]
|
|
[else
|
|
(nanopass-case (Lsrc Expr) x2b
|
|
[(case-lambda ,preinfo (clause () ,interface ,body)) body]
|
|
[else (sorry! 'compile-file-help "unexpected optimizer output ~s" x2b)])])))
|
|
(if (pair? x2b)
|
|
(case (car x2b)
|
|
[(visit-stuff) `(eval-when (visit) ,(finish (cdr x2b)))]
|
|
[(revisit-stuff) `(eval-when (revisit) ,(finish (cdr x2b)))]
|
|
[else (sorry! who "unrecognized stuff ~s" x2b)])
|
|
(finish x2b)))
|
|
rx2b*)])
|
|
(pretty-print (if (fx= (length e*) 1) (car e*) `(begin ,@(reverse e*))) (expand/optimize-output))
|
|
(flush-output-port (expand/optimize-output))))
|
|
(values (reverse rrcinfo*) (reverse rlpinfo*) (reverse rfinal*)))
|
|
(let ([x1 (car chunk*)] [chunk* (cdr chunk*)])
|
|
(define finish-compile
|
|
(lambda (x1 f)
|
|
(if (library/program-info? x1)
|
|
(loop chunk* (cons (f x1) rx2b*) rfinal* (cons (f `(object ,x1)) rlpinfo*) rrcinfo*)
|
|
(let* ([waste (check-prelex-flags x1 'before-cpvalid)]
|
|
[x2 ($pass-time 'cpvalid (lambda () (do-trace $cpvalid x1)))]
|
|
[waste (check-prelex-flags x2 'cpvalid)]
|
|
[x2a (let ([cpletrec-ran? #f])
|
|
(let ([x ((run-cp0)
|
|
(lambda (x)
|
|
(set! cpletrec-ran? #t)
|
|
(let* ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))]
|
|
[waste (check-prelex-flags x 'cp0)]
|
|
[x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]
|
|
[waste (check-prelex-flags x 'cpletrec)])
|
|
x))
|
|
x2)])
|
|
(if cpletrec-ran?
|
|
x
|
|
(let ([x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))])
|
|
(check-prelex-flags x 'cpletrec)
|
|
x))))]
|
|
[x2b ($pass-time 'cpcheck (lambda () (do-trace $cpcheck x2a)))]
|
|
[waste (check-prelex-flags x2b 'cpcheck)]
|
|
[x2b ($pass-time 'cpcommonize (lambda () (do-trace $cpcommonize x2b)))]
|
|
[waste (check-prelex-flags x2b 'cpcommonize)]
|
|
[x7 (do-trace $np-compile x2b #t)]
|
|
[x8 ($c-make-closure x7)])
|
|
(loop chunk* (cons (f x2b) rx2b*) (cons (f x8) rfinal*) rlpinfo* rrcinfo*)))))
|
|
(cond
|
|
[(recompile-info? x1) (loop chunk* (cons x1 rx2b*) rfinal* rlpinfo* (cons x1 rrcinfo*))]
|
|
[(visit-chunk? x1) (finish-compile (visit-chunk-chunk x1) (lambda (x) `(visit-stuff . ,x)))]
|
|
[(revisit-chunk? x1) (finish-compile (revisit-chunk-chunk x1) (lambda (x) `(revisit-stuff . ,x)))]
|
|
[else (finish-compile x1 values)]))))))
|
|
|
|
(define compile-file-help2
|
|
(lambda (op rcinfo** lpinfo** final**)
|
|
(define (libreq-hash x) (symbol-hash (libreq-uid x)))
|
|
(define (libreq=? x y) (eq? (libreq-uid x) (libreq-uid y)))
|
|
(let ([import-ht (make-hashtable libreq-hash libreq=?)]
|
|
[include-ht (make-hashtable string-hash string=?)])
|
|
(for-each
|
|
(lambda (rcinfo*)
|
|
(for-each
|
|
(lambda (rcinfo)
|
|
(for-each
|
|
(lambda (x) (hashtable-set! import-ht x #t))
|
|
(recompile-info-import-req* rcinfo))
|
|
(for-each
|
|
(lambda (x) (hashtable-set! include-ht x #t))
|
|
(recompile-info-include-req* rcinfo)))
|
|
rcinfo*))
|
|
rcinfo**)
|
|
(let ([import-req* (vector->list (hashtable-keys import-ht))]
|
|
[include-req* (vector->list (hashtable-keys include-ht))])
|
|
; the first entry is always a recompile-info record with recompile information for the entire object file
|
|
($pass-time 'pfasl
|
|
(lambda ()
|
|
(c-print-fasl `(object ,(make-recompile-info import-req* include-req*)) op (constant fasl-type-visit-revisit))
|
|
(for-each
|
|
(lambda (final*)
|
|
(for-each
|
|
(lambda (x)
|
|
(record-case x
|
|
[(visit-stuff) x (c-print-fasl x op (constant fasl-type-visit))]
|
|
[(revisit-stuff) x (c-print-fasl x op (constant fasl-type-revisit))]
|
|
[else (c-print-fasl x op (constant fasl-type-visit-revisit))]))
|
|
final*))
|
|
; inserting #t after lpinfo as an end-of-header marker
|
|
(append lpinfo** (cons (list `(object #t)) final**)))))))))
|
|
|
|
(define (new-extension new-ext fn)
|
|
(let ([old-ext (path-extension fn)])
|
|
(format "~a.~a"
|
|
(if (or (string=? old-ext "") (string=? old-ext new-ext)) fn (path-root fn))
|
|
new-ext)))
|
|
|
|
(module (with-object-file with-host-file with-wpo-file with-coverage-file)
|
|
(define call-with-port/cleanup
|
|
(lambda (ofn op p)
|
|
(on-reset (delete-file ofn #f)
|
|
(on-reset (close-port op)
|
|
(p op))
|
|
(close-port op))))
|
|
|
|
(define with-object-file
|
|
(case-lambda
|
|
[(who ofn p) (with-object-file who ofn #t p)]
|
|
[(who ofn compressed-okay? p)
|
|
(call-with-port/cleanup ofn
|
|
($open-file-output-port who ofn
|
|
(if (and compressed-okay? (compile-compressed))
|
|
(file-options replace compressed)
|
|
(file-options replace)))
|
|
p)]))
|
|
|
|
(define with-host-file
|
|
(lambda (who ofn p)
|
|
(if ofn
|
|
(call-with-port/cleanup ofn
|
|
($open-file-output-port who ofn
|
|
(if (compile-compressed)
|
|
(file-options replace compressed)
|
|
(file-options replace)))
|
|
p)
|
|
(p #f))))
|
|
|
|
(define with-wpo-file
|
|
(case-lambda
|
|
[(who ofn p) (with-wpo-file who ofn #t p)]
|
|
[(who ofn compressed-okay? p)
|
|
(if (generate-wpo-files)
|
|
(let ([ofn (new-extension "wpo" ofn)])
|
|
(call-with-port/cleanup ofn
|
|
($open-file-output-port who ofn
|
|
(if (and compressed-okay? (compile-compressed))
|
|
(file-options replace compressed)
|
|
(file-options replace)))
|
|
p))
|
|
(p #f))]))
|
|
|
|
(define with-coverage-file
|
|
(lambda (who ofn p)
|
|
(if (generate-covin-files)
|
|
(let ([ofn (new-extension "covin" ofn)])
|
|
(call-with-port/cleanup ofn
|
|
($open-file-output-port who ofn
|
|
(file-options compressed replace)
|
|
(buffer-mode block)
|
|
(current-transcoder))
|
|
(lambda (op)
|
|
(let ([source-table (make-source-table)])
|
|
(p source-table)
|
|
(put-source-table op source-table)))))
|
|
(p #f)))))
|
|
|
|
(set! $compile-host-library
|
|
(lambda (who iofn)
|
|
(let ([ip ($open-file-input-port who iofn (file-options compressed))])
|
|
(on-reset (close-port ip)
|
|
(let loop ([rx1* '()] [rcinfo* '()] [rother* '()])
|
|
(let ([x1 (fasl-read ip)])
|
|
(cond
|
|
[(eof-object? x1)
|
|
(close-port ip)
|
|
(unless (null? rx1*)
|
|
(unless (null? rother*) ($oops 'compile-library "unexpected value ~s read from file ~s that also contains ~s" (car rother*) iofn (car rx1*)))
|
|
(with-object-file who iofn
|
|
(lambda (op)
|
|
(emit-header op (constant machine-type))
|
|
(let loop ([x1* (reverse rx1*)] [rrcinfo** (list rcinfo*)] [rlpinfo** '()] [rfinal** '()])
|
|
(if (null? x1*)
|
|
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**))
|
|
(let-values ([(rcinfo* lpinfo* final*)
|
|
(let ([x1 (car x1*)])
|
|
(if (recompile-info? x1)
|
|
(values (list x1) '() '())
|
|
(compile-file-help1 (car x1*) "host library")))])
|
|
(loop (cdr x1*) (cons rcinfo* rrcinfo**) (cons lpinfo* rlpinfo**) (cons final* rfinal**))))))))]
|
|
[(recompile-info? x1) (loop rx1* (cons x1 rcinfo*) rother*)]
|
|
[(Lexpand? x1) (loop (cons x1 rx1*) rcinfo* rother*)]
|
|
[else (loop rx1* rcinfo* (cons x1 rother*))])))))))
|
|
|
|
(let ()
|
|
(define-record-type node (nongenerative)
|
|
(fields (mutable depend*) (mutable use-count))
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda ()
|
|
(new #f 0)))))
|
|
(define-record-type program-node (nongenerative) (sealed #t) (parent node)
|
|
(fields pinfo (mutable ir))
|
|
(protocol
|
|
(lambda (pargs->new)
|
|
(lambda (pinfo)
|
|
((pargs->new) pinfo #f)))))
|
|
(define program-node-uid
|
|
(lambda (node)
|
|
(program-info-uid (program-node-pinfo node))))
|
|
(define program-node-invoke-req*
|
|
(lambda (node)
|
|
(program-info-invoke-req* (program-node-pinfo node))))
|
|
|
|
(define-record-type library-node (nongenerative) (parent node)
|
|
(fields binary? (mutable ctinfo) (mutable rtinfo) (mutable ctir) (mutable rtir) (mutable visible?) fn)
|
|
(protocol
|
|
(lambda (pargs->new)
|
|
(lambda (binary? ctinfo rtinfo visible? fn)
|
|
(safe-assert (or ctinfo rtinfo))
|
|
((pargs->new) binary? ctinfo rtinfo #f #f visible? fn)))))
|
|
(define library-node-path
|
|
(lambda (node)
|
|
(library-info-path (or (library-node-ctinfo node) (library-node-rtinfo node)))))
|
|
(define library-node-uid
|
|
(lambda (node)
|
|
(library-info-uid (or (library-node-ctinfo node) (library-node-rtinfo node)))))
|
|
(define library-node-version
|
|
(lambda (node)
|
|
(library-info-version (or (library-node-ctinfo node) (library-node-rtinfo node)))))
|
|
(define library-node-invoke-req*
|
|
(lambda (node)
|
|
(library/rt-info-invoke-req* (library-node-rtinfo node))))
|
|
(define library-node-import-req*
|
|
(lambda (node)
|
|
(library/ct-info-import-req* (library-node-ctinfo node))))
|
|
|
|
(define read-input-file
|
|
(lambda (who ifn)
|
|
(call-with-port ($open-file-input-port who ifn)
|
|
(lambda (ip)
|
|
(on-reset (close-port ip)
|
|
(let ([hash-bang-line
|
|
(let ([start-pos (port-position ip)])
|
|
(if (and (eqv? (get-u8 ip) (char->integer #\#))
|
|
(eqv? (get-u8 ip) (char->integer #\!))
|
|
(let ([b (lookahead-u8 ip)])
|
|
(or (eqv? b (char->integer #\space))
|
|
(eqv? b (char->integer #\/)))))
|
|
(let-values ([(op get-bv) (open-bytevector-output-port)])
|
|
(put-u8 op (char->integer #\#))
|
|
(put-u8 op (char->integer #\!))
|
|
(let loop ()
|
|
(let ([b (get-u8 ip)])
|
|
(unless (eof-object? b)
|
|
(put-u8 op b)
|
|
(unless (eqv? b (char->integer #\newline))
|
|
(loop)))))
|
|
(get-bv))
|
|
(begin (set-port-position! ip start-pos) #f)))])
|
|
(port-file-compressed! ip)
|
|
(if ($compiled-file-header? ip)
|
|
(let loop ([rls '()])
|
|
(let ([x (fasl-read ip)])
|
|
(cond
|
|
[(eof-object? x) (values hash-bang-line (reverse rls))]
|
|
[(Lexpand? x) (loop (cons x rls))]
|
|
[else ($oops who "unexpected wpo file object ~s" x)])))
|
|
($oops who "input file is source ~s" ifn))))))))
|
|
|
|
(define find-library
|
|
(lambda (who path what library-ext*)
|
|
(with-values
|
|
($library-search who path (library-directories) library-ext*)
|
|
(lambda (src-path lib-path lib-exists?)
|
|
(and lib-exists?
|
|
(begin
|
|
(when (and src-path (time<? (file-modification-time lib-path) (file-modification-time src-path)))
|
|
(warningf who "~a file ~a is older than source file ~a" what lib-path src-path))
|
|
(when (import-notify) (fprintf (console-output-port) "reading ~a\n" lib-path))
|
|
lib-path))))))
|
|
|
|
(define build-graph
|
|
(lambda (who ir* ifn capture-program? capture-wpo? libs-visible?)
|
|
(let ([libs (make-hashtable symbol-hash eq?)] [wpo* '()])
|
|
(define lookup-path
|
|
(lambda (uid)
|
|
(cond
|
|
[(symbol-hashtable-ref libs uid #f) => library-node-path]
|
|
[else uid])))
|
|
(define read-library
|
|
(lambda (path libs-visible?)
|
|
(cond
|
|
[(find-library who path "wpo" (map (lambda (ext) (cons (car ext) (string-append (path-root (cdr ext)) ".wpo"))) (library-extensions))) =>
|
|
(lambda (fn)
|
|
(let*-values ([(hash-bang-line ir*) (read-input-file who fn)]
|
|
[(no-program node* ignore-rcinfo*) (process-ir*! ir* fn #f libs-visible?)])
|
|
(values fn node*)))]
|
|
[(find-library who path "so" (library-extensions)) =>
|
|
(lambda (fn) (values fn (read-binary-file path fn libs-visible?)))]
|
|
[else ($oops who "unable to locate expanded library file for library ~s" path)])))
|
|
(define read-binary-file
|
|
(lambda (path fn libs-visible?)
|
|
(call-with-port ($open-file-input-port who fn (file-options compressed))
|
|
(lambda (ip)
|
|
(on-reset (close-port ip)
|
|
(if ($compiled-file-header? ip)
|
|
(let ([libs-in-file '()])
|
|
(let loop! ()
|
|
(let ([x (fasl-read ip)])
|
|
(if (eof-object? x)
|
|
(begin
|
|
(for-each
|
|
(lambda (node)
|
|
(unless (library-node-ctinfo node)
|
|
($oops who "missing compile-time information for ~s" (library-node-path node)))
|
|
(unless (library-node-rtinfo node)
|
|
($oops who "missing run-time information for ~s" (library-node-path node))))
|
|
libs-in-file)
|
|
libs-in-file)
|
|
(begin
|
|
(cond
|
|
[(recompile-info? x)]
|
|
[(procedure? x)]
|
|
[(library/ct-info? x)
|
|
(let ([node (record-ct-lib! x #t fn libs-visible?)])
|
|
(when node (set! libs-in-file (cons node libs-in-file))))]
|
|
[(library/rt-info? x)
|
|
(let ([node (record-rt-lib! x #t fn libs-visible?)])
|
|
(when node (set! libs-in-file (cons node libs-in-file))))]
|
|
[(program-info? x) ($oops who "found program while looking for library ~s in ~a" path fn)]
|
|
; NB: this is here to support the #t inserted by compile-file-help2 after header information
|
|
[(eq? x #t)]
|
|
[else ($oops who "unexpected value ~s read from ~a" x fn)])
|
|
(loop!))))))
|
|
($oops who "malformed binary input file ~s" fn)))))))
|
|
(define process-ir*!
|
|
(lambda (ir* ifn capture-program? libs-visible?)
|
|
(define outer-who who)
|
|
(let ([libs-in-file '()] [maybe-program #f] [rcinfo* '()])
|
|
(define-pass process-ir! : Lexpand (ir) -> * ()
|
|
(Outer : Outer (ir situation) -> * ()
|
|
[(recompile-info ,rcinfo) (set! rcinfo* (cons rcinfo rcinfo*)) (values)]
|
|
[(group ,[] ,[]) (values)]
|
|
[(visit-only ,[inner 'visit ->]) (values)]
|
|
[(revisit-only ,[inner 'revisit ->]) (values)])
|
|
(Inner : Inner (ir situation) -> * ()
|
|
[,lsrc ($oops outer-who "expected program or library form, but encountered top-level expression ~s processing file ~a" ($uncprep lsrc) ifn)]
|
|
[(library/ct-info ,linfo/ct)
|
|
(let ([node (record-ct-lib! linfo/ct #f ifn libs-visible?)])
|
|
(when node (set! libs-in-file (cons node libs-in-file))))
|
|
(values)]
|
|
[(library/rt-info ,linfo/rt)
|
|
(let ([node (record-rt-lib! linfo/rt #f ifn libs-visible?)])
|
|
(when node (set! libs-in-file (cons node libs-in-file))))
|
|
(values)]
|
|
[(program-info ,pinfo)
|
|
(unless capture-program? ($oops outer-who "found program while reading library wpo file ~a" ifn))
|
|
(when (eq? situation 'visit) ($oops outer-who "encountered visit-only program while processing file ~s" ifn))
|
|
(when maybe-program ($oops outer-who "found multiple programs in entry file ~a" ifn))
|
|
(set! maybe-program (make-program-node pinfo))
|
|
(values)])
|
|
(Program : Program (ir situation) -> * ()
|
|
[(program ,uid ,body)
|
|
(unless capture-program? ($oops outer-who "found program while reading library wpo file ~a" ifn))
|
|
(when (eq? situation 'visit) ($oops outer-who "encountered visit-only program while processing file ~s" ifn))
|
|
(unless maybe-program ($oops outer-who "unable to locate program descriptor for ~s" uid))
|
|
(unless (eq? uid (program-node-uid maybe-program))
|
|
($oops outer-who "expected code for program uid ~s, but found code for program uid ~s" (program-node-uid maybe-program) uid))
|
|
(program-node-ir-set! maybe-program ir)
|
|
(values)])
|
|
(ctLibrary : ctLibrary (ir situation) -> * ()
|
|
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
|
|
(when (eq? situation 'revisit) ($oops outer-who "encountered revisit-only compile-time library ~s while processing file ~s" (lookup-path uid) ifn))
|
|
(record-ct-lib-ir! uid ir)
|
|
(values)])
|
|
(rtLibrary : rtLibrary (ir situation) -> * ()
|
|
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
|
(when (eq? situation 'visit) ($oops outer-who "encountered visit-only run-time library ~s while processing file ~s" (lookup-path uid) ifn))
|
|
(record-rt-lib-ir! uid ir)
|
|
(values)])
|
|
(when capture-wpo? (set! wpo* (cons ir wpo*)))
|
|
(Outer ir 'load))
|
|
(for-each process-ir! ir*)
|
|
(for-each
|
|
(lambda (node)
|
|
(unless (library-node-ctinfo node)
|
|
($oops who "missing compile-time information for ~s" (library-node-path node)))
|
|
(unless (library-node-rtinfo node)
|
|
($oops who "missing run-time information for ~s" (library-node-path node)))
|
|
(unless (library-node-ctir node)
|
|
($oops who "missing compile-time code for ~s" (library-node-path node)))
|
|
(unless (library-node-rtir node)
|
|
($oops who "missing run-time code for ~s" (library-node-path node))))
|
|
libs-in-file)
|
|
(values maybe-program libs-in-file rcinfo*))))
|
|
(define record-ct-lib!
|
|
(lambda (linfo/ct binary? ifn libs-visible?)
|
|
(let* ([uid (library-info-uid linfo/ct)]
|
|
[cell (symbol-hashtable-cell libs uid #f)]
|
|
[node (cdr cell)])
|
|
(if node
|
|
(if (library-node-ctinfo node)
|
|
($oops who "encountered library ~s in ~a, but had already encountered it in ~a"
|
|
(library-info-path linfo/ct) ifn (library-node-fn node))
|
|
(begin (library-node-ctinfo-set! node linfo/ct) #f))
|
|
(let ([node (make-library-node binary? linfo/ct #f (or libs-visible? binary?) ifn)])
|
|
(set-cdr! cell node)
|
|
node)))))
|
|
(define record-rt-lib!
|
|
(lambda (linfo/rt binary? ifn libs-visible?)
|
|
(let* ([uid (library-info-uid linfo/rt)]
|
|
[cell (symbol-hashtable-cell libs uid #f)]
|
|
[node (cdr cell)])
|
|
(if node
|
|
(if (library-node-rtinfo node)
|
|
($oops who "encountered library ~s in ~a, but had already encountered it in ~a"
|
|
(library-info-path linfo/rt) ifn (library-node-fn node))
|
|
(begin (library-node-rtinfo-set! node linfo/rt) #f))
|
|
(let ([node (make-library-node binary? #f linfo/rt (or libs-visible? binary?) ifn)])
|
|
(set-cdr! cell node)
|
|
node)))))
|
|
(define record-ct-lib-ir!
|
|
(lambda (uid ir)
|
|
(let ([node (symbol-hashtable-ref libs uid #f)])
|
|
(unless node ($oops "missing descriptor for compile-time library code ~s" uid))
|
|
(library-node-ctir-set! node ir))))
|
|
(define record-rt-lib-ir!
|
|
(lambda (uid ir)
|
|
(let ([node (symbol-hashtable-ref libs uid #f)])
|
|
(unless node ($oops "missing descriptor for run-time library code ~s" uid))
|
|
(library-node-rtir-set! node ir))))
|
|
(define chase-library
|
|
(lambda (req libs-visible?)
|
|
(let ([a (symbol-hashtable-cell libs (libreq-uid req) #f)])
|
|
(cond
|
|
[(cdr a) =>
|
|
(lambda (node)
|
|
(when libs-visible?
|
|
(unless (library-node-visible? node)
|
|
(library-node-visible?-set! node #t)
|
|
(chase-library-dependencies! node))))]
|
|
[else
|
|
(let ([path (libreq-path req)])
|
|
(let-values ([(fn node*) (read-library path libs-visible?)])
|
|
(unless (symbol-hashtable-ref libs (libreq-uid req) #f)
|
|
($oops who "~s does not define expected compilation instance of library ~s" fn path))
|
|
(for-each chase-library-dependencies! node*)))]))))
|
|
(define find-dependencies
|
|
(lambda (req* maybe-import-req*)
|
|
(let ([dep* (map (lambda (req)
|
|
(let ([node (symbol-hashtable-ref libs (libreq-uid req) #f)])
|
|
(node-use-count-set! node (fx+ (node-use-count node) 1))
|
|
node))
|
|
req*)])
|
|
(if maybe-import-req*
|
|
(fold-right (lambda (req dep*)
|
|
(let ([node (symbol-hashtable-ref libs (libreq-uid req) #f)])
|
|
(if node
|
|
(begin
|
|
(node-use-count-set! node (fx+ (node-use-count node) 1))
|
|
(cons node dep*))
|
|
dep*)))
|
|
dep* maybe-import-req*)
|
|
dep*))))
|
|
(define chase-program-dependencies!
|
|
(lambda (node)
|
|
(for-each (lambda (req) (chase-library req libs-visible?)) (program-node-invoke-req* node))
|
|
(node-depend*-set! node (find-dependencies (program-node-invoke-req* node) #f))))
|
|
(define chase-library-dependencies!
|
|
(lambda (node)
|
|
(if (library-node-visible? node)
|
|
(for-each
|
|
(lambda (req)
|
|
(unless ($system-library? (libreq-path req))
|
|
(chase-library req (library-node-visible? node))))
|
|
(library-node-import-req* node))
|
|
(for-each
|
|
(lambda (req) (chase-library req (library-node-visible? node)))
|
|
(library-node-invoke-req* node)))
|
|
(unless (node-depend* node)
|
|
(node-depend*-set! node
|
|
(find-dependencies
|
|
(library-node-invoke-req* node)
|
|
(and (library-node-visible? node) (library-node-import-req* node)))))))
|
|
(let-values ([(maybe-program node* rcinfo*) (process-ir*! ir* ifn capture-program? libs-visible?)])
|
|
(when capture-program?
|
|
(unless maybe-program ($oops who "missing entry program in file ~a" ifn))
|
|
(unless (program-node-ir maybe-program) ($oops who "loading ~a did not define expected program pieces" ifn))
|
|
(chase-program-dependencies! maybe-program))
|
|
(for-each chase-library-dependencies! node*)
|
|
(let-values ([(visible* invisible*) (partition library-node-visible? (vector->list (hashtable-values libs)))])
|
|
(values maybe-program visible* invisible* rcinfo* wpo*))))))
|
|
|
|
(define topological-sort
|
|
(lambda (program-entry library-entry*)
|
|
(define topological-sort
|
|
(lambda (dep* node*)
|
|
(if (null? dep*)
|
|
node*
|
|
(let* ([dep (car dep*)] [use-count (node-use-count dep)])
|
|
(node-use-count-set! dep (fx- use-count 1))
|
|
(if (fx= use-count 1)
|
|
(topological-sort (cdr dep*) (topological-sort (node-depend* dep) (cons dep node*)))
|
|
(topological-sort (cdr dep*) node*))))))
|
|
(fold-right
|
|
(lambda (entry node*) (topological-sort (node-depend* entry) (cons entry node*)))
|
|
(if program-entry (topological-sort (node-depend* program-entry) '()) '())
|
|
(filter (lambda (node) (fx= (node-use-count node) 0)) library-entry*))))
|
|
|
|
(define void-pr (lookup-primref 3 'void))
|
|
|
|
(with-output-language (Lsrc Expr)
|
|
(define build-install-library/ct-code
|
|
(lambda (node)
|
|
(nanopass-case (Lexpand ctLibrary) (library-node-ctir node)
|
|
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
|
|
(if (library-node-visible? node)
|
|
($build-install-library/ct-code uid export-id* import-code visit-code)
|
|
void-pr)])))
|
|
|
|
(define build-void (let ([void-rec `(quote ,(void))]) (lambda () void-rec)))
|
|
|
|
(define gen-var (lambda (sym) (make-prelex sym 0 #f #f)))
|
|
(define build-let
|
|
(lambda (ids exprs body)
|
|
`(call ,(make-preinfo) ,(build-lambda ids body) ,exprs ...)))
|
|
|
|
(define build-lambda
|
|
(lambda (ids body)
|
|
`(case-lambda ,(make-preinfo-lambda)
|
|
(clause (,ids ...) ,(length ids) ,body))))
|
|
|
|
(define build-call
|
|
(lambda (e . e*)
|
|
`(call ,(make-preinfo) ,e ,e* ...)))
|
|
|
|
(define-syntax build-primcall
|
|
; written as a macro to give lookup-primref a chance to lookup the primref at expansion time
|
|
(syntax-rules ()
|
|
[(_ ?name ?arg ...) (build-call (lookup-primref 3 ?name) ?arg ...)]))
|
|
|
|
(define-syntax build-primref
|
|
(syntax-rules ()
|
|
[(_ ?level ?name) (lookup-primref ?level ?name)]))
|
|
|
|
(define build-install-library/rt-code
|
|
(lambda (node thunk)
|
|
(build-primcall '$install-library/rt-code `(quote ,(library-node-uid node)) thunk)))
|
|
|
|
(define-pass patch : Lsrc (ir env) -> Lsrc ()
|
|
(definitions
|
|
(define with-initialized-ids
|
|
(lambda (old-id* proc)
|
|
(let ([new-id* (map (lambda (old-id)
|
|
(let ([new-id (make-prelex
|
|
(prelex-name old-id)
|
|
(let ([flags (prelex-flags old-id)])
|
|
(fxlogor
|
|
(fxlogand flags (constant prelex-sticky-mask))
|
|
(fxsll (fxlogand flags (constant prelex-is-mask))
|
|
(constant prelex-was-flags-offset))))
|
|
(prelex-source old-id)
|
|
#f)])
|
|
(prelex-operand-set! old-id new-id)
|
|
new-id))
|
|
old-id*)])
|
|
(let-values ([v* (proc new-id*)])
|
|
(for-each (lambda (old-id) (prelex-operand-set! old-id #f)) old-id*)
|
|
(apply values v*)))))
|
|
(define build-ref
|
|
(case-lambda
|
|
[(x) (build-ref #f x)]
|
|
[(src x)
|
|
(let ([x (prelex-operand x)])
|
|
(safe-assert (prelex? x))
|
|
(if (prelex-referenced x)
|
|
(set-prelex-multiply-referenced! x #t)
|
|
(set-prelex-referenced! x #t))
|
|
`(ref ,src ,x))])))
|
|
(Expr : Expr (ir) -> Expr ()
|
|
[(ref ,maybe-src ,x) (build-ref maybe-src x)]
|
|
[(call ,preinfo ,pr (quote ,d))
|
|
(guard (eq? (primref-name pr) '$top-level-value) (symbol? d))
|
|
(cond
|
|
[(symbol-hashtable-ref env d #f) => (lambda (x) (build-ref (preinfo-src preinfo) x))]
|
|
[else ir])]
|
|
[(set! ,maybe-src ,x ,[e])
|
|
(let ([x (prelex-operand x)])
|
|
(safe-assert (prelex? x))
|
|
(set-prelex-assigned! x #t)
|
|
`(set! ,maybe-src ,x ,e))]
|
|
[(letrec ([,x* ,e*] ...) ,body)
|
|
(with-initialized-ids x*
|
|
(lambda (x*)
|
|
`(letrec ([,x* ,(map Expr e*)] ...) ,(Expr body))))]
|
|
[(letrec* ([,x* ,e*] ...) ,body)
|
|
(with-initialized-ids x*
|
|
(lambda (x*)
|
|
`(letrec* ([,x* ,(map Expr e*)] ...) ,(Expr body))))])
|
|
(CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ()
|
|
[(clause (,x* ...) ,interface ,body)
|
|
(with-initialized-ids x*
|
|
(lambda (x*)
|
|
`(clause (,x* ...) ,interface ,(Expr body))))]))
|
|
|
|
(define build-top-level-set!*
|
|
(lambda (node)
|
|
(nanopass-case (Lexpand rtLibrary) (library-node-rtir node)
|
|
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
|
(fold-right
|
|
(lambda (dl db dv body)
|
|
(if dl
|
|
`(seq ,(build-primcall '$set-top-level-value! `(quote ,dl)
|
|
`(cte-optimization-loc ,db (ref #f ,dv)))
|
|
,body)
|
|
body))
|
|
(build-void) dl* db* dv*)])))
|
|
|
|
(define make-patch-env
|
|
(lambda (cluster*)
|
|
(let ([patch-env (make-hashtable symbol-hash eq?)])
|
|
(for-each
|
|
(lambda (cluster)
|
|
(for-each
|
|
(lambda (node)
|
|
(unless (library-node-binary? node)
|
|
(nanopass-case (Lexpand rtLibrary) (library-node-rtir node)
|
|
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
|
(for-each (lambda (label var)
|
|
(when label
|
|
(symbol-hashtable-set! patch-env label var)))
|
|
dl* dv*)])))
|
|
cluster))
|
|
cluster*)
|
|
patch-env)))
|
|
|
|
(define build-combined-program-ir
|
|
(lambda (program node*)
|
|
`(seq
|
|
,(build-primcall 'for-each
|
|
(build-primref 3 '$mark-pending!)
|
|
`(quote ,(map library-node-uid (remp library-node-binary? node*))))
|
|
,(patch
|
|
(fold-right
|
|
(lambda (node combined-body)
|
|
(if (library-node-binary? node)
|
|
`(seq
|
|
,(build-primcall '$invoke-library
|
|
`(quote ,(library-node-path node))
|
|
`(quote ,(library-node-version node))
|
|
`(quote ,(library-node-uid node)))
|
|
,combined-body)
|
|
(nanopass-case (Lexpand rtLibrary) (library-node-rtir node)
|
|
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
|
`(letrec* ([,dv* ,de*] ...)
|
|
(seq ,body
|
|
(seq
|
|
,(build-install-library/rt-code node
|
|
(if (library-node-visible? node)
|
|
(build-lambda '() (build-top-level-set!* node))
|
|
void-pr))
|
|
,combined-body)))])))
|
|
(nanopass-case (Lexpand Program) (program-node-ir program)
|
|
[(program ,uid ,body) body])
|
|
node*)
|
|
(make-patch-env (list node*))))))
|
|
|
|
(define build-combined-library-ir
|
|
(lambda (cluster*)
|
|
(define build-mark-invoked!
|
|
(lambda (node)
|
|
(build-primcall '$mark-invoked! `(quote ,(library-node-uid node)))))
|
|
|
|
(define build-cluster
|
|
(lambda (node* cluster-body)
|
|
(fold-right
|
|
(lambda (node cluster-body)
|
|
(nanopass-case (Lexpand rtLibrary) (library-node-rtir node)
|
|
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
|
`(letrec* ([,dv* ,de*] ...)
|
|
(seq ,body
|
|
(seq
|
|
,(if (library-node-visible? node)
|
|
`(seq ,(build-top-level-set!* node) ,(build-mark-invoked! node))
|
|
(build-mark-invoked! node))
|
|
,cluster-body)))]))
|
|
cluster-body node*)))
|
|
(patch
|
|
; example: D imports C; C imports A, B; B imports A; A imports nothing
|
|
; have wpos for D, A, B; obj for C
|
|
; (let ([lib-f (void)])
|
|
; (set! lib-f
|
|
; (lambda (idx)
|
|
; (letrec ([A-local ---] ...)
|
|
; A-body
|
|
; (begin ($top-level-set! A-export A-local) ...)
|
|
; (letrec ([B-local ---] ...)
|
|
; B-body
|
|
; (begin ($top-level-set! B-export B-local) ...)
|
|
; (let ([t (lambda (idx)
|
|
; (letrec ([D-local ---] ...)
|
|
; D-body
|
|
; (begin ($top-level-set! D-export B-local) ...)
|
|
; (set! lib-f (lambda (idx) (void)))))])
|
|
; (if (eqv? idx 0)
|
|
; (set! lib-f t)
|
|
; (t idx)))))))
|
|
; ($install-library/rt-code 'A-uid (lambda () (lib-f 0)))
|
|
; ($install-library/rt-code 'B-uid (lambda () (lib-f 0)))
|
|
; ($install-library/rt-code 'D-uid (lambda () (lib-f 1)))
|
|
; (void))
|
|
(let ([lib-f (gen-var 'lib-f)])
|
|
(let ([cluster-idx* (enumerate cluster*)])
|
|
(build-let (list lib-f) (list (build-void))
|
|
`(seq
|
|
(set! #f ,lib-f
|
|
,(let f ([cluster* cluster*] [cluster-idx* cluster-idx*])
|
|
(let ([idx (gen-var 'idx)])
|
|
(build-lambda (list idx)
|
|
(build-cluster (car cluster*)
|
|
(let ([cluster* (cdr cluster*)])
|
|
(if (null? cluster*)
|
|
(let ([idx (gen-var 'idx)])
|
|
`(set! #f ,lib-f ,(build-lambda (list idx) (build-void))))
|
|
(let ([t (gen-var 't)])
|
|
(build-let (list t) (list (f cluster* (cdr cluster-idx*)))
|
|
`(if ,(build-primcall 'eqv? `(ref #f ,idx) `(quote ,(car cluster-idx*)))
|
|
(set! #f ,lib-f (ref #f ,t))
|
|
,(build-call `(ref #f ,t) `(ref #f ,idx))))))))))))
|
|
,(fold-right (lambda (cluster cluster-idx body)
|
|
(fold-right (lambda (node body)
|
|
`(seq
|
|
,(build-install-library/rt-code node
|
|
(if (library-node-visible? node)
|
|
(build-lambda '()
|
|
(build-call `(ref #f ,lib-f) `(quote ,cluster-idx)))
|
|
void-pr))
|
|
,body))
|
|
body cluster))
|
|
(build-void) cluster* cluster-idx*)))))
|
|
(make-patch-env cluster*)))))
|
|
|
|
(with-output-language (Lexpand Outer)
|
|
(define add-recompile-info
|
|
(lambda (rcinfo* body)
|
|
(fold-left
|
|
(lambda (body rcinfo)
|
|
`(group (recompile-info ,rcinfo) ,body))
|
|
body
|
|
rcinfo*)))
|
|
|
|
(define requirements-join
|
|
(lambda (req* maybe-collected-invoke-req*)
|
|
(define (->libreq node)
|
|
(make-libreq
|
|
(library-node-path node)
|
|
(library-node-version node)
|
|
(library-node-uid node)))
|
|
(if maybe-collected-invoke-req*
|
|
(let f ([invoke-req* maybe-collected-invoke-req*])
|
|
(if (null? invoke-req*)
|
|
req*
|
|
(let* ([invoke-req (car invoke-req*)] [uid (library-node-uid invoke-req)])
|
|
(if (memp (lambda (req) (eq? (libreq-uid req) uid)) req*)
|
|
(f (cdr invoke-req*))
|
|
(cons (->libreq invoke-req) (f (cdr invoke-req*)))))))
|
|
req*)))
|
|
|
|
(define add-library/rt-records
|
|
(lambda (maybe-ht node* body)
|
|
(fold-left
|
|
(lambda (body node)
|
|
(if (library-node-binary? node)
|
|
body
|
|
(let* ([info (library-node-rtinfo node)]
|
|
[uid (library-info-uid info)])
|
|
`(group (revisit-only
|
|
(library/rt-info
|
|
,(make-library/rt-info
|
|
(library-info-path info)
|
|
(library-info-version info)
|
|
uid
|
|
(library-node-visible? node)
|
|
(requirements-join
|
|
(library/rt-info-invoke-req* info)
|
|
(and maybe-ht (symbol-hashtable-ref maybe-ht uid #f))))))
|
|
,body))))
|
|
body node*)))
|
|
|
|
(define add-library/ct-records
|
|
(lambda (maybe-ht visit-lib* body)
|
|
(fold-left
|
|
(lambda (body visit-lib)
|
|
(if (library-node-binary? visit-lib)
|
|
body
|
|
(let* ([info (library-node-ctinfo visit-lib)]
|
|
[uid (library-info-uid info)])
|
|
`(group (visit-only
|
|
(library/ct-info
|
|
,(make-library/ct-info
|
|
(library-info-path info)
|
|
(library-info-version info)
|
|
uid
|
|
(library-node-visible? visit-lib)
|
|
(requirements-join
|
|
(library/ct-info-import-req* info)
|
|
(and maybe-ht (symbol-hashtable-ref maybe-ht uid #f)))
|
|
(library/ct-info-visit-visit-req* info)
|
|
(library/ct-info-visit-req* info))))
|
|
,body))))
|
|
body visit-lib*)))
|
|
|
|
(define add-program-record
|
|
(lambda (node body)
|
|
`(group (revisit-only
|
|
(program-info
|
|
,(make-program-info
|
|
(program-node-uid node)
|
|
; NB: possibly list direct or indirect binary library reqs here
|
|
(program-node-invoke-req* node))))
|
|
,body)))
|
|
|
|
(define add-visit-lib-install*
|
|
(lambda (visit-lib* body)
|
|
(fold-left (lambda (body visit-lib)
|
|
(if (library-node-binary? visit-lib)
|
|
body
|
|
`(group (visit-only ,(build-install-library/ct-code visit-lib)) ,body)))
|
|
body visit-lib*)))
|
|
|
|
(define build-cluster*
|
|
(lambda (node* ht)
|
|
(define (add-deps! node deps)
|
|
(symbol-hashtable-set! ht (library-node-uid node) deps))
|
|
(define (s-entry/binary node* rcluster* deps)
|
|
(if (null? node*)
|
|
(reverse rcluster*)
|
|
(let ([node (car node*)])
|
|
(if (library-node-binary? node)
|
|
(s-entry/binary (cdr node*) rcluster* (cons node deps))
|
|
(begin
|
|
(add-deps! node deps)
|
|
(s-source (cdr node*) (list node) rcluster* (list node)))))))
|
|
(define (s-source node* rnode* rcluster* deps)
|
|
(if (null? node*)
|
|
(reverse (cons (reverse rnode*) rcluster*))
|
|
(let ([node (car node*)])
|
|
(if (library-node-binary? node)
|
|
(s-entry/binary (cdr node*) (cons (reverse rnode*) rcluster*)
|
|
(cons node deps))
|
|
(begin
|
|
(add-deps! node deps)
|
|
(s-source (cdr node*) (cons node rnode*) rcluster* deps))))))
|
|
(s-entry/binary node* '() '())))
|
|
|
|
(define build-program-body
|
|
(lambda (program-entry node* visit-lib* invisible* rcinfo*)
|
|
(add-recompile-info rcinfo*
|
|
(add-library/rt-records #f node*
|
|
(add-library/ct-records #f visit-lib*
|
|
(add-library/ct-records #f invisible*
|
|
(add-program-record program-entry
|
|
(add-visit-lib-install* visit-lib*
|
|
(add-visit-lib-install* invisible*
|
|
`(revisit-only ,(build-combined-program-ir program-entry node*)))))))))))
|
|
|
|
(define build-library-body
|
|
(lambda (node* visit-lib* rcinfo*)
|
|
(let* ([collected-req-ht (make-hashtable symbol-hash eq?)]
|
|
[cluster* (build-cluster* node* collected-req-ht)])
|
|
(add-recompile-info rcinfo*
|
|
(add-library/rt-records collected-req-ht node*
|
|
(add-library/ct-records collected-req-ht visit-lib*
|
|
(add-visit-lib-install* visit-lib*
|
|
`(revisit-only ,(build-combined-library-ir cluster*))))))))))
|
|
|
|
(define finish-compile
|
|
(lambda (who msg ifn ofn hash-bang-line x1)
|
|
(with-object-file who ofn #f
|
|
(lambda (op)
|
|
(with-coverage-file who ofn
|
|
(lambda (source-table)
|
|
(when hash-bang-line (put-bytevector op hash-bang-line))
|
|
(when (compile-compressed) (port-file-compressed! op))
|
|
(parameterize ([$target-machine (constant machine-type-name)]
|
|
; dummy sfd for block-profile optimization
|
|
[$sfd (make-source-file-descriptor ifn #xc7 #xc7c7)]
|
|
[$block-counter 0])
|
|
(when source-table ($insert-profile-src! source-table x1))
|
|
(emit-header op (constant machine-type))
|
|
(let-values ([(rcinfo* lpinfo* final*) (compile-file-help1 x1 msg)])
|
|
(compile-file-help2 op (list rcinfo*) (list lpinfo*) (list final*))))))))))
|
|
|
|
(define write-wpo-file
|
|
(lambda (who ofn ir*)
|
|
(with-wpo-file who ofn
|
|
(lambda (wpoop)
|
|
(when wpoop
|
|
(emit-header wpoop (host-machine-type))
|
|
($with-fasl-target (host-machine-type)
|
|
(lambda ()
|
|
(parameterize ([$target-machine (machine-type)])
|
|
(let ([t ($fasl-table)])
|
|
(let ([x (fold-left (lambda (outer ir) (with-output-language (Lexpand Outer) `(group ,outer ,ir)))
|
|
(car ir*) (cdr ir*))])
|
|
($fasl-enter x t (constant annotation-all))
|
|
($fasl-start wpoop t (constant fasl-type-visit-revisit) (lambda (p) ($fasl-out x p t (constant annotation-all))))))))))))))
|
|
|
|
(define build-required-library-list
|
|
(lambda (node* visit-lib*)
|
|
(let ([ht (make-hashtable symbol-hash eq?)])
|
|
(fold-left
|
|
(lambda (ls node)
|
|
(if (and (library-node-binary? node) (not (symbol-hashtable-contains? ht (library-node-uid node))))
|
|
(cons (library-node-path node) ls)
|
|
ls))
|
|
(fold-left
|
|
(lambda (ls node)
|
|
(if (library-node-binary? node)
|
|
(begin
|
|
(symbol-hashtable-set! ht (library-node-uid node) #t)
|
|
(cons (library-node-path node) ls))
|
|
ls))
|
|
'() node*)
|
|
visit-lib*))))
|
|
|
|
;; TODO: Add automatic recompliation ala scheme import/load-library
|
|
(set-who! compile-whole-program
|
|
(rec compile-whole-program
|
|
(case-lambda
|
|
[(ifn ofn) (compile-whole-program ifn ofn #f)]
|
|
[(ifn ofn libs-visible?)
|
|
(unless (string? ifn) ($oops who "~s is not a string" ifn))
|
|
(unless (string? ofn) ($oops who "~s is not a string" ofn))
|
|
(let*-values ([(hash-bang-line ir*) (read-input-file who ifn)]
|
|
[(program-entry lib* invisible* rcinfo* no-wpo*) (build-graph who ir* ifn #t #f libs-visible?)])
|
|
(safe-assert program-entry)
|
|
(safe-assert (null? no-wpo*))
|
|
(let ([node* (topological-sort program-entry lib*)])
|
|
(finish-compile who "whole program" ifn ofn hash-bang-line
|
|
(build-program-body program-entry node* lib* invisible* rcinfo*))
|
|
(build-required-library-list node* lib*)))])))
|
|
|
|
(set-who! compile-whole-library
|
|
(lambda (ifn ofn)
|
|
(unless (string? ifn) ($oops who "~s is not a string" ifn))
|
|
(unless (string? ofn) ($oops who "~s is not a string" ofn))
|
|
(let*-values ([(hash-bang-line ir*) (read-input-file who ifn)]
|
|
[(no-program lib* invisible* rcinfo* wpo*) (build-graph who ir* ifn #f (generate-wpo-files) #t)])
|
|
(safe-assert (not no-program))
|
|
(safe-assert (null? invisible*))
|
|
(safe-assert (or (not (generate-wpo-files)) (not (null? wpo*))))
|
|
(when (null? lib*) ($oops "did not find libraries in input file ~s" ifn))
|
|
(let ([node* (topological-sort #f lib*)])
|
|
(write-wpo-file who ofn wpo*)
|
|
(finish-compile who "whole library" ifn ofn hash-bang-line
|
|
(build-library-body node* lib* rcinfo*))
|
|
(build-required-library-list node* lib*))))))
|
|
|
|
(set! $c-make-code
|
|
(lambda (func subtype free name arity-mask size code-list info pinfo*)
|
|
(let ([code `(code ,func
|
|
,subtype
|
|
,free
|
|
,(if (symbol? name)
|
|
(symbol->string name)
|
|
(and (string? name) name))
|
|
,arity-mask
|
|
,size
|
|
,code-list
|
|
,info
|
|
,pinfo*)])
|
|
(set-$c-func-code-record! func code)
|
|
code)))
|
|
|
|
(set! $c-make-closure
|
|
(lambda (func)
|
|
(or ($c-func-closure-record func)
|
|
(let ([x `(closure . ,func)])
|
|
(set-$c-func-closure-record! func x)
|
|
x))))
|
|
|
|
(set-who! compile
|
|
(rec compile
|
|
(case-lambda
|
|
[(x0)
|
|
(compile x0
|
|
(if (eq? (subset-mode) 'system)
|
|
($system-environment)
|
|
(interaction-environment)))]
|
|
[(x0 env-spec)
|
|
(define-pass expand-Lexpand : Lexpand (ir) -> Lsrc ()
|
|
(Inner : Inner (ir) -> Expr ()
|
|
[,lsrc lsrc]
|
|
[(program ,uid ,body) ($build-invoke-program uid body)]
|
|
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
|
|
($build-install-library/ct-code uid export-id* import-code visit-code)]
|
|
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
|
($build-install-library/rt-code uid dl* db* dv* de* body)]
|
|
[else (sorry! who "unexpected Lexpand record ~s" ir)])
|
|
(Outer : Outer (ir) -> Expr ()
|
|
[(group ,[e1] ,[e2]) `(seq ,e1 ,e2)]
|
|
[,inner (Inner inner)]
|
|
[else (sorry! who "unexpected Lexpand record ~s" ir)]))
|
|
(unless (environment? env-spec) ($oops who "~s is not an environment" env-spec))
|
|
((parameterize ([$target-machine (constant machine-type-name)] [$sfd #f])
|
|
(let* ([x1 (expand-Lexpand ($pass-time 'expand (lambda () (expand x0 env-spec #t))))]
|
|
[waste ($uncprep x1 #t)] ; populate preinfo sexpr fields
|
|
[waste (when (and (expand-output) (not ($noexpand? x0)))
|
|
(pretty-print ($uncprep x1) (expand-output))
|
|
(flush-output-port (expand-output)))]
|
|
[x2 ($pass-time 'cpvalid (lambda () ($cpvalid x1)))]
|
|
[x2a (let ([cpletrec-ran? #f])
|
|
(let ([x ((run-cp0)
|
|
(lambda (x)
|
|
(set! cpletrec-ran? #t)
|
|
(let ([x ($pass-time 'cp0 (lambda () ($cp0 x)))])
|
|
($pass-time 'cpletrec (lambda () ($cpletrec x)))))
|
|
x2)])
|
|
(if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))]
|
|
[x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))]
|
|
[x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))])
|
|
(when (and (expand/optimize-output) (not ($noexpand? x0)))
|
|
(pretty-print ($uncprep x2b) (expand/optimize-output))
|
|
(flush-output-port (expand/optimize-output)))
|
|
(if (and (compile-interpret-simple)
|
|
(not ($assembly-output))
|
|
(cheat? x2b))
|
|
(lambda () (cheat-eval x2b))
|
|
($compile-backend x2b)))))])))
|
|
|
|
(set! $compile-backend
|
|
(lambda (x2)
|
|
(c-mkcode (c-compile x2))))
|
|
|
|
(let ()
|
|
(define emit-boot-header
|
|
(lambda (op machine bootfiles)
|
|
(emit-header op (constant machine-type) (map path-root (map path-last bootfiles)))
|
|
(when (null? bootfiles)
|
|
(parameterize ([$target-machine machine] [$sfd #f])
|
|
(c-print-fasl ($np-boot-code 'error-invoke) op (constant fasl-type-visit-revisit))
|
|
(c-print-fasl ($np-boot-code 'invoke) op (constant fasl-type-visit-revisit))
|
|
($fasl-base-rtd #!base-rtd op)))))
|
|
|
|
(define do-make-boot-file
|
|
(lambda (who outfn machine bootfile* infn*)
|
|
(unless (string? outfn) ($oops who "~s is not a string" outfn))
|
|
(unless (symbol? machine) ($oops who "~s is not a symbol" machine))
|
|
(unless (eq? machine (constant machine-type-name))
|
|
($oops who "compiler for ~s is not loaded" machine))
|
|
(unless (and (list? bootfile*) (andmap string? bootfile*))
|
|
($oops who "~s is not a list of strings" bootfile*))
|
|
(for-each
|
|
(lambda (infn) (unless (string? infn) ($oops who "~s is not a string" infn)))
|
|
infn*)
|
|
(with-object-file who outfn
|
|
(lambda (op)
|
|
(with-coverage-file who outfn
|
|
(lambda (source-table)
|
|
(unless (and (eq? who 'make-boot-file) (null? bootfile*))
|
|
(emit-boot-header op machine bootfile*))
|
|
(for-each
|
|
(lambda (infn)
|
|
(let ([ip ($open-file-input-port who infn (file-options compressed))])
|
|
(on-reset (close-port ip)
|
|
(if ($compiled-file-header? ip)
|
|
(begin
|
|
(let* ([bufsiz (file-buffer-size)] [buf (make-bytevector bufsiz)])
|
|
(let loop ()
|
|
(let ([n (get-bytevector-n! ip buf 0 bufsiz)])
|
|
(unless (eof-object? n)
|
|
(put-bytevector op buf 0 n)
|
|
(loop)))))
|
|
(when source-table
|
|
(guard (c [else (void)])
|
|
(let ([ip ($open-file-input-port who (new-extension "covin" infn)
|
|
(file-options compressed)
|
|
(buffer-mode block)
|
|
(current-transcoder))])
|
|
(on-reset (close-port ip)
|
|
(get-source-table! ip source-table))
|
|
(close-port ip)))))
|
|
(let ([sfd ($source-file-descriptor infn ip)])
|
|
; whack ip so close-port calls close the text port
|
|
(set! ip (transcoded-port ip (current-transcoder)))
|
|
(compile-file-help op #f #f source-table machine sfd ($make-read ip sfd 0) outfn))))
|
|
(close-port ip)))
|
|
infn*)))))))
|
|
|
|
(define do-make-boot-header
|
|
; create boot loader (invoke) for entry into Scheme from C
|
|
(lambda (who out machine bootfiles)
|
|
(unless (string? out) ($oops who "~s is not a string" out))
|
|
(unless (symbol? machine) ($oops who "~s is not a symbol" machine))
|
|
(unless (eq? machine (constant machine-type-name))
|
|
($oops who "compiler for ~s is not loaded" machine))
|
|
(for-each (lambda (x)
|
|
(unless (string? x)
|
|
($oops who "~s is not a string" x)))
|
|
bootfiles)
|
|
(with-object-file who out
|
|
(lambda (op)
|
|
(emit-boot-header op machine bootfiles)))))
|
|
|
|
(set-who! make-boot-file
|
|
(lambda (outfn bootfile* . infn*)
|
|
(do-make-boot-file who outfn (machine-type) bootfile* infn*)))
|
|
|
|
(set-who! $make-boot-file
|
|
(lambda (outfn machine bootfile* . infn*)
|
|
(do-make-boot-file who outfn machine bootfile* infn*)))
|
|
|
|
(set-who! make-boot-header
|
|
; exported interface: machine-type implicit and requires one or more
|
|
; subordinate boot files
|
|
(lambda (out bootfile . bootfiles)
|
|
(do-make-boot-header who out (machine-type) (cons bootfile bootfiles))))
|
|
|
|
(set-who! $make-boot-header
|
|
; create boot loader (invoke) for entry into Scheme from C
|
|
(lambda (out machine . bootfiles)
|
|
(do-make-boot-header who out machine bootfiles))))
|
|
|
|
(let ()
|
|
(define (libreq-hash x) (symbol-hash (libreq-uid x)))
|
|
(define (libreq=? x y) (eq? (libreq-uid x) (libreq-uid y)))
|
|
(define do-concatenate-object-files
|
|
(lambda (who outfn infn*)
|
|
(unless (string? outfn) ($oops who "~s is not a string" outfn))
|
|
(for-each (lambda (infn) (unless (string? infn) ($oops who "~s is not a string" infn))) infn*)
|
|
(let ([import-ht (make-hashtable libreq-hash libreq=?)]
|
|
[include-ht (make-hashtable string-hash string=?)])
|
|
(let in-loop ([infn* infn*] [rip* '()])
|
|
(if (null? infn*)
|
|
(let ([ip* (reverse rip*)])
|
|
(with-object-file who outfn
|
|
(lambda (op)
|
|
(emit-header op (constant machine-type))
|
|
(c-print-fasl `(object ,(make-recompile-info
|
|
(vector->list (hashtable-keys import-ht))
|
|
(vector->list (hashtable-keys include-ht))))
|
|
op (constant fasl-type-visit-revisit))
|
|
(for-each (lambda (ip)
|
|
(let loop () ;; NB: This loop consumes one entry past the last library/program info record,
|
|
;; which we presume is the #t end-of-header marker.
|
|
(let ([ty (lookahead-u8 ip)])
|
|
(unless (eof-object? ty)
|
|
;; perhaps should verify ty here.
|
|
(let ([x (fasl-read ip)])
|
|
(when (or (library-info? x) (program-info? x))
|
|
(c-print-fasl `(object ,x) op ty)
|
|
(loop)))))))
|
|
ip*)
|
|
;; inserting #t after lpinfo as an end-of-header marker
|
|
(c-print-fasl `(object #t) op (constant fasl-type-visit-revisit))
|
|
(let* ([bufsiz (file-buffer-size)] [buf (make-bytevector bufsiz)])
|
|
(for-each (lambda (ip)
|
|
(let loop ()
|
|
(let ([n (get-bytevector-n! ip buf 0 bufsiz)])
|
|
(unless (eof-object? n)
|
|
(put-bytevector op buf 0 n)
|
|
(loop))))
|
|
(close-port ip))
|
|
ip*)))))
|
|
(let* ([fn (car infn*)]
|
|
[ip ($open-file-input-port who fn)])
|
|
(on-reset (close-port ip)
|
|
;; NB: Does not currently support files beginning with a #! line. Add that here if desired.
|
|
(port-file-compressed! ip)
|
|
(unless ($compiled-file-header? ip) ($oops who "missing header for compiled file ~s" fn))
|
|
(let ([rcinfo (fasl-read ip)])
|
|
(unless (recompile-info? rcinfo) ($oops who "expected recompile info at start of ~s, found ~a" fn rcinfo))
|
|
(for-each
|
|
(lambda (x)
|
|
;; NB: this could be enhanced to perform additional checks for compatible versions
|
|
(hashtable-set! import-ht x x))
|
|
(recompile-info-import-req* rcinfo))
|
|
(for-each
|
|
(lambda (x) (hashtable-set! include-ht x #t))
|
|
(recompile-info-include-req* rcinfo))
|
|
(in-loop (cdr infn*) (cons ip rip*))
|
|
))))))))
|
|
|
|
(set-who! concatenate-object-files
|
|
(lambda (outfn infn0 . infn*)
|
|
(do-concatenate-object-files who outfn (cons infn0 infn*))))
|
|
)
|
|
|
|
(set-who! compile-port
|
|
(rec compile-port
|
|
(case-lambda
|
|
[(ip op) (compile-port ip op #f)]
|
|
[(ip op sfd) (compile-port ip op sfd #f)]
|
|
[(ip op sfd wpoop) (compile-port ip op sfd wpoop #f)]
|
|
[(ip op sfd wpoop covop) (compile-port ip op sfd wpoop covop (constant machine-type-name))]
|
|
[(ip op sfd wpoop covop machine) (compile-port ip op sfd wpoop covop machine #f)]
|
|
[(ip op sfd wpoop covop machine hostop)
|
|
(unless (and (input-port? ip) (textual-port? ip))
|
|
($oops who "~s is not a textual input port" ip))
|
|
(unless (and (output-port? op) (binary-port? op))
|
|
($oops who "~s is not a binary output port" op))
|
|
(when sfd
|
|
(unless (source-file-descriptor? sfd)
|
|
($oops who "~s is not a source-file descriptor or #f" sfd)))
|
|
(when wpoop
|
|
(unless (and (output-port? wpoop) (binary-port? wpoop))
|
|
($oops who "~s is not a binary output port or #f" wpoop)))
|
|
(when covop
|
|
(unless (and (output-port? covop) (textual-port? covop))
|
|
($oops who "~s is not a textual output port or #f" covop)))
|
|
(unless (symbol? machine) ($oops who "~s is not a symbol" machine))
|
|
(unless (eq? machine (constant machine-type-name))
|
|
($oops who "compiler for ~s is not loaded" machine))
|
|
(when hostop
|
|
(unless (and (output-port? hostop) (binary-port? hostop))
|
|
($oops who "~s is not a binary output port or #f" hostop)))
|
|
(let ([source-table (and covop (make-source-table))])
|
|
(let ([fp (and (port-has-port-position? ip)
|
|
(let ([fp (port-position ip)])
|
|
(if ($port-flags-set? ip (constant port-flag-char-positions))
|
|
fp
|
|
(and (eqv? fp 0) fp))))])
|
|
(compile-file-help op hostop wpoop source-table machine sfd ($make-read ip sfd fp) #f)
|
|
(when covop (put-source-table covop source-table))))])))
|
|
|
|
(set-who! compile-to-port
|
|
(rec compile-to-port
|
|
(case-lambda
|
|
[(sexpr* op) (compile-to-port sexpr* op #f)]
|
|
[(sexpr* op sfd) (compile-to-port sexpr* op sfd #f)]
|
|
[(sexpr* op sfd wpoop) (compile-to-port sexpr* op sfd wpoop #f)]
|
|
[(sexpr* op sfd wpoop covop) (compile-to-port sexpr* op sfd wpoop covop (constant machine-type-name))]
|
|
[(sexpr* op sfd wpoop covop machine) (compile-to-port sexpr* op sfd wpoop covop machine #f)]
|
|
[(sexpr* op sfd wpoop covop machine hostop)
|
|
(define do-compile-to-port
|
|
(lambda ()
|
|
(let ([source-table (and covop (make-source-table))])
|
|
(compile-file-help op hostop wpoop source-table machine sfd
|
|
(lambda ()
|
|
(if (null? sexpr*)
|
|
(eof-object)
|
|
(let ([x (car sexpr*)])
|
|
(set! sexpr* (cdr sexpr*))
|
|
x)))
|
|
(port-name op))
|
|
(when covop (put-source-table covop source-table)))))
|
|
(unless (list? sexpr*)
|
|
($oops who "~s is not a proper list" sexpr*))
|
|
(unless (and (output-port? op) (binary-port? op))
|
|
($oops who "~s is not a binary output port" op))
|
|
(when sfd
|
|
(unless (source-file-descriptor? sfd)
|
|
($oops who "~s is not a source-file descriptor or #f" sfd)))
|
|
(when wpoop
|
|
(unless (and (output-port? wpoop) (binary-port? wpoop))
|
|
($oops who "~s is not a binary output port or #f" wpoop)))
|
|
(when covop
|
|
(unless (and (output-port? covop) (textual-port? covop))
|
|
($oops who "~s is not a textual output port or #f" covop)))
|
|
(unless (symbol? machine) ($oops who "~s is not a symbol" machine))
|
|
(unless (eq? machine (constant machine-type-name))
|
|
($oops who "compiler for ~s is not loaded" machine))
|
|
(when hostop
|
|
(unless (and (output-port? hostop) (binary-port? hostop))
|
|
($oops who "~s is not a binary output port or #f" hostop)))
|
|
(if (and (= (length sexpr*) 1) (pair? (car sexpr*)) (eq? (caar sexpr*) 'top-level-program))
|
|
(let ([library-collector (make-parameter '())])
|
|
(parameterize ([$require-libraries library-collector])
|
|
(do-compile-to-port))
|
|
(library-collector))
|
|
(do-compile-to-port))])))
|
|
|
|
(let ()
|
|
(define (in&out in)
|
|
(let ([ext (path-extension in)])
|
|
(cond
|
|
[(string=? ext "") (values (format "~a.ss" in) (format "~a.so" in))]
|
|
[(string=? ext "so") (values in (format "~a.so" in))]
|
|
[else (values in (format "~a.so" (path-root in)))])))
|
|
|
|
(define (do-compile-to-file who out hostout machine sfd do-read)
|
|
(with-object-file who out
|
|
(lambda (op)
|
|
(with-host-file who hostout
|
|
(lambda (hostop)
|
|
(with-wpo-file who out
|
|
(lambda (wpoop)
|
|
(with-coverage-file who out
|
|
(lambda (source-table)
|
|
(compile-file-help op hostop wpoop source-table machine sfd do-read out))))))))))
|
|
|
|
(define (do-compile-file who in out hostout machine r6rs?)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(unless (string? out) ($oops who "~s is not a string" out))
|
|
(unless (symbol? machine) ($oops who "~s is not a symbol" machine))
|
|
(unless (eq? machine (constant machine-type-name)) ($oops who "compiler for ~s is not loaded" machine))
|
|
(when (compile-file-message) (printf "compiling ~a with output to ~a~@[ (host output to ~a)~]\n" in out hostout))
|
|
(let ([ip ($open-file-input-port who in)])
|
|
(on-reset (close-port ip)
|
|
(let ([sfd ($source-file-descriptor in ip)])
|
|
; whack existing ip so close-port calls close the text port
|
|
(set! ip (transcoded-port ip (current-transcoder)))
|
|
(when r6rs? ($set-port-flags! ip (constant port-flag-r6rs)))
|
|
(let ([fp (let ([start-pos (port-position ip)])
|
|
(if (and (eqv? (read-char ip) #\#)
|
|
(eqv? (read-char ip) #\!)
|
|
(memv (read-char ip) '(#\space #\/)))
|
|
(let loop ([fp 3])
|
|
(let ([c (read-char ip)])
|
|
(if (eof-object? c)
|
|
fp
|
|
(let ([fp (+ fp 1)])
|
|
(if (char=? c #\newline)
|
|
fp
|
|
(loop fp))))))
|
|
(begin
|
|
(set-port-position! ip start-pos)
|
|
0)))])
|
|
(do-compile-to-file who out hostout machine sfd ($make-read ip sfd fp)))))
|
|
(close-port ip)))
|
|
|
|
(define (do-compile-script who in out machine r6rs?)
|
|
(define ($make-read-program ip sfd fp)
|
|
(let ([do-read ($make-read ip sfd fp)])
|
|
(lambda ()
|
|
(let f ([form* '()])
|
|
(let ([x (do-read)])
|
|
(if (eof-object? x)
|
|
(if (null? form*) x `(top-level-program ,@(reverse form*)))
|
|
(f (cons x form*))))))))
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(unless (string? out) ($oops who "~s is not a string" out))
|
|
(unless (symbol? machine) ($oops who "~s is not a symbol" machine))
|
|
(unless (eq? machine (constant machine-type-name)) ($oops who "compiler for ~s is not loaded" machine))
|
|
(when (compile-file-message) (printf "compiling ~a with output to ~a\n" in out))
|
|
(let ([ip ($open-file-input-port who in)])
|
|
(on-reset (close-port ip)
|
|
(let ([sfd ($source-file-descriptor in ip)])
|
|
; whack existing ip so close-port calls close the text port
|
|
(set! ip (transcoded-port ip (current-transcoder)))
|
|
(when r6rs? ($set-port-flags! ip (constant port-flag-r6rs)))
|
|
(let ([start-pos (port-position ip)])
|
|
(if (and (eqv? (read-char ip) #\#)
|
|
(eqv? (read-char ip) #\!)
|
|
(memv (lookahead-char ip) '(#\space #\/)))
|
|
; copy #! line. open output file w/o compression
|
|
(with-object-file who out #f
|
|
(lambda (op)
|
|
(with-wpo-file who out #f
|
|
(lambda (wpoop)
|
|
(with-coverage-file who out
|
|
(lambda (source-table)
|
|
(put-u8 op (char->integer #\#))
|
|
(put-u8 op (char->integer #\!))
|
|
(when wpoop (put-u8 wpoop (char->integer #\#)))
|
|
(when wpoop (put-u8 wpoop (char->integer #\!)))
|
|
(let ([fp (let loop ([fp 2])
|
|
(let ([c (read-char ip)])
|
|
(when (eof-object? c)
|
|
($oops who "unexpected eof reading script header on ~s" in))
|
|
(let ([n (char->integer c)])
|
|
(unless (fx< n 256)
|
|
($oops who
|
|
"integer code for ~s script header character ~s is too large to copy to output port"
|
|
in c))
|
|
(put-u8 op n)
|
|
(when wpoop (put-u8 wpoop n)))
|
|
(let ([fp (+ fp 1)])
|
|
(if (char=? c #\newline) fp (loop fp)))))])
|
|
; compress remainder of file if requeseted
|
|
(when (compile-compressed)
|
|
(port-file-compressed! op)
|
|
(when wpoop (port-file-compressed! wpoop)))
|
|
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd fp) out))))))))
|
|
; no #! line. open output file w/ compression, if so directed
|
|
(with-object-file who out
|
|
(lambda (op)
|
|
(set-port-position! ip start-pos)
|
|
(with-wpo-file who out
|
|
(lambda (wpoop)
|
|
(with-coverage-file who out
|
|
(lambda (source-table)
|
|
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd 0) out)))))))))))
|
|
(close-port ip))
|
|
(unless-feature windows (chmod out #o755)))
|
|
|
|
(set-who! compile-file
|
|
(case-lambda
|
|
[(in out machine) (do-compile-file who in out #f machine #f)]
|
|
[(in out) (do-compile-file who in out #f (constant machine-type-name) #f)]
|
|
[(in)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(let-values ([(in out) (in&out in)])
|
|
(do-compile-file who in out #f (constant machine-type-name) #f))]))
|
|
|
|
(set-who! compile-library
|
|
(let ()
|
|
(define do-compile-library
|
|
(lambda (in out machine)
|
|
(do-compile-file who in out
|
|
(and (not (eq? machine (machine-type)))
|
|
(format "~a.~s" (path-root out) (machine-type)))
|
|
machine
|
|
#t)))
|
|
(case-lambda
|
|
[(in out machine) (do-compile-library in out machine)]
|
|
[(in out) (do-compile-library in out (constant machine-type-name))]
|
|
[(in)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(let-values ([(in out) (in&out in)])
|
|
(do-compile-library in out (constant machine-type-name)))])))
|
|
|
|
(set-who! compile-script
|
|
(case-lambda
|
|
[(in out machine) (do-compile-script who in out machine #f)]
|
|
[(in out) (do-compile-script who in out (constant machine-type-name) #f)]
|
|
[(in)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(let-values ([(in out) (in&out in)])
|
|
(do-compile-script who in out (constant machine-type-name) #f))]))
|
|
|
|
(set-who! compile-program
|
|
(let ()
|
|
(define (do-compile-program in out machine)
|
|
(let ([library-collector (make-parameter '())])
|
|
(parameterize ([$require-libraries library-collector])
|
|
(do-compile-script who in out machine #t))
|
|
(library-collector)))
|
|
(case-lambda
|
|
[(in out machine) (do-compile-program in out machine)]
|
|
[(in out) (do-compile-program in out (constant machine-type-name))]
|
|
[(in)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(let-values ([(in out) (in&out in)])
|
|
(do-compile-program in out (constant machine-type-name)))])))
|
|
|
|
(set-who! maybe-compile-file
|
|
(case-lambda
|
|
[(in out)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(unless (string? out) ($oops who "~s is not a string" out))
|
|
($maybe-compile-file who in out compile-file)
|
|
(void)]
|
|
[(in)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(let-values ([(in out) (in&out in)])
|
|
($maybe-compile-file who in out compile-file))
|
|
(void)]))
|
|
|
|
(set-who! maybe-compile-library
|
|
(case-lambda
|
|
[(in out)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(unless (string? out) ($oops who "~s is not a string" out))
|
|
($maybe-compile-file who in out (compile-library-handler))
|
|
(void)]
|
|
[(in)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(let-values ([(in out) (in&out in)])
|
|
($maybe-compile-file who in out (compile-library-handler)))
|
|
(void)]))
|
|
|
|
(set-who! maybe-compile-program
|
|
(case-lambda
|
|
[(in out)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(unless (string? out) ($oops who "~s is not a string" out))
|
|
($maybe-compile-file who in out (compile-program-handler))]
|
|
[(in)
|
|
(unless (string? in) ($oops who "~s is not a string" in))
|
|
(let-values ([(in out) (in&out in)])
|
|
($maybe-compile-file who in out (compile-program-handler)))]))
|
|
|
|
(set-who! compile-to-file
|
|
(rec compile-to-file
|
|
(case-lambda
|
|
[(sexpr* out) (compile-to-file sexpr* out #f)]
|
|
[(sexpr* out sfd)
|
|
(unless (list? sexpr*) ($oops who "~s is not a proper list" sexpr*))
|
|
(unless (string? out) ($oops who "~s is not a string" out))
|
|
(when sfd (unless (source-file-descriptor? sfd) ($oops who "~s is not a source-file descriptor or #f" sfd)))
|
|
(let ([library? (and (= (length sexpr*) 1) (pair? (car sexpr*)) (eq? (caar sexpr*) 'library))]
|
|
[program? (and (= (length sexpr*) 1) (pair? (car sexpr*)) (eq? (caar sexpr*) 'top-level-program))])
|
|
(define (go)
|
|
(do-compile-to-file who out
|
|
(and library?
|
|
(not (eq? (constant machine-type-name) (machine-type)))
|
|
(format "~a.~s" (path-root out) (machine-type)))
|
|
(constant machine-type-name)
|
|
sfd
|
|
(lambda ()
|
|
(if (null? sexpr*)
|
|
(eof-object)
|
|
(let ([x (car sexpr*)])
|
|
(set! sexpr* (cdr sexpr*))
|
|
x)))))
|
|
(if program?
|
|
(let ([library-collector (make-parameter '())])
|
|
(parameterize ([$require-libraries library-collector]) (go))
|
|
(library-collector))
|
|
(go)))]))))
|
|
);let
|