mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Use intrinsics for top-level refs outside captured scopes

Browse source 
* module/language/tree-il/compile-cps.scm (toplevel-box): Reify
  intrinsic calls for top-level references outside captured scopes.
* module/language/cps/reify-primitives.scm (compute-known-primitives):
  Update set of macro-instructions.
This commit is contained in:
Andy Wingo 2018-05-14 15:46:52 +02:00
parent ceffb5e990
commit 76eac85084
2 changed files with 44 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

3
module/language/cps/reify-primitives.scm
View file

@ -330,7 +330,8 @@
push-fluid pop-fluid fluid-ref fluid-set!
push-dynamic-state pop-dynamic-state
lsh rsh lsh/immediate rsh/immediate
cache-ref cache-set!))
cache-ref cache-set!
resolve-module lookup define!))
(let ((table (make-hash-table)))
(for-each
(match-lambda ((inst . _) (hashq-set! table inst #t)))

59
module/language/tree-il/compile-cps.scm
View file

@ -1394,23 +1394,48 @@
(scope-counter (1+ scope-id))
scope-id))
(define (toplevel-box cps src name bound? val-proc)
(define (lookup cps k)
(match (current-topbox-scope)
(#f
(with-cps cps
;; FIXME: Resolve should take name as immediate.
($ (with-cps-constants ((name name))
($ (convert-primcall k src 'resolve (list bound?) name))))))
(scope
(with-cps cps
($ (convert-primcall k src 'cached-toplevel-box
(list scope name bound?)))))))
(with-cps cps
(letv box)
(let$ body (val-proc box))
(letk kbox ($kargs ('box) (box) ,body))
($ (lookup kbox))))
(define (toplevel-box cps src name bound? have-var)
(define %unbound
#(unbound-variable #f "Unbound variable: ~S"))
(match (current-topbox-scope)
(#f
(with-cps cps
(letv mod name-var box)
(letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var))))
(let$ body
((if bound?
(lambda (cps)
(with-cps cps
(letv val)
(let$ body (have-var box))
(letk kdef ($kargs () () ,body))
(letk ktest ($kargs ('val) (val)
($branch kdef kbad src
'undefined? #f (val))))
(build-term
($continue ktest src
($primcall 'scm-ref/immediate
'(box . 1) (box))))))
(lambda (cps)
(with-cps cps
($ (have-var box)))))))
(letk ktest ($kargs () () ,body))
(letk kbox ($kargs ('box) (box)
($branch kbad ktest src 'heap-object? #f (box))))
(letk kname ($kargs ('name) (name-var)
($continue kbox src
($primcall 'lookup #f (mod name-var)))))
(letk kmod ($kargs ('mod) (mod)
($continue kname src ($const name))))
(build-term
($continue kmod src ($primcall 'current-module #f ())))))
(scope
(with-cps cps
(letv box)
(let$ body (have-var box))
(letk kbox ($kargs ('box) (box) ,body))
($ (convert-primcall kbox src 'cached-toplevel-box
(list scope name bound?)))))))
(define (module-box cps src module name public? bound? val-proc)
(with-cps cps