[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-315
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-315-gef47c42 |
|
Date: |
Thu, 31 Oct 2013 21:16:54 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ef47c4229c9c19db56bb0c123eba01c71c4a2011
The branch, wip-rtl-halloween has been updated
via ef47c4229c9c19db56bb0c123eba01c71c4a2011 (commit)
via 3e248c70e3be268b6ad71c9eee9895519ab0495f (commit)
via 5bff312598d025730976a52a27b8582b3707c73b (commit)
via dda5fd94de382e96b4c9bad9750aee3e4fe3bacc (commit)
via c7cb2bc20042cbaa4058b92eb36762e5ea72a1e0 (commit)
from 57a5cc97609bfb6e90952352095cc8245473b8c5 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit ef47c4229c9c19db56bb0c123eba01c71c4a2011
Author: Andy Wingo <address@hidden>
Date: Thu Oct 31 22:16:10 2013 +0100
Be smarter about capturing the environment for memoized code
* libguile/memoize.h (SCM_M_CAPTURE_MODULE)
* libguile/memoize.c (MAKMEMO_CAPTURE_MODULE, capture_env):
(maybe_makmemo_capture_module, memoize): Determine when to capture the
module on the environment chain at compile-time, instead of at
runtime. Introduces a new memoized expression type, capture-module.
(scm_memoized_expression): Start memoizing with #f as the
environment.
(unmemoize): Add unmemoizer.
(scm_memoize_variable_access_x): Cope with #f as module, and treat as
the root module (captured before modules were booted).
* libguile/eval.c (eval):
* module/ice-9/eval.scm (primitive-eval): Adapt.
commit 3e248c70e3be268b6ad71c9eee9895519ab0495f
Author: Andy Wingo <address@hidden>
Date: Thu Oct 31 20:39:22 2013 +0100
define! is an interesting primitive
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
Add define!.
commit 5bff312598d025730976a52a27b8582b3707c73b
Author: Andy Wingo <address@hidden>
Date: Thu Oct 31 20:24:38 2013 +0100
fix compilation of (let lp () (lp))
* module/language/cps/dfg.scm (reverse-post-order): Add an optional
"fold-all-conts" argument.
(compute-live-variables): Take the function as an arg instead of the
start continuation, and implement fold-all-conts so that nodes that
never reach the tail also get liveness information.
commit dda5fd94de382e96b4c9bad9750aee3e4fe3bacc
Author: Andy Wingo <address@hidden>
Date: Thu Oct 31 19:24:42 2013 +0100
DFG: Export analyze-control-flow.
* module/language/cps/dfg.scm ($cfa, $dominator-analysis): Remove
dominator things from $cfa, to break out to separate structure.
(cfa-k-idx, cfa-k-count, cfa-k-sym, cfa-predecessors): New public
accessors.
(analyze-control-flow): New public function.
(analyze-dominators): Adapt.
commit c7cb2bc20042cbaa4058b92eb36762e5ea72a1e0
Author: Andy Wingo <address@hidden>
Date: Thu Oct 31 19:21:31 2013 +0100
static-patch! for pair and vector fields
* module/system/vm/assembler.scm (intern-constant): Use static-patch!
for fields.
-----------------------------------------------------------------------
Summary of changes:
libguile/eval.c | 29 +---
libguile/memoize.c | 67 ++++++--
libguile/memoize.h | 1 +
module/ice-9/eval.scm | 36 ++---
module/language/cps/dfg.scm | 260 +++++++++++++++++--------------
module/language/cps/slot-allocation.scm | 6 +-
module/language/tree-il/primitives.scm | 2 +-
module/system/vm/assembler.scm | 8 +-
8 files changed, 220 insertions(+), 189 deletions(-)
diff --git a/libguile/eval.c b/libguile/eval.c
index 43a182a..1572c87 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -245,18 +245,6 @@ truncate_values (SCM x)
}
#define EVAL1(x, env) (truncate_values (eval ((x), (env))))
-/* the environment:
- (VAL ... . MOD)
- If MOD is #f, it means the environment was captured before modules were
- booted.
- If MOD is the literal value '(), we are evaluating at the top level, and so
- should track changes to the current module. You have to be careful in this
- case, because further lexical contours should capture the current module.
-*/
-#define CAPTURE_ENV(env) \
- (scm_is_null (env) ? scm_current_module () : \
- (scm_is_false (env) ? scm_the_root_module () : env))
-
static SCM
eval (SCM x, SCM env)
{
@@ -288,8 +276,7 @@ eval (SCM x, SCM env)
SCM new_env;
int i;
- new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED,
- CAPTURE_ENV (env));
+ new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
for (i = 0; i < VECTOR_LENGTH (inits); i++)
env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
env = new_env;
@@ -298,7 +285,7 @@ eval (SCM x, SCM env)
}
case SCM_M_LAMBDA:
- RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
+ RETURN_BOOT_CLOSURE (mx, env);
case SCM_M_QUOTE:
return mx;
@@ -307,6 +294,9 @@ eval (SCM x, SCM env)
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
+ case SCM_M_CAPTURE_MODULE:
+ return eval (mx, scm_current_module ());
+
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
@@ -405,8 +395,7 @@ eval (SCM x, SCM env)
else
{
env = env_tail (env);
- return SCM_VARIABLE_REF
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
+ return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, env));
}
case SCM_M_TOPLEVEL_SET:
@@ -421,9 +410,7 @@ eval (SCM x, SCM env)
else
{
env = env_tail (env);
- SCM_VARIABLE_SET
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
- val);
+ SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, env), val);
return SCM_UNSPECIFIED;
}
}
@@ -654,7 +641,7 @@ scm_c_primitive_eval (SCM exp)
{
if (!SCM_EXPANDED_P (exp))
exp = scm_call_1 (scm_current_module_transformer (), exp);
- return eval (scm_memoize_expression (exp), SCM_EOL);
+ return eval (scm_memoize_expression (exp), SCM_BOOL_F);
}
static SCM var_primitive_eval;
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 6eb36d4..5c7129f 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -131,6 +131,8 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_QUOTE, exp)
#define MAKMEMO_DEFINE(var, val) \
MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
+#define MAKMEMO_CAPTURE_MODULE(exp) \
+ MAKMEMO (SCM_M_CAPTURE_MODULE, exp)
#define MAKMEMO_APPLY(proc, args)\
MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
#define MAKMEMO_CONT(proc) \
@@ -166,6 +168,7 @@ static const char *const memoized_tags[] =
"let",
"quote",
"define",
+ "capture-module",
"apply",
"call/cc",
"call-with-values",
@@ -240,6 +243,22 @@ memoize_exps (SCM exps, SCM env)
}
static SCM
+capture_env (SCM env)
+{
+ if (scm_is_false (env))
+ return SCM_BOOL_T;
+ return env;
+}
+
+static SCM
+maybe_makmemo_capture_module (SCM exp, SCM env)
+{
+ if (scm_is_false (env))
+ return MAKMEMO_CAPTURE_MODULE (exp);
+ return exp;
+}
+
+static SCM
memoize (SCM exp, SCM env)
{
if (!SCM_EXPANDED_P (exp))
@@ -255,7 +274,9 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
- return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME)),
+ env);
else
return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F);
@@ -279,11 +300,15 @@ memoize (SCM exp, SCM env)
REF (exp, MODULE_SET, PUBLIC));
case SCM_EXPANDED_TOPLEVEL_REF:
- return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME)), env);
case SCM_EXPANDED_TOPLEVEL_SET:
- return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
- memoize (REF (exp, TOPLEVEL_SET, EXP), env));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
+ memoize (REF (exp, TOPLEVEL_SET, EXP),
+ capture_env (env))),
+ env);
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
@@ -343,7 +368,9 @@ memoize (SCM exp, SCM env)
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
- return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
+ return MAKMEMO_CALL (maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (name), env),
+ nargs, args);
else
return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
SCM_BOOL_F),
@@ -381,11 +408,11 @@ memoize (SCM exp, SCM env)
meta);
else
{
- proc = memoize (body, env);
+ proc = memoize (body, capture_env (env));
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
}
- return proc;
+ return maybe_makmemo_capture_module (proc, env);
}
case SCM_EXPANDED_LAMBDA_CASE:
@@ -462,11 +489,12 @@ memoize (SCM exp, SCM env)
varsv = scm_vector (vars);
inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
SCM_BOOL_F);
- new_env = scm_cons (varsv, env);
+ new_env = scm_cons (varsv, capture_env (env));
for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
VECTOR_SET (inits, i, memoize (CAR (exps), env));
- return MAKMEMO_LET (inits, memoize (body, new_env));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (inits, memoize (body, new_env)), env);
}
case SCM_EXPANDED_LETREC:
@@ -484,7 +512,7 @@ memoize (SCM exp, SCM env)
expsv = scm_vector (exps);
undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED));
- new_env = scm_cons (varsv, env);
+ new_env = scm_cons (varsv, capture_env (env));
if (in_order_p)
{
@@ -495,7 +523,8 @@ memoize (SCM exp, SCM env)
body_exps = MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i),
init),
body_exps);
}
- return MAKMEMO_LET (undefs, body_exps);
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (undefs, body_exps), env);
}
else
{
@@ -518,9 +547,11 @@ memoize (SCM exp, SCM env)
if (scm_is_false (sets))
return memoize (body, env);
- return MAKMEMO_LET (undefs,
- MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
- memoize (body, new_env)));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (undefs,
+ MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
+ memoize (body, new_env))),
+ env);
}
}
@@ -538,7 +569,7 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression",
1, 0, 0,
#define FUNC_NAME s_scm_memoize_expression
{
SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
- return memoize (exp, scm_current_module ());
+ return memoize (exp, SCM_BOOL_F);
}
#undef FUNC_NAME
@@ -612,6 +643,9 @@ unmemoize (const SCM expr)
unmemoize (CAR (args)), unmemoize (CDR (args)));
case SCM_M_DEFINE:
return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
+ case SCM_M_CAPTURE_MODULE:
+ return scm_list_2 (scm_from_latin1_symbol ("capture-module"),
+ unmemoize (args));
case SCM_M_IF:
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
unmemoize (scm_cadr (args)), unmemoize (scm_cddr
(args)));
@@ -735,6 +769,9 @@ SCM_DEFINE (scm_memoize_variable_access_x,
"memoize-variable-access!", 2, 0, 0,
{
SCM mx = SCM_MEMOIZED_ARGS (m);
+ if (scm_is_false (mod))
+ mod = scm_the_root_module ();
+
switch (SCM_MEMOIZED_TAG (m))
{
case SCM_M_TOPLEVEL_REF:
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 95e92a3..68dcd21 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -69,6 +69,7 @@ enum
SCM_M_LET,
SCM_M_QUOTE,
SCM_M_DEFINE,
+ SCM_M_CAPTURE_MODULE,
SCM_M_APPLY,
SCM_M_CONT,
SCM_M_CALL_WITH_VALUES,
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index ed51039..e34c087 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -43,20 +43,6 @@
(eval-when (compile)
- (define-syntax capture-env
- (syntax-rules ()
- ((_ (exp ...))
- (let ((env (exp ...)))
- (capture-env env)))
- ((_ env)
- (if (null? env)
- (current-module)
- (if (not env)
- ;; the and current-module checks that modules are booted,
- ;; and thus the-root-module is defined
- (and (current-module) the-root-module)
- env)))))
-
(define-syntax env-toplevel
(syntax-rules ()
((_ env)
@@ -459,8 +445,7 @@
(variable-ref
(if (variable? var-or-sym)
var-or-sym
- (memoize-variable-access! exp
- (capture-env (env-toplevel env))))))
+ (memoize-variable-access! exp (env-toplevel env)))))
(('if (test consequent . alternate))
(if (eval test env)
@@ -472,7 +457,7 @@
(('let (inits . body))
(let* ((width (vector-length inits))
- (new-env (make-env width #f (capture-env env))))
+ (new-env (make-env width #f env)))
(let lp ((i 0))
(when (< i width)
(env-set! new-env 0 i (eval (vector-ref inits i) env))
@@ -482,11 +467,10 @@
(('lambda (body meta nreq . tail))
(let ((proc
(if (null? tail)
- (make-fixed-closure eval nreq body (capture-env env))
+ (make-fixed-closure eval nreq body env)
(if (null? (cdr tail))
- (make-rest-closure eval nreq body (capture-env env))
- (apply make-general-closure (capture-env env)
- body nreq tail)))))
+ (make-rest-closure eval nreq body env)
+ (apply make-general-closure env body nreq tail)))))
(let lp ((meta meta))
(unless (null? meta)
(set-procedure-property! proc (caar meta) (cdar meta))
@@ -518,13 +502,15 @@
(begin
(define! name (eval x env))
(if #f #f)))
-
+
+ (('capture-module x)
+ (eval x (current-module)))
+
(('toplevel-set! (var-or-sym . x))
(variable-set!
(if (variable? var-or-sym)
var-or-sym
- (memoize-variable-access! exp
- (capture-env (env-toplevel env))))
+ (memoize-variable-access! exp (env-toplevel env)))
(eval x env)))
(('call-with-prompt (tag thunk . handler))
@@ -551,4 +537,4 @@
(if (macroexpanded? exp)
exp
((module-transformer (current-module)) exp)))
- '()))))
+ #f))))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index a3b6062..faefcd3 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -62,6 +62,10 @@
control-point?
lookup-bound-syms
+ ;; Control flow analysis.
+ analyze-control-flow
+ cfa-k-idx cfa-k-count cfa-k-sym cfa-predecessors
+
;; Data flow analysis.
compute-live-variables
dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
@@ -118,7 +122,13 @@
(define (make-block scope scope-level)
(%make-block scope scope-level '() '()))
-(define (reverse-post-order k0 get-successors)
+;; Some analyses assume that the only relevant set of nodes is the set
+;; that is reachable from some start node. Others need to include nodes
+;; that are reachable from an end node as well, or all nodes in a
+;; function. In that case pass an appropriate implementation of
+;; fold-all-conts, as compute-live-variables does.
+(define* (reverse-post-order k0 get-successors #:optional
+ (fold-all-conts (lambda (f seed) seed)))
(let ((order '())
(visited? (make-hash-table)))
(let visit ((k k0))
@@ -128,7 +138,14 @@
(visit k)))
(get-successors k))
(set! order (cons k order)))
- (list->vector order)))
+ (list->vector (fold-all-conts
+ (lambda (k seed)
+ (if (hashq-ref visited? k)
+ seed
+ (begin
+ (hashq-set! visited? k #t)
+ (cons k seed))))
+ order))))
(define (make-block-mapping order)
(let ((mapping (make-hash-table)))
@@ -148,22 +165,69 @@
;; Control-flow analysis.
(define-record-type $cfa
- (make-cfa k-map order preds idoms dom-levels loop-header irreducible)
+ (make-cfa k-map order preds)
cfa?
;; Hash table mapping k-sym -> k-idx
(k-map cfa-k-map)
;; Vector of k-idx -> k-sym, in reverse post order
(order cfa-order)
;; Vector of k-idx -> list of k-idx
- (preds cfa-preds)
+ (preds cfa-preds))
+
+(define* (cfa-k-idx cfa k
+ #:key (default (lambda (k)
+ (error "unknown k" k))))
+ (or (hashq-ref (cfa-k-map cfa) k)
+ (default k)))
+
+(define (cfa-k-count cfa)
+ (vector-length (cfa-order cfa)))
+
+(define (cfa-k-sym cfa n)
+ (vector-ref (cfa-order cfa) n))
+
+(define (cfa-predecessors cfa n)
+ (vector-ref (cfa-preds cfa) n))
+
+(define* (analyze-control-flow fun dfg #:key reverse?)
+ (define (build-cfa kentry block-succs block-preds)
+ (define (block-accessor accessor)
+ (lambda (k)
+ (accessor (lookup-block k (dfg-blocks dfg)))))
+ (define (reachable-preds mapping accessor)
+ ;; It's possible for a predecessor to not be in the mapping, if
+ ;; the predecessor is not reachable from the entry node.
+ (lambda (k)
+ (filter-map (cut hashq-ref mapping <>)
+ ((block-accessor accessor) k))))
+ (let* ((order (reverse-post-order kentry (block-accessor block-succs)))
+ (k-map (make-block-mapping order))
+ (preds (convert-predecessors order
+ (reachable-preds k-map block-preds))))
+ (make-cfa k-map order preds)))
+ (match fun
+ (($ $fun meta free
+ ($ $cont kentry src
+ (and entry
+ ($ $kentry self ($ $cont ktail _ tail) clauses))))
+ (if reverse?
+ (build-cfa ktail block-preds block-succs)
+ (build-cfa kentry block-succs block-preds)))))
+
+;; Dominator analysis.
+(define-record-type $dominator-analysis
+ (make-dominator-analysis cfa idoms dom-levels loop-header irreducible)
+ dominator-analysis?
+ ;; The corresponding $cfa
+ (cfa dominator-analysis-cfa)
;; Vector of k-idx -> k-idx
- (idoms cfa-idoms)
+ (idoms dominator-analysis-idoms)
;; Vector of k-idx -> dom-level
- (dom-levels cfa-dom-levels)
+ (dom-levels dominator-analysis-dom-levels)
;; Vector of k-idx -> k-idx or -1
- (loop-header cfa-loop-header)
+ (loop-header dominator-analysis-loop-header)
;; Vector of k-idx -> true or false value
- (irreducible cfa-irreducible))
+ (irreducible dominator-analysis-irreducible))
(define (compute-dom-levels idoms)
(let ((dom-levels (make-vector (vector-length idoms) #f)))
@@ -376,33 +440,13 @@
(lp (1- level))))
loop-headers))
-(define* (analyze-control-flow fun dfg #:key reverse?)
- (define (build-cfa kentry block-succs block-preds)
- (define (block-accessor accessor)
- (lambda (k)
- (accessor (lookup-block k blocks))))
- (define (reachable-preds mapping accessor)
- ;; It's possible for a predecessor to not be in the mapping, if
- ;; the predecessor is not reachable from the entry node.
- (lambda (k)
- (filter-map (cut hashq-ref mapping <>)
- ((block-accessor accessor) k))))
- (let* ((order (reverse-post-order kentry (block-accessor block-succs)))
- (k-map (make-block-mapping order))
- (preds (convert-predecessors order
- (reachable-preds k-map block-preds)))
- (idoms (compute-idoms preds))
- (dom-levels (compute-dom-levels idoms))
- (loop-headers (identify-loops preds idoms dom-levels)))
- (make-cfa k-map order preds idoms dom-levels loop-headers #f)))
- (match fun
- (($ $fun meta free
- ($ $cont kentry src
- (and entry
- ($ $kentry self ($ $cont ktail _ tail) clauses))))
- (if reverse?
- (build-cfa ktail block-preds block-succs)
- (build-cfa kentry block-succs block-preds)))))
+(define (analyze-dominators cfa)
+ (match cfa
+ (($ $cfa k-map order preds)
+ (let* ((idoms (compute-idoms preds))
+ (dom-levels (compute-dom-levels idoms))
+ (loop-headers (identify-loops preds idoms dom-levels)))
+ (make-dominator-analysis cfa idoms dom-levels loop-headers #f)))))
;; Compute the maximum fixed point of the data-flow constraint problem.
@@ -488,7 +532,7 @@
(define (dfa-k-out dfa idx)
(vector-ref (dfa-out dfa) idx))
-(define (compute-live-variables ktail dfg)
+(define (compute-live-variables fun dfg)
(define (make-variable-mapping use-maps)
(let ((mapping (make-hash-table))
(n 0))
@@ -500,59 +544,67 @@
(define (block-accessor blocks accessor)
(lambda (k)
(accessor (lookup-block k blocks))))
- (define (reachable-preds mapping blocks accessor)
- ;; It's possible for a predecessor to not be in the mapping, if
- ;; the predecessor is not reachable from the entry node.
+ (define (renumbering-accessor mapping blocks accessor)
(lambda (k)
- (filter-map (cut hashq-ref mapping <>)
- ((block-accessor blocks accessor) k))))
- (call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
- (lambda (var-map nvars)
- (let* ((blocks (dfg-blocks dfg))
- (order (reverse-post-order ktail
- (block-accessor blocks block-preds)))
- (k-map (make-block-mapping order))
- (succs (convert-predecessors
- order
- (reachable-preds k-map blocks block-succs)))
- (syms (make-vector nvars #f))
- (names (make-vector nvars #f))
- (usev (make-vector (vector-length order) '()))
- (defv (make-vector (vector-length order) '()))
- (live-in (make-vector (vector-length order) #f))
- (live-out (make-vector (vector-length order) #f)))
- (define (k->idx k)
- (or (hashq-ref k-map k) (error "unknown k" k)))
- ;; Initialize syms, names, defv, and usev.
- (hash-for-each
- (lambda (sym use-map)
- (match use-map
- (($ $use-map name sym def uses)
- (let ((v (or (hashq-ref var-map sym) (error "unknown var" sym))))
- (vector-set! syms v sym)
- (vector-set! names v name)
- (for-each (lambda (def)
- (vector-push! defv (k->idx def) v))
- ((block-accessor blocks block-preds) def))
- (for-each (lambda (use)
- (vector-push! usev (k->idx use) v))
- uses)))))
- (dfg-use-maps dfg))
-
- ;; Initialize live-in and live-out sets.
- (let lp ((n 0))
- (when (< n (vector-length live-out))
- (vector-set! live-in n (make-bitvector nvars #f))
- (vector-set! live-out n (make-bitvector nvars #f))
- (lp (1+ n))))
-
- ;; Liveness is a reverse data-flow problem, so we give
- ;; compute-maximum-fixed-point a reversed graph, swapping in and
- ;; out, usev and defv, using successors instead of predecessors,
- ;; and starting with ktail instead of the entry.
- (compute-maximum-fixed-point succs live-out live-in defv usev #t)
-
- (make-dfa k-map order var-map names syms live-in live-out)))))
+ (map (cut hashq-ref mapping <>)
+ ((block-accessor blocks accessor) k))))
+ (match fun
+ (($ $fun meta free
+ (and entry
+ ($ $cont kentry src ($ $kentry self ($ $cont ktail _ tail)))))
+ (call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
+ (lambda (var-map nvars)
+ (define (fold-all-conts f seed)
+ (fold-local-conts (lambda (k src cont seed) (f k seed))
+ seed entry))
+ (let* ((blocks (dfg-blocks dfg))
+ (order (reverse-post-order ktail
+ (block-accessor blocks block-preds)
+ fold-all-conts))
+ (k-map (make-block-mapping order))
+ (succs (convert-predecessors
+ order
+ (renumbering-accessor k-map blocks block-succs)))
+ (syms (make-vector nvars #f))
+ (names (make-vector nvars #f))
+ (usev (make-vector (vector-length order) '()))
+ (defv (make-vector (vector-length order) '()))
+ (live-in (make-vector (vector-length order) #f))
+ (live-out (make-vector (vector-length order) #f)))
+ (define (k->idx k)
+ (or (hashq-ref k-map k) (error "unknown k" k)))
+ ;; Initialize syms, names, defv, and usev.
+ (hash-for-each
+ (lambda (sym use-map)
+ (match use-map
+ (($ $use-map name sym def uses)
+ (let ((v (or (hashq-ref var-map sym)
+ (error "unknown var" sym))))
+ (vector-set! syms v sym)
+ (vector-set! names v name)
+ (for-each (lambda (def)
+ (vector-push! defv (k->idx def) v))
+ ((block-accessor blocks block-preds) def))
+ (for-each (lambda (use)
+ (vector-push! usev (k->idx use) v))
+ uses)))))
+ (dfg-use-maps dfg))
+
+ ;; Initialize live-in and live-out sets.
+ (let lp ((n 0))
+ (when (< n (vector-length live-out))
+ (vector-set! live-in n (make-bitvector nvars #f))
+ (vector-set! live-out n (make-bitvector nvars #f))
+ (lp (1+ n))))
+
+ ;; Liveness is a reverse data-flow problem, so we give
+ ;; compute-maximum-fixed-point a reversed graph, swapping in
+ ;; and out, usev and defv, using successors instead of
+ ;; predecessors, and starting with ktail instead of the
+ ;; entry.
+ (compute-maximum-fixed-point succs live-out live-in defv usev #t)
+
+ (make-dfa k-map order var-map names syms live-in live-out)))))))
(define (print-dfa dfa)
(match dfa
@@ -694,12 +746,7 @@
(link-blocks! kclause kbody)
(visit body kbody)))
- clauses)
-
- ;; Currently we don't need to build dominator trees. When we do,
- ;; probably we should require the user to do so herself.
- #;
- (analyze-control-flow! kentry ktail blocks))))
+ clauses))))
(define* (compute-dfg fun #:key (global? #t))
(let* ((conts (make-hash-table))
@@ -851,31 +898,6 @@
(($ $use-map name sym def uses)
uses))))))
-;; Does k1 dominate k2?
-(define (dominates? k1 k2 blocks)
- (let ((b1 (lookup-block k1 blocks))
- (b2 (lookup-block k2 blocks)))
- (let ((k1-level (block-dom-level b1))
- (k2-level (block-dom-level b2)))
- (cond
- ((> k1-level k2-level) #f)
- ((< k1-level k2-level) (dominates? k1 (block-idom b2) blocks))
- ((= k1-level k2-level) (eqv? k1 k2))))))
-
-;; Does k1 post-dominate k2?
-(define (post-dominates? k1 k2 blocks)
- (let ((b1 (lookup-block k1 blocks))
- (b2 (lookup-block k2 blocks)))
- (let ((k1-level (block-pdom-level b1))
- (k2-level (block-pdom-level b2)))
- (cond
- ((> k1-level k2-level) #f)
- ((< k1-level k2-level) (post-dominates? k1 (block-pdom b2) blocks))
- ((= k1-level k2-level) (eqv? k1 k2))))))
-
-(define (lookup-loop-header k blocks)
- (block-loop-header (lookup-block k blocks)))
-
;; A continuation is a control point if it has multiple predecessors, or
;; if its single predecessor has multiple successors.
(define (control-point? k dfg)
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 9d3dae8..ddc3751 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -425,11 +425,9 @@ are comparable with eqv?. A tmp slot may be used."
(hashq-set! allocation k nlocals))))
(match fun
- (($ $fun meta free ($ $cont k _ ($ $kentry self
- ($ $cont ktail _ ($ $ktail))
- clauses)))
+ (($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses)))
(let* ((dfg (compute-dfg fun #:global? #f))
- (dfa (compute-live-variables ktail dfg))
+ (dfa (compute-live-variables fun dfg))
(allocation (make-hash-table))
(slots (make-vector (dfa-var-count dfa) #f))
(live-slots (add-live-slot 0 (empty-live-slots))))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index b56e54c..46bc4eb 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -77,7 +77,7 @@
variable? variable-ref variable-set!
variable-bound?
- current-module
+ current-module define!
fluid-ref fluid-set! with-fluid*
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index bee6257..811841e 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -543,10 +543,10 @@ table, its existing label is used directly."
(define (field dst n obj)
(let ((src (recur obj)))
(if src
- (list (if (statically-allocatable? obj)
- `(make-non-immediate 1 ,src)
- `(static-ref 1 ,src))
- `(static-set! 1 ,dst ,n))
+ (if (statically-allocatable? obj)
+ `((static-patch! ,dst ,n ,src))
+ `((static-ref 1 ,src)
+ (static-set! 1 ,dst ,n)))
'())))
(define (intern obj label)
(cond
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-315-gef47c42,
Andy Wingo <=