\f
-SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
- (SCM handle),
- "Return the vtable tag of the structure @var{handle}.")
-#define FUNC_NAME s_scm_struct_vtable_tag
-{
- SCM_VALIDATE_VTABLE (1, handle);
- scm_c_issue_deprecation_warning
- ("struct-vtable-tag is deprecated. What were you doing with it anyway?");
-
- return scm_from_unsigned_integer
- (((scm_t_bits)SCM_STRUCT_DATA (handle)) >> 3);
-}
-#undef FUNC_NAME
-
-
-\f
+ SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector, string,\n"
+ "bitvector, or uniform numeric vector.")
+ #define FUNC_NAME s_scm_generalized_vector_p
+ {
+ scm_c_issue_deprecation_warning
+ ("generalized-vector? is deprecated. Use array? and check the "
+ "array-rank instead.");
+ return scm_from_bool (scm_is_generalized_vector (obj));
+ }
+ #undef FUNC_NAME
+
+ SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0,
+ (SCM v),
+ "Return the length of the generalized vector @var{v}.")
+ #define FUNC_NAME s_scm_generalized_vector_length
+ {
+ scm_c_issue_deprecation_warning
+ ("generalized-vector-length is deprecated. Use array-length instead.");
+ return scm_from_size_t (scm_c_generalized_vector_length (v));
+ }
+ #undef FUNC_NAME
+
+ SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
+ (SCM v, SCM idx),
+ "Return the element at index @var{idx} of the\n"
+ "generalized vector @var{v}.")
+ #define FUNC_NAME s_scm_generalized_vector_ref
+ {
+ scm_c_issue_deprecation_warning
+ ("generalized-vector-ref is deprecated. Use array-ref instead.");
+ return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
+ }
+ #undef FUNC_NAME
+
+ SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
+ (SCM v, SCM idx, SCM val),
+ "Set the element at index @var{idx} of the\n"
+ "generalized vector @var{v} to @var{val}.")
+ #define FUNC_NAME s_scm_generalized_vector_set_x
+ {
+ scm_c_issue_deprecation_warning
+ ("generalized-vector-set! is deprecated. Use array-set! instead. "
+ "Note the change in argument order!");
+ scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
+ return SCM_UNSPECIFIED;
+ }
+ #undef FUNC_NAME
+
+ SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
+ (SCM v),
+ "Return a new list whose elements are the elements of the\n"
+ "generalized vector @var{v}.")
+ #define FUNC_NAME s_scm_generalized_vector_to_list
+ {
+ /* FIXME: This duplicates `array_to_list'. */
+ SCM ret = SCM_EOL;
+ long inc;
+ ssize_t pos, i;
+ scm_t_array_handle h;
+
+ scm_c_issue_deprecation_warning
+ ("generalized-vector->list is deprecated. Use array->list instead.");
+
+ scm_generalized_vector_get_handle (v, &h);
+
+ i = h.dims[0].ubnd - h.dims[0].lbnd + 1;
+ inc = h.dims[0].inc;
+ pos = (i - 1) * inc;
+
+ for (; i > 0; i--, pos -= inc)
+ ret = scm_cons (h.impl->vref (&h, h.base + pos), ret);
+
+ scm_array_handle_release (&h);
+ return ret;
+ }
+ #undef FUNC_NAME
+
+
+ \f
+
void
scm_i_init_deprecated ()
{
#define SCM_INLINE_H
/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010,
- * 2011, 2012 Free Software Foundation, Inc.
- * 2011, 2013 Free Software Foundation, Inc.
++ * 2011, 2012, 2013 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 License
#include "libguile/error.h"
- SCM_INLINE SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
- SCM_INLINE void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val);
-
-SCM_INLINE int scm_is_pair (SCM x);
SCM_INLINE int scm_is_string (SCM x);
-SCM_INLINE int scm_get_byte_or_eof (SCM port);
-SCM_INLINE int scm_peek_byte_or_eof (SCM port);
-SCM_INLINE void scm_putc (char c, SCM port);
-SCM_INLINE void scm_puts (const char *str_data, SCM port);
-
-
SCM_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
SCM_INLINE SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
scm_t_bits ccr, scm_t_bits cdr);
#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
/* Either inlining, or being included from inline.c. */
- SCM_INLINE_IMPLEMENTATION SCM
- scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
-SCM_INLINE_IMPLEMENTATION int
-scm_is_pair (SCM x)
--{
- if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
- /* catch overflow */
- scm_out_of_range (NULL, scm_from_ssize_t (p));
- /* perhaps should catch overflow here too */
- return h->impl->vref (h, h->base + p);
- }
- /* The following "workaround_for_gcc_295" avoids bad code generated by
- i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least).
--
- SCM_INLINE_IMPLEMENTATION void
- scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
- {
- if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
- /* catch overflow */
- scm_out_of_range (NULL, scm_from_ssize_t (p));
- /* perhaps should catch overflow here too */
- h->impl->vset (h, h->base + p, v);
- Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
- the fetch of the tag word from x is done before confirming it's a
- non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a
- immediate. This was seen to afflict scm_srfi1_split_at and something
- deep in the bowels of ceval(). In both cases segvs resulted from
- deferencing a random immediate value. srfi-1.test exposes the problem
- through a short list, the immediate being SCM_EOL in that case.
- Something in syntax.test exposed the ceval() problem.
-
- Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the
- problem, without even using that variable. The "w=w" is just to
- prevent a warning about it being unused.
- */
-#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95
- volatile SCM workaround_for_gcc_295 = x;
- workaround_for_gcc_295 = workaround_for_gcc_295;
-#endif
-
- return SCM_I_CONSP (x);
--}
--
SCM_INLINE_IMPLEMENTATION int
scm_is_string (SCM x)
{
($ <toplevel-set>) ; could return zero values in
($ <toplevel-define>) ; the future
($ <module-set>) ;
- ($ <dynset>)) ;
- (and (= (length names) 1)
- (make-let src names gensyms (list exp) body)))
- (($ <primcall> src (? singly-valued-primitive? name))
- (and (= (length names) 1)
- (make-let src names gensyms (list exp) body)))
+ ($ <dynset>) ;
- ($ <application> src
- ($ <primitive-ref> _ (? singly-valued-primitive?))))
++ ($ <primcall> src (? singly-valued-primitive?)))
+ (and (<= nmin 1) (or (not nmax) (>= nmax 1))
- (make-application src (make-lambda #f '() consumer) (list exp))))
++ (make-call src (make-lambda #f '() consumer) (list exp))))
;; Statically-known number of values.
- (($ <application> src ($ <primitive-ref> _ 'values) vals)
+ (($ <primcall> src 'values vals)
- (and (= (length names) (length vals))
- (make-let src names gensyms vals body)))
+ (and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals)))
- (make-application src (make-lambda #f '() consumer) vals)))
++ (make-call src (make-lambda #f '() consumer) vals)))
;; Not going to copy code into both branches.
(($ <conditional>) #f)
(begin
(record-operand-use op)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
- (vals ... ($ <application> _ ($ <primitive-ref> _ 'list) rest-args))
- ($ <application> asrc
- ($ <primitive-ref> _ (or 'apply '@apply))
+ (($ <let> src
+ (names ... rest)
+ (gensyms ... rest-sym)
- (make-application
++ (vals ... ($ <primcall> _ 'list rest-args))
++ ($ <primcall> asrc (or 'apply '@apply)
+ (proc args ...
+ ($ <lexical-ref> _
+ (? (cut eq? <> rest))
+ (? (lambda (sym)
+ (and (eq? sym rest-sym)
+ (= (lexical-refcount sym) 1))))))))
+ (let* ((tmps (make-list (length rest-args) 'tmp))
+ (tmp-syms (fresh-temporaries tmps)))
+ (for-tail
+ (make-let src
+ (append names tmps)
+ (append gensyms tmp-syms)
+ (append vals rest-args)
++ (make-call
+ asrc
+ proc
+ (append args
+ (map (cut make-lexical-ref #f <> <>)
+ tmps tmp-syms)))))))
(($ <let> src names gensyms vals body)
(define (compute-alias exp)
;; It's very common for macros to introduce something like:
;; reconstruct the let-values, pevaling the consumer.
(let ((producer (for-values producer)))
(or (match consumer
- (($ <lambda-case> src req #f #f #f () gensyms body #f)
- (cond
- ((inline-values producer src req gensyms body)
- => for-tail)
- (else #f)))
+ (($ <lambda-case> src req opt rest #f inits gensyms body #f)
+ (let* ((nmin (length req))
+ (nmax (and (not rest) (+ nmin (if opt (length opt) 0)))))
+ (cond
+ ((inline-values lv-src producer nmin nmax consumer)
+ => for-tail)
+ (else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynwind> src winder body unwinder)
- (let ((pre (for-value winder))
- (body (for-tail body))
- (post (for-value unwinder)))
- (cond
- ((not (constant-expression? pre))
- (cond
- ((not (constant-expression? post))
- (let ((pre-sym (gensym "pre-")) (post-sym (gensym "post-")))
- (record-new-temporary! 'pre pre-sym 1)
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(pre post) (list pre-sym post-sym) (list pre post)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (let ((pre-sym (gensym "pre-")))
- (record-new-temporary! 'pre pre-sym 1)
- (make-let src '(pre) (list pre-sym) (list pre)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- post))))))
- ((not (constant-expression? post))
- (let ((post-sym (gensym "post-")))
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(post) (list post-sym) (list post)
- (make-dynwind src
- pre
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (make-dynwind src pre body post)))))
+ (($ <dynwind> src winder pre body post unwinder)
+ (make-dynwind src (for-value winder) (for-effect pre)
+ (for-tail body)
+ (for-effect post) (for-value unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
((value test effect) #t)
(else (null? (cdr vals))))
(every singly-valued-expression? vals))
- (for-tail (make-sequence src (append (cdr vals) (list (car vals)))))
- (make-application src (make-primitive-ref #f 'values) vals))))))
- (($ <application> src (and apply ($ <primitive-ref> _ (or 'apply '@apply)))
- (proc args ... tail))
+ (for-tail (list->seq src (append (cdr vals) (list (car vals)))))
+ (make-primcall src 'values vals))))))
+
+ (($ <primcall> src (or 'apply '@apply) (proc args ... tail))
- (match (for-value tail)
- (($ <const> _ (args* ...))
- (let ((args* (map (lambda (x) (make-const #f x)) args*)))
- (for-tail (make-call src proc (append args args*)))))
- (($ <primcall> _ 'list args*)
- (for-tail (make-call src proc (append args args*))))
- (tail
- (let ((args (append (map for-value args) (list tail))))
- (make-primcall src '@apply (cons (for-value proc) args))))))
+ (let lp ((tail* (find-definition tail 1)) (speculative? #t))
+ (define (copyable? x)
+ ;; Inlining a result from find-definition effectively copies it,
+ ;; relying on the let-pruning to remove its original binding. We
+ ;; shouldn't copy non-constant expressions.
+ (or (not speculative?) (constant-expression? x)))
+ (match tail*
+ (($ <const> _ (args* ...))
+ (let ((args* (map (cut make-const #f <>) args*)))
- (for-tail (make-application src proc (append args args*)))))
- (($ <application> _ ($ <primitive-ref> _ 'cons)
++ (for-tail (make-call src proc (append args args*)))))
++ (($ <primcall> _ 'cons
+ ((and head (? copyable?)) (and tail (? copyable?))))
- (for-tail (make-application src apply
- (cons proc
- (append args (list head tail))))))
- (($ <application> _ ($ <primitive-ref> _ 'list)
++ (for-tail (make-primcall src '@apply
++ (cons proc
++ (append args (list head tail))))))
++ (($ <primcall> _ 'list
+ (and args* ((? copyable?) ...)))
- (for-tail (make-application src proc (append args args*))))
++ (for-tail (make-call src proc (append args args*))))
+ (tail*
+ (if speculative?
+ (lp (for-value tail) #f)
+ (let ((args (append (map for-value args) (list tail*))))
- (make-application src apply
- (cons (for-value proc) args))))))))
- (($ <application> src orig-proc orig-args)
++ (make-primcall src '@apply
++ (cons (for-value proc) args))))))))
+
+ (($ <primcall> src (? constructor-primitive? name) args)
+ (cond
+ ((and (memq ctx '(effect test))
+ (match (cons name args)
+ ((or ('cons _ _)
+ ('list . _)
+ ('vector . _)
+ ('make-prompt-tag)
+ ('make-prompt-tag ($ <const> _ (? string?))))
+ #t)
+ (_ #f)))
+ ;; Some expressions can be folded without visiting the
+ ;; arguments for value.
+ (let ((res (if (eq? ctx 'effect)
+ (make-void #f)
+ (make-const #f #t))))
+ (for-tail (list->seq src (append args (list res))))))
+ (else
+ (match (cons name (map for-value args))
+ (('cons x ($ <const> _ (? (cut eq? <> '()))))
+ (make-primcall src 'list (list x)))
+ (('cons x ($ <primcall> _ 'list elts))
+ (make-primcall src 'list (cons x elts)))
+ ((name . args)
+ (make-primcall src name args))))))
+
+ (($ <primcall> src (? accessor-primitive? name) args)
+ (match (cons name (map for-value args))
+ ;; FIXME: these for-tail recursions could take place outside
+ ;; an effort counter.
+ (('car ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src tail head)))
+ (('cdr ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src head tail)))
+ (('car ($ <primcall> src 'list (head . tail)))
+ (for-tail (list->seq src (append tail (list head)))))
+ (('cdr ($ <primcall> src 'list (head . tail)))
+ (for-tail (make-seq src head (make-primcall #f 'list tail))))
+
+ (('car ($ <const> src (head . tail)))
+ (for-tail (make-const src head)))
+ (('cdr ($ <const> src (head . tail)))
+ (for-tail (make-const src tail)))
+ (((or 'memq 'memv) k ($ <const> _ (elts ...)))
+ ;; FIXME: factor
+ (case ctx
+ ((effect)
+ (for-tail
+ (make-seq src k (make-void #f))))
+ ((test)
+ (cond
+ ((const? k)
+ ;; A shortcut. The `else' case would handle it, but
+ ;; this way is faster.
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (and (member (const-exp k) elts) #t))))
+ ((null? elts)
+ (for-tail
+ (make-seq src k (make-const #f #f))))
+ (else
+ (let ((t (gensym "t "))
+ (eq (if (eq? name 'memq) 'eq? 'eqv?)))
+ (record-new-temporary! 't t (length elts))
+ (for-tail
+ (make-let
+ src (list 't) (list t) (list k)
+ (let lp ((elts elts))
+ (define test
+ (make-primcall #f eq
+ (list (make-lexical-ref #f 't t)
+ (make-const #f (car elts)))))
+ (if (null? (cdr elts))
+ test
+ (make-conditional src test
+ (make-const #f #t)
+ (lp (cdr elts)))))))))))
+ (else
+ (cond
+ ((const? k)
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (member (const-exp k) elts))))
+ ((null? elts)
+ (for-tail (make-seq src k (make-const #f #f))))
+ (else
+ (make-primcall src name (list k (make-const #f elts))))))))
+ ((name . args)
+ (fold-constants src name args ctx))))
+
+ (($ <primcall> src (? equality-primitive? name) (a b))
+ (let ((val-a (for-value a))
+ (val-b (for-value b)))
+ (log 'equality-primitive name val-a val-b)
+ (cond ((and (lexical-ref? val-a) (lexical-ref? val-b)
+ (eq? (lexical-ref-gensym val-a)
+ (lexical-ref-gensym val-b)))
+ (for-tail (make-const #f #t)))
+ (else
+ (fold-constants src name (list val-a val-b) ctx)))))
+
+ (($ <primcall> src (? effect-free-primitive? name) args)
+ (fold-constants src name (map for-value args) ctx))
+
+ (($ <primcall> src name args)
+ (make-primcall src name (map for-value args)))
+
+ (($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
- (let ((proc (visit orig-proc 'operator)))
+ (let revisit-proc ((proc (visit orig-proc 'operator)))
(match proc
- (($ <primitive-ref> _ (? constructor-primitive? name))
- (cond
- ((and (memq ctx '(effect test))
- (match (cons name orig-args)
- ((or ('cons _ _)
- ('list . _)
- ('vector . _)
- ('make-prompt-tag)
- ('make-prompt-tag ($ <const> _ (? string?))))
- #t)
- (_ #f)))
- ;; Some expressions can be folded without visiting the
- ;; arguments for value.
- (let ((res (if (eq? ctx 'effect)
- (make-void #f)
- (make-const #f #t))))
- (for-tail (make-sequence src (append orig-args (list res))))))
- (else
- (match (cons name (map for-value orig-args))
- (('cons head tail)
- (match tail
- (($ <const> src (? (cut eq? <> '())))
- (make-application src (make-primitive-ref #f 'list)
- (list head)))
- (($ <application> src ($ <primitive-ref> _ 'list) elts)
- (make-application src (make-primitive-ref #f 'list)
- (cons head elts)))
- (_ (make-application src proc (list head tail)))))
- ((_ . args)
- (make-application src proc args))))))
- (($ <primitive-ref> _ (? accessor-primitive? name))
- (match (cons name (map for-value orig-args))
- ;; FIXME: these for-tail recursions could take place outside
- ;; an effort counter.
- (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list tail head))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list head tail))))
- (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence src (append tail (list head)))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence
- src
- (list head
- (make-application
- src (make-primitive-ref #f 'list) tail)))))
-
- (('car ($ <const> src (head . tail)))
- (for-tail (make-const src head)))
- (('cdr ($ <const> src (head . tail)))
- (for-tail (make-const src tail)))
- (((or 'memq 'memv) k ($ <const> _ (elts ...)))
- ;; FIXME: factor
- (case ctx
- ((effect)
- (for-tail
- (make-sequence src (list k (make-void #f)))))
- ((test)
- (cond
- ((const? k)
- ;; A shortcut. The `else' case would handle it, but
- ;; this way is faster.
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (and (member (const-exp k) elts) #t))))
- ((null? elts)
- (for-tail
- (make-sequence src (list k (make-const #f #f)))))
- (else
- (let ((t (gensym "t-"))
- (eq (if (eq? name 'memq) 'eq? 'eqv?)))
- (record-new-temporary! 't t (length elts))
- (for-tail
- (make-let
- src (list 't) (list t) (list k)
- (let lp ((elts elts))
- (define test
- (make-application
- #f (make-primitive-ref #f eq)
- (list (make-lexical-ref #f 't t)
- (make-const #f (car elts)))))
- (if (null? (cdr elts))
- test
- (make-conditional src test
- (make-const #f #t)
- (lp (cdr elts)))))))))))
- (else
- (cond
- ((const? k)
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (member (const-exp k) elts))))
- ((null? elts)
- (for-tail (make-sequence src (list k (make-const #f #f)))))
- (else
- (make-application src proc (list k (make-const #f elts))))))))
- ((_ . args)
- (or (fold-constants src name args ctx)
- (make-application src proc args)))))
- (($ <primitive-ref> _ (? effect-free-primitive? name))
- (let ((args (map for-value orig-args)))
- (or (fold-constants src name args ctx)
- (make-application src proc args))))
+ (($ <primitive-ref> _ name)
+ (for-tail (make-primcall src name orig-args)))
(($ <lambda> _ _
- ($ <lambda-case> _ req opt #f #f inits gensyms body #f))
- ;; Simple case: no rest, no keyword arguments.
+ ($ <lambda-case> _ req opt rest #f inits gensyms body #f))
+ ;; Simple case: no keyword arguments.
;; todo: handle the more complex cases
(let* ((nargs (length orig-args))
(nreq (length req))
(nopt (if opt (length opt) 0))
(key (source-expression proc)))
- (define (inlined-application)
++ (define (inlined-call)
+ (make-let src
+ (append req
+ (or opt '())
+ (if rest (list rest) '()))
+ gensyms
+ (if (> nargs (+ nreq nopt))
+ (append (list-head orig-args (+ nreq nopt))
+ (list
- (make-application
- #f
- (make-primitive-ref #f 'list)
++ (make-primcall
++ #f 'list
+ (drop orig-args (+ nreq nopt)))))
+ (append orig-args
+ (drop inits (- nargs nreq))
+ (if rest
+ (list (make-const #f '()))
+ '())))
+ body))
+
(cond
- ((or (< nargs nreq) (> nargs (+ nreq nopt)))
+ ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
;; An error, or effecting arguments.
- (make-application src (for-call orig-proc)
- (map for-value orig-args)))
+ (make-call src (for-call orig-proc) (map for-value orig-args)))
((or (and=> (find-counter key counter) counter-recursive?)
(lambda? orig-proc))
;; A recursive call, or a lambda in the operator
(lp (counter-prev counter)))))))
(log 'inline-recurse key)
- (loop (make-let src (append req (or opt '()))
- gensyms
- (append orig-args
- (drop inits (- nargs nreq)))
- body)
- env counter ctx))
- (loop (inlined-application) env counter ctx))
++ (loop (inlined-call) env counter ctx))
(else
;; An integration at the top-level, the first
;; recursion of a recursive procedure, or a nested
(make-top-counter effort-limit operand-size-limit
abort key))))
(define result
- (loop (make-let src (append req (or opt '()))
- gensyms
- (append orig-args
- (drop inits (- nargs nreq)))
- body)
- env new-counter ctx))
- (loop (inlined-application) env new-counter ctx))
++ (loop (inlined-call) env new-counter ctx))
(if counter
;; The nested inlining attempt succeeded.
(log 'inline-end result exp)
result)))))
- (make-application src body orig-args))))
+ (($ <let> _ _ _ vals _)
+ ;; Attempt to inline `let' in the operator position.
+ ;;
+ ;; We have to re-visit the proc in value mode, since the
+ ;; `let' bindings might have been introduced or renamed,
+ ;; whereas the lambda (if any) in operator position has not
+ ;; been renamed.
+ (if (or (and-map constant-expression? vals)
+ (and-map constant-expression? orig-args))
+ ;; The arguments and the let-bound values commute.
+ (match (for-value orig-proc)
+ (($ <let> lsrc names syms vals body)
+ (log 'inline-let orig-proc)
+ (for-tail
+ (make-let lsrc names syms vals
- (make-application src (for-call orig-proc)
- (map for-value orig-args))))
++ (make-call src body orig-args))))
+ ;; It's possible for a `let' to go away after the
+ ;; visit due to the fact that visiting a procedure in
+ ;; value context will prune unused bindings, whereas
+ ;; visiting in operator mode can't because it doesn't
+ ;; traverse through lambdas. In that case re-visit
+ ;; the procedure.
+ (proc (revisit-proc proc)))
++ (make-call src (for-call orig-proc)
++ (map for-value orig-args))))
(_
- (make-application src (for-call orig-proc)
- (map for-value orig-args))))))
+ (make-call src (for-call orig-proc) (map for-value orig-args))))))
(($ <lambda> src meta body)
(case ctx
((effect) (make-void #f))
(($ <prompt> src tag body handler)
(define (make-prompt-tag? x)
(match x
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
- (or () ((? constant-expression?))))
+ (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
#t)
(_ #f)))
- (define (find-definition x n-aliases)
- (cond
- ((lexical-ref? x)
- (cond
- ((lookup (lexical-ref-gensym x))
- => (lambda (op)
- (let ((y (or (operand-residual-value op)
- (visit-operand op counter 'value 10 10))))
- (cond
- ((and (lexical-ref? y)
- (= (lexical-refcount (lexical-ref-gensym x)) 1))
- ;; X is a simple alias for Y. Recurse, regardless of
- ;; the number of aliases we were expecting.
- (find-definition y n-aliases))
- ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
- ;; We found a definition that is aliased the right
- ;; number of times. We still recurse in case it is a
- ;; lexical.
- (values (find-definition y 1)
- op))
- (else
- ;; We can't account for our aliases.
- (values #f #f))))))
- (else
- ;; A formal parameter. Can't say anything about that.
- (values #f #f))))
- ((= n-aliases 1)
- ;; Not a lexical: success, but only if we are looking for an
- ;; unaliased value.
- (values x #f))
- (else (values #f #f))))
(let ((tag (for-value tag))
(body (for-tail body)))
(letrec* ((a (lambda (x) (top x)))
(b (lambda () a)))
(foo (b) (b)))
- (apply (toplevel foo)
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))))
+ (call (toplevel foo)
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))))
- (pass-if-peval resolve-primitives
++ (pass-if-peval
+ ;; The inliner sees through a `let'.
+ ((let ((a 10)) (lambda (b) (* b 2))) 30)
+ (const 60))
+
+ (pass-if-peval
+ ((lambda ()
+ (define (const x) (lambda (_) x))
+ (let ((v #f))
+ ((const #t) v))))
+ (const #t))
+
+ (pass-if-peval
+ ;; Applications of procedures with rest arguments can get inlined.
+ ((lambda (x y . z)
+ (list x y z))
+ 1 2 3 4)
- (let (z) (_) ((apply (primitive list) (const 3) (const 4)))
- (apply (primitive list) (const 1) (const 2) (lexical z _))))
++ (let (z) (_) ((primcall list (const 3) (const 4)))
++ (primcall list (const 1) (const 2) (lexical z _))))
+
- (pass-if-peval resolve-primitives
++ (pass-if-peval
+ ;; Unmutated lists can get inlined.
+ (let ((args (list 2 3)))
+ (apply (lambda (x y z w)
+ (list x y z w))
+ 0 1 args))
- (apply (primitive list) (const 0) (const 1) (const 2) (const 3)))
++ (primcall list (const 0) (const 1) (const 2) (const 3)))
+
- (pass-if-peval resolve-primitives
++ (pass-if-peval
+ ;; However if the list might have been mutated, it doesn't propagate.
+ (let ((args (list 2 3)))
+ (foo! args)
+ (apply (lambda (x y z w)
+ (list x y z w))
+ 0 1 args))
- (let (args) (_) ((apply (primitive list) (const 2) (const 3)))
- (begin
- (apply (toplevel foo!) (lexical args _))
- (apply (primitive @apply)
- (lambda ()
- (lambda-case
- (((x y z w) #f #f #f () (_ _ _ _))
- (apply (primitive list)
- (lexical x _) (lexical y _)
- (lexical z _) (lexical w _)))))
- (const 0)
- (const 1)
- (lexical args _)))))
-
- (pass-if-peval resolve-primitives
++ (let (args) (_) ((primcall list (const 2) (const 3)))
++ (seq
++ (call (toplevel foo!) (lexical args _))
++ (primcall @apply
++ (lambda ()
++ (lambda-case
++ (((x y z w) #f #f #f () (_ _ _ _))
++ (primcall list
++ (lexical x _) (lexical y _)
++ (lexical z _) (lexical w _)))))
++ (const 0)
++ (const 1)
++ (lexical args _)))))
++
++ (pass-if-peval
+ ;; Here the `args' that gets built by the application of the lambda
+ ;; takes more than effort "10" to visit. Test that we fall back to
+ ;; the source expression of the operand, which is still a call to
+ ;; `list', so the inlining still happens.
+ (lambda (bv offset n)
+ (let ((x (bytevector-ieee-single-native-ref
+ bv
+ (+ offset 0)))
+ (y (bytevector-ieee-single-native-ref
+ bv
+ (+ offset 4))))
+ (let ((args (list x y)))
+ (@apply
+ (lambda (bv offset x y)
+ (bytevector-ieee-single-native-set!
+ bv
+ (+ offset 0)
+ x)
+ (bytevector-ieee-single-native-set!
+ bv
+ (+ offset 4)
+ y))
+ bv
+ offset
+ args))))
+ (lambda ()
+ (lambda-case
+ (((bv offset n) #f #f #f () (_ _ _))
- (let (x y) (_ _) ((apply (primitive bytevector-ieee-single-native-ref)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 0)))
- (apply (primitive bytevector-ieee-single-native-ref)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 4))))
- (begin
- (apply (primitive bytevector-ieee-single-native-set!)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 0))
- (lexical x _))
- (apply (primitive bytevector-ieee-single-native-set!)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 4))
- (lexical y _))))))))
-
- (pass-if-peval resolve-primitives
++ (let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref
++ (lexical bv _)
++ (primcall +
++ (lexical offset _) (const 0)))
++ (primcall bytevector-ieee-single-native-ref
++ (lexical bv _)
++ (primcall +
++ (lexical offset _) (const 4))))
++ (seq
++ (primcall bytevector-ieee-single-native-set!
++ (lexical bv _)
++ (primcall +
++ (lexical offset _) (const 0))
++ (lexical x _))
++ (primcall bytevector-ieee-single-native-set!
++ (lexical bv _)
++ (primcall +
++ (lexical offset _) (const 4))
++ (lexical y _))))))))
++
++ (pass-if-peval
+ ;; Here we ensure that non-constant expressions are not copied.
+ (lambda ()
+ (let ((args (list (foo!))))
+ (@apply
+ (lambda (z x)
+ (list z x))
+ ;; This toplevel ref might raise an unbound variable exception.
+ ;; The effects of `(foo!)' must be visible before this effect.
+ z
+ args)))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ())
- (let (_) (_) ((apply (toplevel foo!)))
++ (let (_) (_) ((call (toplevel foo!)))
+ (let (z) (_) ((toplevel z))
- (apply (primitive 'list)
- (lexical z _)
- (lexical _ _))))))))
++ (primcall 'list
++ (lexical z _)
++ (lexical _ _))))))))
+
- (pass-if-peval resolve-primitives
++ (pass-if-peval
+ ;; Rest args referenced more than once are not destructured.
+ (lambda ()
+ (let ((args (list 'foo)))
+ (set-car! args 'bar)
+ (@apply
+ (lambda (z x)
+ (list z x))
+ z
+ args)))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ())
+ (let (args) (_)
- ((apply (primitive list) (const foo)))
- (begin
- (apply (primitive set-car!) (lexical args _) (const bar))
- (apply (primitive @apply)
- (lambda . _)
- (toplevel z)
- (lexical args _))))))))
-
- (pass-if-peval resolve-primitives
++ ((primcall list (const foo)))
++ (seq
++ (primcall set-car! (lexical args _) (const bar))
++ (primcall @apply
++ (lambda . _)
++ (toplevel z)
++ (lexical args _))))))))
++
++ (pass-if-peval
+ ;; Let-values inlining, even with consumers with rest args.
+ (call-with-values (lambda () (values 1 2))
+ (lambda args
+ (apply list args)))
- (apply (primitive list) (const 1) (const 2)))
++ (primcall list (const 1) (const 2)))
+
(pass-if-peval
;; Constant folding: cons of #nil does not make list
(cons 1 #nil)
HCoop / bpt / guile.git / commitdiff