scanon = scm_take_locale_string (canon);
for (; scm_is_pair (in_path); in_path = scm_cdr (in_path))
- if (scm_is_true (scm_string_prefix_p (scm_car (in_path),
- scanon,
- SCM_UNDEFINED, SCM_UNDEFINED,
- SCM_UNDEFINED, SCM_UNDEFINED)))
- {
- size_t len = scm_c_string_length (scm_car (in_path));
-
- /* The path either has a trailing delimiter or doesn't. scanon will be
- delimited by single delimiters. In the case in which the path does
- not have a trailing delimiter, add one to the length to strip off the
- delimiter within scanon. */
- if (!len
+ {
+ SCM dir = scm_car (in_path);
+ size_t len = scm_c_string_length (dir);
+
+ /* When DIR is empty, it means "current working directory". We
+ could set DIR to (getcwd) in that case, but then the
+ canonicalization would depend on the current directory, which
+ is not what we want in the context of `compile-file', for
+ instance. */
+ if (len > 0
+ && scm_is_true (scm_string_prefix_p (dir, scanon,
+ SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED, SCM_UNDEFINED)))
+ {
+ /* DIR either has a trailing delimiter or doesn't. SCANON
+ will be delimited by single delimiters. When DIR does not
+ have a trailing delimiter, add one to the length to strip
+ off the delimiter within SCANON. */
+ if (
#ifdef __MINGW32__
- || (scm_i_string_ref (scm_car (in_path), len - 1) != '/'
- && scm_i_string_ref (scm_car (in_path), len - 1) != '\\')
+ (scm_i_string_ref (dir, len - 1) != '/'
+ && scm_i_string_ref (dir, len - 1) != '\\')
#else
- || scm_i_string_ref (scm_car (in_path), len - 1) != '/'
+ scm_i_string_ref (dir, len - 1) != '/'
#endif
- )
- len++;
+ )
+ len++;
- if (scm_c_string_length (scanon) > len)
- return scm_substring (scanon, scm_from_size_t (len), SCM_UNDEFINED);
- else
- return SCM_BOOL_F;
- }
+ if (scm_c_string_length (scanon) > len)
+ return scm_substring (scanon, scm_from_size_t (len), SCM_UNDEFINED);
+ else
+ return SCM_BOOL_F;
+ }
+ }
return SCM_BOOL_F;
}
{
if (SCM_LIKELY (scm_is_symbol (what)))
{
- if (SCM_LIKELY (scm_module_system_booted_p
- && scm_is_true (program_module)))
+ if (SCM_LIKELY (scm_is_true (program_module)))
/* might longjmp */
return scm_module_lookup (program_module, what);
else
## Process this file with Automake to create Makefile.in
## Jim Blandy <jimb@red-bean.com> --- September 1997
##
-## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009, 2011 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009, 2011,
+## 2012 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
# 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.2.pc
SOURCES = \
ice-9/psyntax-pp.scm \
ice-9/boot-9.scm \
+ ice-9/vlist.scm \
+ srfi/srfi-1.scm \
+ language/tree-il/peval.scm \
+ language/tree-il/cse.scm \
\
language/tree-il.scm \
language/glil.scm \
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
- language/tree-il/peval.scm \
language/tree-il/effects.scm \
language/tree-il/fix-letrec.scm \
language/tree-il/optimize.scm \
language/tree-il/analyze.scm \
language/tree-il/inline.scm \
language/tree-il/compile-glil.scm \
- language/tree-il/cse.scm \
language/tree-il/debug.scm \
language/tree-il/spec.scm
ice-9/weak-vector.scm \
ice-9/list.scm \
ice-9/serialize.scm \
- ice-9/vlist.scm \
ice-9/local-eval.scm
SRFI_SOURCES = \
- srfi/srfi-1.scm \
srfi/srfi-2.scm \
srfi/srfi-4.scm \
srfi/srfi-4/gnu.scm \
tree-il-fold
make-tree-il-folder
post-order!
- pre-order!))
+ pre-order!
+
+ tree-il=?
+ tree-il-hash))
(define (print-tree-il exp port)
(format port "#<tree-il ~S>" (unparse-tree-il exp)))
(else #f))
x)))
+
+;; FIXME: We should have a better primitive than this.
+(define (struct-nfields x)
+ (/ (string-length (symbol->string (struct-layout x))) 2))
+
+(define (tree-il=? 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 (tree-il=? (struct-ref a n) (struct-ref b n))
+ (lp (1- n)))))))
+ ((pair? a)
+ (and (pair? b)
+ (tree-il=? (car a) (car b))
+ (tree-il=? (cdr a) (cdr b))))
+ (else
+ (equal? a b))))
+
+(define-syntax hash-bits
+ (make-variable-transformer
+ (lambda (x)
+ (syntax-case x ()
+ (var
+ (identifier? #'var)
+ (logcount most-positive-fixnum))))))
+
+(define (tree-il-hash exp)
+ (let ((hash-depth 4)
+ (hash-width 3))
+ (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)))
(arity:allow-other-keys? a)))
(program-arities proc))))
((procedure? proc)
- (let ((arity (procedure-minimum-arity proc)))
- (values (procedure-name proc)
- (list (list (car arity) (cadr arity) (caddr arity)
- #f #f)))))
+ (if (struct? proc)
+ ;; An applicable struct.
+ (arities (struct-ref proc 0))
+ ;; An applicable smob.
+ (let ((arity (procedure-minimum-arity proc)))
+ (values (procedure-name proc)
+ (list (list (car arity) (cadr arity) (caddr arity)
+ #f #f))))))
(else
(let loop ((name #f)
(proc proc)
(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* call #t))
+ ((procedure? proc*)
+ (validate-arity proc* call #f)))))
toplevel-calls)))
(make-arity-info vlist-null vlist-null vlist-null)))
(define (proc-ref? exp proc special-name env)
"Return #t when EXP designates procedure PROC in ENV. As a last
resort, return #t when EXP refers to the global variable SPECIAL-NAME."
+
+ (define special?
+ (cut eq? <> special-name))
+
(match exp
+ (($ <toplevel-ref> _ (? special?))
+ ;; Allow top-levels like: (define _ (cut gettext <> "my-domain")).
+ #t)
(($ <toplevel-ref> _ name)
(let ((var (module-variable env name)))
- (if (and var (variable-bound? var))
- (eq? (variable-ref var) proc)
- (eq? name special-name)))) ; special hack to support local aliases
+ (and var (variable-bound? var)
+ (eq? (variable-ref var) proc))))
+ (($ <module-ref> _ _ (? special?))
+ #t)
(($ <module-ref> _ module name public?)
(let* ((mod (if public?
(false-if-exception (resolve-interface module))
- (resolve-module module #:ensure? #f)))
+ (resolve-module module #:ensure #f)))
(var (and mod (module-variable mod name))))
(and var (variable-bound? var) (eq? (variable-ref var) proc))))
+ (($ <lexical-ref> _ (? special?))
+ #t)
(_ #f)))
(define gettext? (cut proc-ref? <> gettext '_ <>))
(($ <const> _ (? boolean?)) #t)
(_ (eq? ctx 'test))))
+(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."
(lambda (sym)
(vhash-assq sym table))))
- (define compute-effects
+ (define %compute-effects
(make-effects-analyzer assigned-lexical?))
(define (negate exp ctx)
(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)))
(define (add-to-db exp effects ctx db)
(let ((v (vector exp effects ctx))
- (h (hash-expression exp)))
+ (h (tree-il-hash exp)))
(vhash-cons v h db (hasher h))))
(define (control-flow-boundary db)
(define (entry-matches? v1 v2)
(match (if (vector? v1) v1 v2)
(#(exp* effects* ctx*)
- (and (expressions-equal? exp exp*)
+ (and (tree-il=? exp exp*)
(or (not ctx) (eq? ctx* ctx))))
(_ #f)))
(let ((len (vlist-length db))
- (h (hash-expression exp)))
+ (h (tree-il-hash exp)))
(and (vhash-assoc #t db entry-matches? (hasher h))
(let lp ((n 0))
(and (< n len)
(unparse-tree-il exp*) effects* ctx*)
(or (and (= h h*)
(or (not ctx) (eq? ctx ctx*))
- (expressions-equal? exp exp*))
+ (tree-il=? exp exp*))
(and (effects-commute? effects effects*)
(lp (1+ n)))))))))))
(define (add-to-env exp name sym db env)
(let* ((v (vector exp name sym (vlist-length db)))
- (h (hash-expression exp)))
+ (h (tree-il-hash exp)))
(vhash-cons v h env (hasher h))))
(define (augment-env env names syms exps db)
(define (entry-matches? v1 v2)
(match (if (vector? v1) v1 v2)
(#(exp* name sym db)
- (expressions-equal? exp exp*))
+ (tree-il=? exp exp*))
(_ #f)))
(define (unroll db base n)
(and (effects-commute? effects effects*)
(unroll db (1+ base) (1- n)))))))
- (let ((h (hash-expression exp)))
+ (let ((h (tree-il-hash exp)))
(and (effect-free? (exclude-effects effects &type-check))
(vhash-assoc exp env entry-matches? (hasher h))
(let ((env-len (vlist-length env))
(match (vlist-ref env n)
((#(exp* name sym db-len*) . h*)
(and (unroll db m (- db-len db-len*))
- (if (and (= h h*) (expressions-equal? exp* exp))
+ (if (and (= h h*) (tree-il=? exp* exp))
(make-lexical-ref (tree-il-src exp) name sym)
(lp (1+ n) (- db-len db-len*))))))))))))
+ (define (lookup-lexical sym env)
+ (let ((env-len (vlist-length env)))
+ (let lp ((n 0))
+ (and (< n env-len)
+ (match (vlist-ref env n)
+ ((#(exp _ sym* _) . _)
+ (if (eq? sym sym*)
+ exp
+ (lp (1+ n)))))))))
+
(define (intersection db+ db-)
(vhash-fold-right
(lambda (k h out)
(lp (cdr in) (cons x out) (concat db** db*))))
(values (reverse out) db*))))
+ (define (compute-effects exp)
+ (%compute-effects exp (lambda (sym) (lookup-lexical sym env))))
+
+ (define (bailout? exp)
+ (causes-effects? (compute-effects exp) &definite-bailout))
+
(define (return exp db*)
(let ((effects (compute-effects exp)))
(cond
=> (lambda (exp)
(log 'propagate-test ctx (unparse-tree-il exp))
(values exp db*)))
- ((and (eq? ctx 'value)
+ ((and (singly-valued-expression? exp ctx)
(find-dominating-lexical exp effects env db))
=> (lambda (exp)
(log 'propagate-value ctx (unparse-tree-il exp))
"Returns a procedure of type EXP -> EFFECTS that analyzes the effects
of an expression."
- (define compute-effects
- (let ((cache (make-hash-table)))
- (lambda (exp)
+ (let ((cache (make-hash-table)))
+ (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
+ (define (compute-effects exp)
(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 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)))
+ &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))))
- ;; 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.
+ (($ <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.
+ (($ <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.
+ (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+ (cond
+ ((lookup sym)
+ => (lambda (proc)
+ (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.
+ (($ <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 exp))
+
+ compute-effects))
;;; transformation of letrec into simpler forms
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
'())))
(values unref simple lambda* complex)))
+(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-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
+ (list->seq*
src
(append
;; The right-hand-sides of the unreferenced
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
- (list->seq
+ (list->seq*
src
(append
;; unreferenced bindings, called for effect.
((test) (make-const #f #t))
(else exp)))
(($ <conditional> src condition subsequent alternate)
+ (define (call-with-failure-thunk exp proc)
+ (match exp
+ (($ <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)))
+ (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))))))
(($ <primcall> src '@call-with-values
(producer
($ <lambda> _ _
#:use-module (system base pmatch)
#:use-module (system base message)
#:use-module (language tree-il)
+ #:use-module (language tree-il canonicalize)
#:use-module (language tree-il primitives)
+ #:use-module (language tree-il fix-letrec)
#:use-module (language tree-il cse)
#:use-module (language tree-il peval)
#:use-module (language glil)
((_ in pat)
(pass-if 'in
(let ((evaled (unparse-tree-il
- (cse
- (peval
- (expand-primitives!
- (resolve-primitives!
- (compile 'in #:from 'scheme #:to 'tree-il)
- (current-module))))))))
+ (canonicalize!
+ (fix-letrec!
+ (cse
+ (peval
+ (expand-primitives!
+ (resolve-primitives!
+ (compile 'in #:from 'scheme #:to 'tree-il)
+ (current-module))))))))))
(pmatch evaled
(pat #t)
(_ (pk 'cse-mismatch)
(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 _)))))))
+ (seq
+ (fix (failure) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (primcall throw (const foo))))))
+ (if (primcall struct? (lexical x _))
+ (if (primcall eq?
+ (primcall struct-vtable (lexical x _))
+ (toplevel x-vtable))
+ (void)
+ (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 () ())
+ (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))))))))
out))))
((lambda (y) (list y)) x))
(let (x) (_) (_)
- (primcall list (lexical x _)))))
+ (primcall list (lexical x _))))
+
+ ;; Here we test that a common test in a chain of ifs gets lifted.
+ (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 () ())
+ (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
+ (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 () ())
+ (call (toplevel qux) (toplevel x))))))
+ (if (primcall struct? (toplevel x))
+ (if (primcall eq?
+ (primcall struct-vtable (toplevel x))
+ (toplevel A))
+ (if (toplevel B)
+ (call (toplevel foo) (toplevel x))
+ (if (toplevel C)
+ (call (toplevel bar) (toplevel x))
+ (if (toplevel D)
+ (call (toplevel baz) (toplevel x))
+ (call (lexical failure _)))))
+ (call (lexical failure _)))
+ (call (lexical failure _))))))
(and (= line line*)
(= col col*)))))))))))
+\f
+
+(define-syntax-rule (with-load-path path body ...)
+ (let ((new path)
+ (old %load-path))
+ (dynamic-wind
+ (lambda ()
+ (set! %load-path new))
+ (lambda ()
+ body ...)
+ (lambda ()
+ (set! %load-path old)))))
+
+(with-test-prefix "%file-port-name-canonicalization"
+
+ (pass-if "absolute file name & empty %load-path entry"
+ ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead
+ ;; of "/dev/null". See
+ ;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html>
+ ;; for a discussion.
+ (equal? "/dev/null"
+ (with-load-path (cons "" (delete "/" %load-path))
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename (open-input-file "/dev/null"))))))
+
+ (pass-if "relative canonicalization with /"
+ (equal? "dev/null"
+ (with-load-path (cons "/" %load-path)
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename (open-input-file "/dev/null"))))))
+
+ (pass-if "relative canonicalization from ice-9"
+ (equal? "ice-9/q.scm"
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename
+ (open-input-file (%search-load-path "ice-9/q.scm"))))))
+
+ (pass-if "absolute canonicalization from ice-9"
+ (equal? (string-append (assoc-ref %guile-build-info 'top_srcdir)
+ "/module/ice-9/q.scm")
+ (with-fluids ((%file-port-name-canonicalization 'absolute))
+ (port-filename (open-input-file (%search-load-path "ice-9/q.scm")))))))
+
(delete-file (test-file))
;;; Local Variables:
;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
+;;; eval: (put 'with-load-path 'scheme-indent-function 1)
;;; End:
w "wrong number of arguments to"))))
w)))))
+ (pass-if "top-level applicable struct"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((p current-warning-port))
+ (p (+ (p) 1))
+ (p))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+
+ (pass-if "top-level applicable struct with wrong arguments"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(let ((p current-warning-port))
+ (p 1 2 3))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
(pass-if "local toplevel-defines"
(let ((w (call-with-warnings
(lambda ()
#:opts %opts-w-format
#:to 'assembly)))))
+ (pass-if "non-literal format string using gettext as top-level _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(begin
+ (define (_ s) (gettext s "my-domain"))
+ (format #t (_ "~A ~A!") "hello" "world"))
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using gettext as module-ref _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using gettext as lexical _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((_ (lambda (s)
+ (gettext s "my-domain"))))
+ (format #t (_ "~A ~A!") "hello" "world"))
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
(pass-if "non-literal format string using ngettext"
(null? (call-with-warnings
(lambda ()
HCoop / bpt / guile.git / commitdiff