mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 14:30: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))
(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
(letv name-var var)
(let$ good (have-var var))
(letk kgood ($kargs () () ,good))
(letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var))))
(let$ body (%lookup kbad kgood src mod-var name-var var assert-bound?))
(letk klookup ($kargs ('name) (name-var) ,body))
(let$ body (have-var var))
(letk kres ($kargs ('var) (var) ,body))
(letk klookup ($kargs ('name) (name-var)
($continue kres src
($primcall (if assert-bound? 'lookup-bound 'lookup) #f
(mod-var name-var)))))
(build-term ($continue klookup src ($const name)))))
(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))
(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))))
(let$ body (have-var box))
(letk kbox ($kargs ('box) (box) ,body))
(letk kname ($kargs ('name) (name-var)
($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)
($continue kname src ($const name))))
(build-term