Skip to content

Commit

Permalink
WIP fix library-exports for library that has is loaded but not imported
Browse files Browse the repository at this point in the history 
- revised gensyms for modified record types, but maybe missed something?
- have to make a second time to quash errors like the following in the
  first make
    exception in $fasl-file-equal?: vector comparison failed while
    comparing ../boot/a6le/sbb and ../boot/a6le/petite.boot within
    fasl entry 935
  • Loading branch information
@owaddell-beckman
owaddell-beckman committed Jun 4, 2018
1 parent 343c09a commit b403fad
Show file tree
Hide file tree
Showing 4 changed files with 63 additions and 16 deletions.
33 changes: 33 additions & 0 deletions mats/8.ms
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10854,6 +10854,39 @@
(load-library "testfile-li3.so")
(library-object-filename '(testfile-li3)))
"testfile-li3.so")
(begin
(define (test-library-info file)
(separate-eval
`(load-library ,file)
;; no import here
'(begin
(define (show f)
(guard (e [else (display-condition e) (newline)])
(pretty-print (f '(testfile-li3)))))
(show library-object-filename)
(show library-requirements)
(show library-version)
(show library-exports))
;; now import
'(import (testfile-li3))
'(show library-exports)))
#t)
(equal?
(test-library-info "testfile-li3.ss")
(string-append
"#f\n"
"((rnrs (6)))\n"
"()\n"
"(x)\n"
"(x)\n"))
(equal?
(test-library-info "testfile-li3.so")
(string-append
"\"testfile-li3.so\"\n"
"((rnrs (6)))\n"
"()\n"
"(x)\n"
"(x)\n"))
)

(mat rnrs-eval
Expand Down
1 change: 1 addition & 0 deletions s/compile.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1312,6 +1312,7 @@
(library-info-path info)
(library-info-version info)
(library-info-uid info)
(library/ct-info-interface-binding info)
(library/ct-info-include-req* info)
(library/ct-info-import-req* info)
(library/ct-info-visit-visit-req* info)
Expand Down
3 changes: 2 additions & 1 deletion s/expand-lang.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,13 +38,14 @@
(define-record-type library/ct-info
(parent library-info)
(fields
(immutable interface-binding)
; NB: include-req* should go away with new recompile support that uses recompile-info
(immutable include-req*)
(immutable import-req*)
(immutable visit-visit-req*)
(immutable visit-req*)
(immutable clo*))
(nongenerative #{library/ct-info fgf0koeh2zn6ajlujfyoyf-3})
(nongenerative #{library/ct-info fgf0koeh2zn6ajlujfyoyf-4})
(sealed #t))

(define-record-type library/rt-info
Expand Down
42 changes: 27 additions & 15 deletions s/syntax.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2351,6 +2351,7 @@

(define-record-type ctdesc
(fields
(immutable interface-binding) ; interface binding from chi-top-library
(immutable include-req*) ; libraries included when this library was compiled
(immutable import-req*) ; libraries imported when this library was imported
(immutable visit-visit-req*) ; libraries that must be visited (for meta definitions) when this library is visited
Expand All @@ -2361,7 +2362,7 @@
(mutable export-id*) ; ids that need to be reset when visit-code raises an exception
(mutable import-code)
(mutable visit-code))
(nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-2})
(nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-3})
(sealed #t))

(define-record-type rtdesc
Expand All @@ -2375,7 +2376,7 @@
(module (libdesc-import-req* libdesc-include-req* libdesc-visit-visit-req* libdesc-visit-req*
libdesc-loaded-import-reqs libdesc-loaded-import-reqs-set!
libdesc-loaded-visit-reqs libdesc-loaded-visit-reqs-set!
libdesc-import-code libdesc-import-code-set!
libdesc-interface-binding libdesc-import-code libdesc-import-code-set!
libdesc-visit-code libdesc-visit-code-set!
libdesc-visit-id* libdesc-visit-id*-set!
libdesc-clo* libdesc-clo*-set!)
Expand Down Expand Up @@ -2407,6 +2408,9 @@
(define libdesc-loaded-visit-reqs-set!
(lambda (desc x)
(ctdesc-loaded-visit-reqs-set! (get-ctdesc desc) x)))
(define libdesc-interface-binding
(lambda (desc)
(ctdesc-interface-binding (get-ctdesc desc))))
(define libdesc-import-code
(lambda (desc)
(ctdesc-import-code (get-ctdesc desc))))
Expand Down Expand Up @@ -2642,7 +2646,7 @@
(install-library library-path library-uid
; import-code & visit-code is #f because vthunk invocation has already set up compile-time environment
(make-libdesc library-path library-version outfn #f
(make-ctdesc include-req* import-req* visit-visit-req* visit-req* '() #t #t '() #f #f)
(make-ctdesc interface-binding include-req* import-req* visit-visit-req* visit-req* '() #t #t '() #f #f)
(make-rtdesc invoke-req* #t
(top-level-eval-hook
(build-lambda no-source '()
Expand All @@ -2666,6 +2670,7 @@
build-void
(lambda ()
(make-library/ct-info library-path library-version library-uid
interface-binding
include-req* import-req* visit-visit-req* visit-req*
(fold-left (lambda (clo* dl db)
(if dl
Expand All @@ -2690,13 +2695,13 @@
ls)))
'() env*)
; setup code
`(,(build-cte-install bound-id (build-data no-source interface-binding) '*system*)
,@(if (null? env*)
'()
`(,(build-sequence no-source
(map (lambda (x)
(build-cte-install (car x) (build-data no-source (cdr x)) #f))
env*)))))
;; import-library installs the interface-binding
(if (null? env*)
'()
`(,(build-sequence no-source
(map (lambda (x)
(build-cte-install (car x) (build-data no-source (cdr x)) #f))
env*))))
; visit code
vcode*)))))))))
(let ([mb (car mb*)] [mb* (cdr mb*)])
Expand Down Expand Up @@ -5020,10 +5025,15 @@

(set-who! library-exports
(lambda (libref)
(let* ([binding (lookup-global (get-lib who libref))]
[iface (get-indirect-interface (binding-value binding))])
(unless (and (eq? (binding-type binding) '$module) (interface? iface))
($oops who "unexpected binding ~s" binding))
(let* ([label (get-lib who libref)]
[ctdesc (libdesc-ctdesc (get-library-descriptor label))]
[interface-binding (and ctdesc (ctdesc-interface-binding ctdesc))]
[iface
(and (pair? interface-binding)
(eq? (binding-type interface-binding) '$module)
(get-indirect-interface (binding-value interface-binding)))])
(unless (interface? iface)
($oops who "no compile-time information for library ~s" libref))
(let* ([exports (interface-exports iface)]
[n (vector-length exports)])
(let loop ([i 0] [ls '()])
Expand Down Expand Up @@ -5151,6 +5161,7 @@
(for-each (lambda (req) (import-library (libreq-uid req))) (libdesc-import-req* desc))
($install-library-clo-info (libdesc-clo* desc))
(libdesc-clo*-set! desc '())
($sc-put-cte uid (libdesc-interface-binding desc) '*system*)
(p)))]))]
[else ($oops #f "library ~:s is not defined" uid)])))

Expand Down Expand Up @@ -5417,6 +5428,7 @@
($oops #f "attempting to re-install compile-time part of library ~s" (library-info-path linfo/ct))))
(install-library/ct-desc (library-info-path linfo/ct) (library-info-version linfo/ct) uid ofn
(make-ctdesc
(library/ct-info-interface-binding linfo/ct)
(library/ct-info-include-req* linfo/ct)
(library/ct-info-import-req* linfo/ct)
(library/ct-info-visit-visit-req* linfo/ct)
Expand Down Expand Up @@ -5511,7 +5523,7 @@
(lambda (path uid)
(install-library path uid
(make-libdesc path (if (eq? (car path) 'rnrs) '(6) '()) #f #t
(make-ctdesc '() '() '() '() '() #t #t '() #f #f)
(make-ctdesc (get-global-definition-hook uid) '() '() '() '() '() #t #t '() #f #f)
(make-rtdesc '() #t #f)))))
(set! $make-base-modules
(lambda ()
Expand Down

0 comments on commit b403fad

Please sign in to comment.