# What we now call `guild' used to be known as `guile-tools'.
install-data-hook:
- cd $(DESTDIR)$(bindir) && rm -f guile-tools$(EXEEXT) && \
- $(LN_S) guild$(EXEEXT) guile-tools$(EXEEXT)
+ guild="`echo $(ECHO_N) guild \
+ | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ; \
+ guile_tools="`echo $(ECHO_N) guile-tools \
+ | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ; \
+ cd $(DESTDIR)$(bindir) && rm -f "$$guile_tools" && \
+ $(LN_S) "$$guild" "$$guile_tools"
pkgconfigdir = $(libdir)/pkgconfig
-pkgconfig_DATA = guile-2.0.pc
+pkgconfig_DATA = guile-2.2.pc
## FIXME: in the future there will be direct automake support for
## doing this. When that happens, switch over.
(false-if-exception
(module-ref env name))))
proc)))
- (if (or (lambda? proc*) (procedure? proc*))
- (validate-arity proc* call (lambda? proc*)))))
+ (cond ((lambda? proc*)
- (validate-arity proc* application #t))
++ (validate-arity proc* call #t))
+ ((procedure? proc*)
- (validate-arity proc* application #f)))))
++ (validate-arity proc* call #f)))))
toplevel-calls)))
(make-arity-info vlist-null vlist-null vlist-null)))
(($ <const> _ (? boolean?)) #t)
(_ (eq? ctx 'test))))
- (($ <application> _
- ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
- (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+ (define (singly-valued-expression? x ctx)
+ (match x
+ (($ <const>) #t)
+ (($ <lexical-ref>) #t)
+ (($ <void>) #t)
+ (($ <lexical-ref>) #t)
+ (($ <primitive-ref>) #t)
+ (($ <module-ref>) #t)
+ (($ <toplevel-ref>) #t)
++ (($ <primcall> _ (? singly-valued-primitive?)) #t)
++ (($ <primcall> _ 'values (val)) #t)
+ (($ <lambda>) #t)
+ (_ (eq? ctx 'value))))
+
(define* (cse exp)
"Eliminate common subexpressions in EXP."
(make-const src #f))
(($ <conditional> src test consequent alternate)
(make-conditional src test (negate consequent ctx) (negate alternate ctx)))
- (($ <application> _ ($ <primitive-ref> _ 'not)
+ (($ <primcall> _ 'not
((and x (? (cut boolean-valued-expression? <> ctx)))))
x)
- (($ <application> src
- ($ <primitive-ref> _ (and pred (? negate-primitive)))
- args)
- (make-application src
- (make-primitive-ref #f (negate-primitive pred))
- args))
+ (($ <primcall> src (and pred (? negate-primitive)) args)
+ (make-primcall src (negate-primitive pred) args))
(_
- (make-application #f (make-primitive-ref #f 'not) (list exp)))))
+ (make-primcall #f 'not (list exp)))))
- (define (bailout? exp)
- (causes-effects? (compute-effects exp) &definite-bailout))
-
- (define (struct-nfields x)
- (/ (string-length (symbol->string (struct-layout x))) 2))
-
- (define hash-bits (logcount most-positive-fixnum))
- (define hash-depth 4)
- (define hash-width 3)
- (define (hash-expression exp)
- (define (hash-exp exp depth)
- (define (rotate x bits)
- (logior (ash x (- bits))
- (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
- (define (mix h1 h2)
- (logxor h1 (rotate h2 8)))
- (define (hash-struct s)
- (let ((len (struct-nfields s))
- (h (hashq (struct-vtable s) most-positive-fixnum)))
- (if (zero? depth)
- h
- (let lp ((i (max (- len hash-width) 1)) (h h))
- (if (< i len)
- (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
- h)))))
- (define (hash-list l)
- (let ((h (hashq 'list most-positive-fixnum)))
- (if (zero? depth)
- h
- (let lp ((l l) (width 0) (h h))
- (if (< width hash-width)
- (lp (cdr l) (1+ width)
- (mix (hash-exp (car l) (1+ depth)) h))
- h)))))
- (cond
- ((struct? exp) (hash-struct exp))
- ((list? exp) (hash-list exp))
- (else (hash exp most-positive-fixnum))))
- (hash-exp exp 0))
-
- (define (expressions-equal? a b)
- (cond
- ((struct? a)
- (and (struct? b)
- (eq? (struct-vtable a) (struct-vtable b))
- ;; Assume that all structs are tree-il, so we skip over the
- ;; src slot.
- (let lp ((n (1- (struct-nfields a))))
- (or (zero? n)
- (and (expressions-equal? (struct-ref a n) (struct-ref b n))
- (lp (1- n)))))))
- ((pair? a)
- (and (pair? b)
- (expressions-equal? (car a) (car b))
- (expressions-equal? (cdr a) (cdr b))))
- (else
- (equal? a b))))
-
(define (hasher n)
(lambda (x size) (modulo n size)))
(or (hashq-ref cache exp)
(let ((effects (visit exp)))
(hashq-set! cache exp effects)
- effects)))))
-
- (define (accumulate-effects exps)
- (let lp ((exps exps) (out &no-effects))
- (if (null? exps)
- out
- (lp (cdr exps) (logior out (compute-effects (car exps)))))))
-
- (define (visit exp)
- (match exp
- (($ <const>)
- &no-effects)
- (($ <void>)
- &no-effects)
- (($ <lexical-ref> _ _ gensym)
- (if (assigned-lexical? gensym)
- &mutable-lexical
- &no-effects))
- (($ <lexical-set> _ name gensym exp)
- (logior (cause &mutable-lexical)
- (compute-effects exp)))
- (($ <let> _ names gensyms vals body)
- (logior (if (or-map assigned-lexical? gensyms)
- (cause &allocation)
- &no-effects)
- (accumulate-effects vals)
- (compute-effects body)))
- (($ <letrec> _ in-order? names gensyms vals body)
- (logior (if (or-map assigned-lexical? gensyms)
- (cause &allocation)
- &no-effects)
- (accumulate-effects vals)
- (compute-effects body)))
- (($ <fix> _ names gensyms vals body)
- (logior (if (or-map assigned-lexical? gensyms)
- (cause &allocation)
- &no-effects)
- (accumulate-effects vals)
- (compute-effects body)))
- (($ <let-values> _ producer consumer)
- (logior (compute-effects producer)
- (compute-effects consumer)
- (cause &type-check)))
- (($ <dynwind> _ winder pre body post unwinder)
- (logior (compute-effects winder)
- (compute-effects pre)
- (compute-effects body)
- (compute-effects post)
- (compute-effects unwinder)))
- (($ <dynlet> _ fluids vals body)
- (logior (accumulate-effects fluids)
- (accumulate-effects vals)
- (cause &type-check)
- (cause &fluid)
- (compute-effects body)))
- (($ <dynref> _ fluid)
- (logior (compute-effects fluid)
- (cause &type-check)
- &fluid))
- (($ <dynset> _ fluid exp)
- (logior (compute-effects fluid)
- (compute-effects exp)
- (cause &type-check)
- (cause &fluid)))
- (($ <toplevel-ref>)
- (logior &toplevel
- (cause &type-check)))
- (($ <module-ref>)
- (logior &toplevel
- (cause &type-check)))
- (($ <module-set> _ mod name public? exp)
- (logior (cause &toplevel)
- (cause &type-check)
- (compute-effects exp)))
- (($ <toplevel-define> _ name exp)
- (logior (cause &toplevel)
- (compute-effects exp)))
- (($ <toplevel-set> _ name exp)
- (logior (cause &toplevel)
- (compute-effects exp)))
- (($ <primitive-ref>)
- &no-effects)
- (($ <conditional> _ test consequent alternate)
- (let ((tfx (compute-effects test))
- (cfx (compute-effects consequent))
- (afx (compute-effects alternate)))
- (if (causes-effects? (logior tfx (logand afx cfx))
- &definite-bailout)
- (logior tfx cfx afx)
- (exclude-effects (logior tfx cfx afx)
- &definite-bailout))))
-
- ;; Zero values.
- (($ <primcall> _ 'values ())
- (cause &zero-values))
-
- ;; Effect-free primitives.
- (($ <primcall> _ (and name (? effect+exception-free-primitive?)) args)
- (logior (accumulate-effects args)
- (if (constructor-primitive? name)
- (cause &allocation)
- &no-effects)))
- (($ <primcall> _ (and name (? effect-free-primitive?)) args)
- (logior (accumulate-effects args)
- (cause &type-check)
- (if (constructor-primitive? name)
- (cause &allocation)
- (if (accessor-primitive? name)
- &mutable-data
- &no-effects))))
+ effects)))
+
+ (define (accumulate-effects exps)
+ (let lp ((exps exps) (out &no-effects))
+ (if (null? exps)
+ out
+ (lp (cdr exps) (logior out (compute-effects (car exps)))))))
+
+ (define (visit exp)
+ (match exp
+ (($ <const>)
+ &no-effects)
+ (($ <void>)
+ &no-effects)
+ (($ <lexical-ref> _ _ gensym)
+ (if (assigned-lexical? gensym)
+ &mutable-lexical
+ &no-effects))
+ (($ <lexical-set> _ name gensym exp)
+ (logior (cause &mutable-lexical)
+ (compute-effects exp)))
+ (($ <let> _ names gensyms vals body)
+ (logior (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (accumulate-effects vals)
+ (compute-effects body)))
+ (($ <letrec> _ in-order? names gensyms vals body)
+ (logior (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (accumulate-effects vals)
+ (compute-effects body)))
+ (($ <fix> _ names gensyms vals body)
+ (logior (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (accumulate-effects vals)
+ (compute-effects body)))
+ (($ <let-values> _ producer consumer)
+ (logior (compute-effects producer)
+ (compute-effects consumer)
+ (cause &type-check)))
- (($ <dynwind> _ winder body unwinder)
++ (($ <dynwind> _ winder pre body post unwinder)
+ (logior (compute-effects winder)
++ (compute-effects pre)
+ (compute-effects body)
++ (compute-effects post)
+ (compute-effects unwinder)))
+ (($ <dynlet> _ fluids vals body)
+ (logior (accumulate-effects fluids)
+ (accumulate-effects vals)
+ (cause &type-check)
+ (cause &fluid)
+ (compute-effects body)))
+ (($ <dynref> _ fluid)
+ (logior (compute-effects fluid)
+ (cause &type-check)
+ &fluid))
+ (($ <dynset> _ fluid exp)
+ (logior (compute-effects fluid)
+ (compute-effects exp)
+ (cause &type-check)
+ (cause &fluid)))
+ (($ <toplevel-ref>)
+ (logior &toplevel
+ (cause &type-check)))
+ (($ <module-ref>)
+ (logior &toplevel
+ (cause &type-check)))
+ (($ <module-set> _ mod name public? exp)
+ (logior (cause &toplevel)
+ (cause &type-check)
+ (compute-effects exp)))
+ (($ <toplevel-define> _ name exp)
+ (logior (cause &toplevel)
+ (compute-effects exp)))
+ (($ <toplevel-set> _ name exp)
+ (logior (cause &toplevel)
+ (compute-effects exp)))
+ (($ <primitive-ref>)
+ &no-effects)
+ (($ <conditional> _ test consequent alternate)
+ (let ((tfx (compute-effects test))
+ (cfx (compute-effects consequent))
+ (afx (compute-effects alternate)))
+ (if (causes-effects? (logior tfx (logand afx cfx))
+ &definite-bailout)
+ (logior tfx cfx afx)
+ (exclude-effects (logior tfx cfx afx)
+ &definite-bailout))))
+
+ ;; Zero values.
- (($ <application> _ ($ <primitive-ref> _ 'values) ())
++ (($ <primcall> _ 'values ())
+ (cause &zero-values))
+
+ ;; Effect-free primitives.
- (($ <application> _
- ($ <primitive-ref> _ (and name
- (? effect+exception-free-primitive?)))
- args)
++ (($ <primcall> _ (and name (? effect+exception-free-primitive?)) args)
+ (logior (accumulate-effects args)
+ (if (constructor-primitive? name)
+ (cause &allocation)
+ &no-effects)))
- (($ <application> _
- ($ <primitive-ref> _ (and name
- (? effect-free-primitive?)))
- args)
++ (($ <primcall> _ (and name (? effect-free-primitive?)) args)
+ (logior (accumulate-effects args)
+ (cause &type-check)
+ (if (constructor-primitive? name)
+ (cause &allocation)
+ (if (accessor-primitive? name)
+ &mutable-data
+ &no-effects))))
- ;; Lambda applications might throw wrong-number-of-args.
- (($ <call> _ ($ <lambda> _ _ body) args)
- (logior (compute-effects body)
- (accumulate-effects args)
- (cause &type-check)))
+ ;; Lambda applications might throw wrong-number-of-args.
- (($ <application> _ ($ <lambda> _ _ body) args)
++ (($ <call> _ ($ <lambda> _ _ body) args)
+ (logior (accumulate-effects args)
+ (match body
+ (($ <lambda-case> _ req #f #f #f () syms body #f)
+ (logior (compute-effects body)
+ (if (= (length req) (length args))
+ 0
+ (cause &type-check))))
+ (($ <lambda-case>)
+ (logior (compute-effects body)
+ (cause &type-check))))))
- ;; Bailout primitives.
- (($ <primcall> _ (? bailout-primitive? name) args)
- (logior (accumulate-effects args)
- (cause &definite-bailout)
- (cause &possible-bailout)))
-
- ;; A call to an unknown procedure can do anything.
- (($ <primcall> _ name args)
- (logior &all-effects-but-bailout
- (cause &all-effects-but-bailout)))
- (($ <call> _ proc args)
- (logior &all-effects-but-bailout
- (cause &all-effects-but-bailout)))
-
- (($ <lambda> _ meta body)
- &no-effects)
- (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
- (logior (exclude-effects (accumulate-effects inits)
- &definite-bailout)
- (if (or-map assigned-lexical? gensyms)
- (cause &allocation)
- &no-effects)
- (compute-effects body)
- (if alt (compute-effects alt) &no-effects)))
-
- (($ <seq> _ head tail)
- (logior
- ;; Returning zero values to a for-effect continuation is
- ;; not observable.
- (exclude-effects (compute-effects head)
- (cause &zero-values))
- (compute-effects tail)))
-
- (($ <prompt> _ tag body handler)
- (logior (compute-effects tag)
- (compute-effects body)
- (compute-effects handler)))
-
- (($ <abort> _ tag args tail)
- (logior &all-effects-but-bailout
- (cause &all-effects-but-bailout)))))
-
- compute-effects)
+ ;; Bailout primitives.
- (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
- args)
++ (($ <primcall> _ (? bailout-primitive? name) args)
+ (logior (accumulate-effects args)
+ (cause &definite-bailout)
+ (cause &possible-bailout)))
+
+ ;; A call to a lexically bound procedure, perhaps labels
+ ;; allocated.
- (($ <application> _ (and proc ($ <lexical-ref> _ _ sym)) args)
++ (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+ (cond
+ ((lookup sym)
+ => (lambda (proc)
- (compute-effects (make-application #f proc args))))
++ (compute-effects (make-call #f proc args))))
+ (else
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))))
+
+ ;; A call to an unknown procedure can do anything.
- (($ <application> _ proc args)
++ (($ <primcall> _ name args)
++ (logior &all-effects-but-bailout
++ (cause &all-effects-but-bailout)))
++ (($ <call> _ proc args)
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))
+
+ (($ <lambda> _ meta body)
+ &no-effects)
+ (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
+ (logior (exclude-effects (accumulate-effects inits)
+ &definite-bailout)
+ (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (compute-effects body)
+ (if alt (compute-effects alt) &no-effects)))
+
- (($ <sequence> _ exps)
- (let lp ((exps exps) (effects &no-effects))
- (match exps
- ((tail)
- (logior (compute-effects tail)
- ;; Returning zero values to a for-effect continuation is
- ;; not observable.
- (exclude-effects effects (cause &zero-values))))
- ((head . tail)
- (lp tail (logior (compute-effects head) effects))))))
++ (($ <seq> _ head tail)
++ (logior
++ ;; Returning zero values to a for-effect continuation is
++ ;; not observable.
++ (exclude-effects (compute-effects head)
++ (cause &zero-values))
++ (compute-effects tail)))
+
+ (($ <prompt> _ tag body handler)
+ (logior (compute-effects tag)
+ (compute-effects body)
+ (compute-effects handler)))
+
+ (($ <abort> _ tag args tail)
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))))
+
+ (compute-effects exp))
+
+ compute-effects))
'())))
(values unref simple lambda* complex)))
-(define (make-sequence* src exps)
- (let lp ((in exps) (out '()))
- (if (null? (cdr in))
- (if (null? out)
- (car in)
- (make-sequence src (reverse (cons (car in) out))))
- (let ((head (car in)))
- (record-case head
- ((<lambda>) (lp (cdr in) out))
- ((<const>) (lp (cdr in) out))
- ((<lexical-ref>) (lp (cdr in) out))
- ((<void>) (lp (cdr in) out))
- (else (lp (cdr in) (cons head out))))))))
++(define (make-seq* src head tail)
++ (record-case head
++ ((<lambda>) tail)
++ ((<const>) tail)
++ ((<lexical-ref>) tail)
++ ((<void>) tail)
++ (else (make-seq src head tail))))
++
++(define (list->seq* loc exps)
++ (if (null? (cdr exps))
++ (car exps)
++ (let lp ((exps (cdr exps)) (effects (list (car exps))))
++ (if (null? (cdr exps))
++ (make-seq* loc
++ (fold (lambda (exp tail) (make-seq* #f exp tail))
++ (car effects)
++ (cdr effects))
++ (car exps))
++ (lp (cdr exps) (cons (car exps) effects))))))
+
(define (fix-letrec! x)
(let-values (((unref simple lambda* complex) (partition-vars x)))
(post-order!
;; expression, called for effect.
((<lexical-set> gensym exp)
(if (memq gensym unref)
- (make-seq #f exp (make-void #f))
- (make-sequence* #f (list exp (make-void #f)))
++ (make-seq* #f exp (make-void #f))
x))
((<letrec> src in-order? names gensyms vals body)
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
- (list->seq
- (make-sequence*
++ (list->seq*
src
(append
;; The right-hand-sides of the unreferenced
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
- (list->seq
- (make-sequence*
++ (list->seq*
src
(append
;; unreferenced bindings, called for effect.
((test) (make-const #f #t))
(else exp)))
(($ <conditional> src condition subsequent alternate)
- (($ <application> _ _ ()) (proc exp))
+ (define (call-with-failure-thunk exp proc)
+ (match exp
- (proc (make-application #f (make-lexical-ref #f 'failure t)
- '())))))))
++ (($ <call> _ _ ()) (proc exp))
++ (($ <primcall> _ _ ()) (proc exp))
+ (($ <const>) (proc exp))
+ (($ <void>) (proc exp))
+ (($ <lexical-ref>) (proc exp))
+ (_
+ (let ((t (gensym "failure-")))
+ (record-new-temporary! 'failure t 2)
+ (make-let
+ src (list 'failure) (list t)
+ (list
+ (make-lambda
+ #f '()
+ (make-lambda-case #f '() #f #f #f '() '() exp #f)))
- (($ <conditional> src
- ($ <application> _ ($ <primitive-ref> _ 'not) (pred))
++ (proc (make-call #f (make-lexical-ref #f 'failure t)
++ '())))))))
+ (define (simplify-conditional c)
+ (match c
+ ;; Swap the arms of (if (not FOO) A B), to simplify.
++ (($ <conditional> src ($ <primcall> _ 'not (pred))
+ subsequent alternate)
+ (simplify-conditional
+ (make-conditional src pred alternate subsequent)))
+ ;; Special cases for common tests in the predicates of chains
+ ;; of if expressions.
+ (($ <conditional> src
+ ($ <conditional> src* outer-test inner-test ($ <const> _ #f))
+ inner-subsequent
+ alternate)
+ (let lp ((alternate alternate))
+ (match alternate
+ ;; Lift a common repeated test out of a chain of if
+ ;; expressions.
+ (($ <conditional> _ (? (cut tree-il=? outer-test <>))
+ other-subsequent alternate)
+ (make-conditional
+ src outer-test
+ (simplify-conditional
+ (make-conditional src* inner-test inner-subsequent
+ other-subsequent))
+ alternate))
+ ;; Likewise, but punching through any surrounding
+ ;; failure continuations.
+ (($ <let> let-src (name) (sym) ((and thunk ($ <lambda>))) body)
+ (make-let
+ let-src (list name) (list sym) (list thunk)
+ (lp body)))
+ ;; Otherwise, rotate AND tests to expose a simple
+ ;; condition in the front. Although this may result in
+ ;; lexically binding failure thunks, the thunks will be
+ ;; compiled to labels allocation, so there's no actual
+ ;; code growth.
+ (_
+ (call-with-failure-thunk
+ alternate
+ (lambda (failure)
+ (make-conditional
+ src outer-test
+ (simplify-conditional
+ (make-conditional src* inner-test inner-subsequent failure))
+ failure)))))))
+ (_ c)))
(match (for-test condition)
(($ <const> _ val)
(if val
(for-tail subsequent)
(for-tail alternate)))
- ;; Swap the arms of (if (not FOO) A B), to simplify.
- (($ <primcall> _ 'not (c))
- (make-conditional src c
- (for-tail alternate)
- (for-tail subsequent)))
(c
- (make-conditional src c
- (for-tail subsequent)
- (for-tail alternate)))))
+ (simplify-conditional
+ (make-conditional src c (for-tail subsequent)
+ (for-tail alternate))))))
- (($ <application> src
- ($ <primitive-ref> _ '@call-with-values)
+ (($ <primcall> src '@call-with-values
(producer
($ <lambda> _ _
(and consumer
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (seq (if (if (primcall struct? (lexical x _))
- (primcall eq?
- (primcall struct-vtable
- (lexical x _))
- (toplevel x-vtable))
- (const #f))
- (void)
- (primcall throw (const foo)))
- (primcall struct-ref (lexical x _) (lexical y _)))))))
- (begin
++ (seq
+ (fix (failure) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
- (apply (primitive throw) (const foo))))))
- (if (apply (primitive struct?) (lexical x _))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable)
- (lexical x _))
- (toplevel x-vtable))
++ (primcall throw (const foo))))))
++ (if (primcall struct? (lexical x _))
++ (if (primcall eq?
++ (primcall struct-vtable (lexical x _))
++ (toplevel x-vtable))
+ (void)
- (apply (lexical failure _)))
- (apply (lexical failure _))))
- (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
++ (call (lexical failure _)))
++ (call (lexical failure _))))
++ (primcall struct-ref (lexical x _) (lexical y _)))))))
;; Strict argument evaluation also adds info to the DB.
(pass-if-cse
(lambda _
(lambda-case
(((x) #f #f #f () (_))
- (let (z) (_) ((if (if (primcall struct? (lexical x _))
- (primcall eq?
- (primcall struct-vtable
- (lexical x _))
- (toplevel x-vtable))
- (const #f))
- (primcall struct-ref (lexical x _) (const 1))
- (primcall throw (const foo))))
+ (let (z) (_)
+ ((fix (failure) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
- (apply (primitive throw) (const foo))))))
- (if (apply (primitive struct?) (lexical x _))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable)
- (lexical x _))
- (toplevel x-vtable))
- (apply (primitive struct-ref) (lexical x _) (const 1))
- (apply (lexical failure _)))
- (apply (lexical failure _)))))
- (apply (primitive +) (lexical z _)
- (apply (primitive struct-ref) (lexical x _) (const 2))))))))
++ (primcall throw (const foo))))))
++ (if (primcall struct? (lexical x _))
++ (if (primcall eq?
++ (primcall struct-vtable (lexical x _))
++ (toplevel x-vtable))
++ (primcall struct-ref (lexical x _) (const 1))
++ (call (lexical failure _)))
++ (call (lexical failure _)))))
+ (primcall + (lexical z _)
+ (primcall struct-ref (lexical x _) (const 2))))))))
;; Replacing named expressions with lexicals.
(pass-if-cse
out))))
((lambda (y) (list y)) x))
(let (x) (_) (_)
- (primcall list (lexical x _)))))
- (apply (primitive list) (lexical x _))))
++ (primcall list (lexical x _))))
+
+ ;; Here we test that a common test in a chain of ifs gets lifted.
- (pass-if-peval resolve-primitives
++ (pass-if-peval
+ (if (and (struct? x) (eq? (struct-vtable x) A))
+ (foo x)
+ (if (and (struct? x) (eq? (struct-vtable x) B))
+ (bar x)
+ (if (and (struct? x) (eq? (struct-vtable x) C))
+ (baz x)
+ (qux x))))
+ (let (failure) (_) ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
- (apply (toplevel qux) (toplevel x))))))
- (if (apply (primitive struct?) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel A))
- (apply (toplevel foo) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel B))
- (apply (toplevel bar) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel C))
- (apply (toplevel baz) (toplevel x))
- (apply (lexical failure _)))))
- (apply (lexical failure _)))))
++ (call (toplevel qux) (toplevel x))))))
++ (if (primcall struct? (toplevel x))
++ (if (primcall eq?
++ (primcall struct-vtable (toplevel x))
++ (toplevel A))
++ (call (toplevel foo) (toplevel x))
++ (if (primcall eq?
++ (primcall struct-vtable (toplevel x))
++ (toplevel B))
++ (call (toplevel bar) (toplevel x))
++ (if (primcall eq?
++ (primcall struct-vtable (toplevel x))
++ (toplevel C))
++ (call (toplevel baz) (toplevel x))
++ (call (lexical failure _)))))
++ (call (lexical failure _)))))
+
+ ;; Multiple common tests should get lifted as well.
- (pass-if-peval resolve-primitives
++ (pass-if-peval
+ (if (and (struct? x) (eq? (struct-vtable x) A) B)
+ (foo x)
+ (if (and (struct? x) (eq? (struct-vtable x) A) C)
+ (bar x)
+ (if (and (struct? x) (eq? (struct-vtable x) A) D)
+ (baz x)
+ (qux x))))
+ (let (failure) (_) ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
- (apply (toplevel qux) (toplevel x))))))
- (if (apply (primitive struct?) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel A))
++ (call (toplevel qux) (toplevel x))))))
++ (if (primcall struct? (toplevel x))
++ (if (primcall eq?
++ (primcall struct-vtable (toplevel x))
++ (toplevel A))
+ (if (toplevel B)
- (apply (toplevel foo) (toplevel x))
++ (call (toplevel foo) (toplevel x))
+ (if (toplevel C)
- (apply (toplevel bar) (toplevel x))
++ (call (toplevel bar) (toplevel x))
+ (if (toplevel D)
- (apply (toplevel baz) (toplevel x))
- (apply (lexical failure _)))))
- (apply (lexical failure _)))
- (apply (lexical failure _))))))
++ (call (toplevel baz) (toplevel x))
++ (call (lexical failure _)))))
++ (call (lexical failure _)))
++ (call (lexical failure _))))))
HCoop / bpt / guile.git / commitdiff