mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00
Code Activity

Top-level lookups raise exceptions in run-time

Browse source 
* module/language/cps/reify-primitives.scm (reify-lookup):
* module/language/tree-il/compile-cps.scm (toplevel-box): Instead of
  checking that the result of module-variable is a variable, and
  possibly checking that it's bound, we just call intrinsics that throw
  exceptions if the variable isn't bound.  This reduces useless inlining
  that can't inform CPS optimizations, as they are tangled in diamond
  control flow.
This commit is contained in:
Andy Wingo 2020-05-11 10:22:56 +02:00
parent 4274d615cc
commit 85124b0d69
2 changed files with 10 additions and 50 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -201,34 +201,14 @@
(wrap-unary cps k src 's64->u64 'u64->s64 'ulsh/immediate param a)) (wrap-unary cps k src 's64->u64 'u64->s64 'ulsh/immediate param a))
(define (reify-lookup cps src mod-var name assert-bound? have-var) (define (reify-lookup cps src mod-var name assert-bound? have-var)
(define (%lookup cps kbad k src mod-var name-var var assert-bound?)
(if assert-bound?
(with-cps cps
(letv val)
(letk kcheck
($kargs ('val) (val)
($branch k kbad src 'undefined? #f (val))))
(letk kref
($kargs () ()
($continue kcheck src
($primcall 'scm-ref/immediate '(box . 1) (var)))))
($ (%lookup kbad kref src mod-var name-var var #f)))
(with-cps cps
(letk kres
($kargs ('var) (var)
($branch kbad k src 'heap-object? #f (var))))
(build-term
($continue kres src
($primcall 'module-variable #f (mod-var name-var)))))))
(define %unbound
#(unbound-variable #f "Unbound variable: ~S"))
(with-cps cps (with-cps cps
(letv name-var var) (letv name-var var)
(let$ good (have-var var)) (let$ body (have-var var))
(letk kgood ($kargs () () ,good)) (letk kres ($kargs ('var) (var) ,body))
(letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var)))) (letk klookup ($kargs ('name) (name-var)
(let$ body (%lookup kbad kgood src mod-var name-var var assert-bound?)) ($continue kres src
(letk klookup ($kargs ('name) (name-var) ,body)) ($primcall (if assert-bound? 'lookup-bound 'lookup) #f
(mod-var name-var)))))
(build-term ($continue klookup src ($const name))))) (build-term ($continue klookup src ($const name)))))
(define (reify-resolve-module cps k src module public?) (define (reify-resolve-module cps k src module public?)

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

@ -1401,36 +1401,16 @@
scope-id)) scope-id))
(define (toplevel-box cps src name bound? have-var) (define (toplevel-box cps src name bound? have-var)
(define %unbound
#(unbound-variable #f "Unbound variable: ~S"))
(match (current-topbox-scope) (match (current-topbox-scope)
(#f (#f
(with-cps cps (with-cps cps
(letv mod name-var box) (letv mod name-var box)
(letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var)))) (let$ body (have-var box))
(let$ body (letk kbox ($kargs ('box) (box) ,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) (letk kname ($kargs ('name) (name-var)
($continue kbox src ($continue kbox src
($primcall 'module-variable #f (mod name-var))))) ($primcall (if bound? 'lookup-bound 'lookup) #f
(mod name-var)))))
(letk kmod ($kargs ('mod) (mod) (letk kmod ($kargs ('mod) (mod)
($continue kname src ($const name)))) ($continue kname src ($const name))))
(build-term (build-term