This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/s/compile.ss

2122 lines
104 KiB
Scheme
Raw Normal View History

2022-07-29 15:12:07 +02:00
;;; 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
(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 scheme-version) (constant machine-type))
(when hostop (emit-header hostop (constant scheme-version) (host-machine-type)))
(when wpoop (emit-header wpoop (constant scheme-version) (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
(lambda (who ofn p)
(call-with-port/cleanup ofn
($open-file-output-port who ofn
(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
(file-options replace))
p)
(p #f))))
(define with-wpo-file
(lambda (who ofn p)
(if (generate-wpo-files)
(let ([ofn (new-extension "wpo" ofn)])
(call-with-port/cleanup ofn
($open-file-output-port who ofn
(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)])
(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 scheme-version) (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)))])
(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)
(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
(lambda (op)
(with-coverage-file who ofn
(lambda (source-table)
(when hash-bang-line (put-bytevector op hash-bang-line))
(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 scheme-version) (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 (constant scheme-version) (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 scheme-version) (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)])
(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 scheme-version) (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.
(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 ($port-flags-set? op (constant port-flag-compressed)) ($compressed-warning who 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 ($port-flags-set? wpoop (constant port-flag-compressed)) ($compressed-warning who 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))
(when ($port-flags-set? hostop (constant port-flag-compressed)) ($compressed-warning who 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 ($port-flags-set? op (constant port-flag-compressed)) ($compressed-warning who 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 ($port-flags-set? wpoop (constant port-flag-compressed)) ($compressed-warning who 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))
(when ($port-flags-set? hostop (constant port-flag-compressed)) ($compressed-warning who 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
(with-object-file who out
(lambda (op)
(with-wpo-file who out
(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)))))])
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd fp) out))))))))
; no #! line
(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))
(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-program-handler)))
(void)]))
(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