From 8d7ebc510603772433b865ae8aa99ec0413793da Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 12 Sep 2008 18:08:19 -0500
Subject: [PATCH 01/16] Change stack effect of nths to match nth, rice
bounds-check?
---
.../strength-reduction-tests.factor | 119 ------------------
.../strength-reduction.factor | 5 -
core/sequences/sequences.factor | 6 +-
3 files changed, 3 insertions(+), 127 deletions(-)
delete mode 100644 basis/compiler/tree/strength-reduction/strength-reduction-tests.factor
delete mode 100644 basis/compiler/tree/strength-reduction/strength-reduction.factor
diff --git a/basis/compiler/tree/strength-reduction/strength-reduction-tests.factor b/basis/compiler/tree/strength-reduction/strength-reduction-tests.factor
deleted file mode 100644
index 86fe74d939..0000000000
--- a/basis/compiler/tree/strength-reduction/strength-reduction-tests.factor
+++ /dev/null
@@ -1,119 +0,0 @@
-! TUPLE: declared-fixnum { x fixnum } ;
-!
-! [ t ] [
-! [ { declared-fixnum } declare [ 1 + ] change-x ]
-! { + fixnum+ >fixnum } inlined?
-! ] unit-test
-!
-! [ t ] [
-! [ { declared-fixnum } declare x>> drop ]
-! { slot } inlined?
-! ] unit-test
-!
-! [ t ] [
-! [ hashtable new ] \ new inlined?
-! ] unit-test
-!
-! [ t ] [
-! [ dup hashtable eq? [ new ] when ] \ new inlined?
-! ] unit-test
-!
-! [ f ] [
-! [ { integer } declare -63 shift 4095 bitand ]
-! \ shift inlined?
-! ] unit-test
-!
-! [ t ] [
-! [ { integer } declare 127 bitand 3 + ]
-! { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
-! ] unit-test
-!
-! [ f ] [
-! [ { integer } declare 127 bitand 3 + ]
-! { >fixnum } inlined?
-! ] unit-test
-!
-! [ t ] [
-! [
-! { integer } declare
-! dup 0 >= [
-! 615949 * 797807 + 20 2^ mod dup 19 2^ -
-! ] [ dup ] if
-! ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
-! ] unit-test
-!
-! [ t ] [
-! [
-! { fixnum } declare
-! 615949 * 797807 + 20 2^ mod dup 19 2^ -
-! ] { >fixnum } inlined?
-! ] unit-test
-!
-! [ t ] [
-! [
-! { integer } declare 0 swap
-! [
-! drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
-! ] map
-! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
-! ] unit-test
-!
-! [ t ] [
-! [
-! { fixnum } declare 0 swap
-! [
-! drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
-! ] map
-! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
-! ] unit-test
-!
-! [ t ] [
-! [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
-! ] unit-test
-!
-! [ t ] [
-! [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
-! ] unit-test
-!
-! [ t ] [
-! [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
-! ] unit-test
-!
-!
-!
-! [ t ] [
-! [
-! { integer } declare [ 256 mod ] map
-! ] { mod fixnum-mod } inlined?
-! ] unit-test
-!
-!
-! [ f ] [
-! [
-! 256 mod
-! ] { mod fixnum-mod } inlined?
-! ] unit-test
-!
-! [ f ] [
-! [
-! dup 0 >= [ 256 mod ] when
-! ] { mod fixnum-mod } inlined?
-! ] unit-test
-!
-! [ t ] [
-! [
-! { integer } declare dup 0 >= [ 256 mod ] when
-! ] { mod fixnum-mod } inlined?
-! ] unit-test
-!
-! [ t ] [
-! [
-! { integer } declare 256 rem
-! ] { mod fixnum-mod } inlined?
-! ] unit-test
-!
-! [ t ] [
-! [
-! { integer } declare [ 256 rem ] map
-! ] { mod fixnum-mod rem } inlined?
-! ] unit-test
diff --git a/basis/compiler/tree/strength-reduction/strength-reduction.factor b/basis/compiler/tree/strength-reduction/strength-reduction.factor
deleted file mode 100644
index c36395bbee..0000000000
--- a/basis/compiler/tree/strength-reduction/strength-reduction.factor
+++ /dev/null
@@ -1,5 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.strength-reduction
-
-: strength-reduce ( nodes -- nodes' ) ;
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index b08d6eb2c7..6cda7fc73f 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -51,7 +51,7 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
: push ( elt seq -- ) [ length ] [ set-nth ] bi ;
: bounds-check? ( n seq -- ? )
- length 1- 0 swap between? ; inline
+ dupd length < [ 0 >= ] [ drop f ] if ; inline
ERROR: bounds-error index seq ;
@@ -485,8 +485,8 @@ PRIVATE>
[ rot = [ over push ] [ drop ] if ]
curry each-index ;
-: nths ( seq indices -- seq' )
- swap [ nth ] curry map ;
+: nths ( indices seq -- seq' )
+ [ nth ] curry map ;
: contains? ( seq quot -- ? )
find drop >boolean ; inline
From 10c68ebb21b4077210bddfc3a173908d66584e39 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 12 Sep 2008 18:08:38 -0500
Subject: [PATCH 02/16] New modular arithmetic optimization pass
---
.../tree/cleanup/cleanup-tests.factor | 16 +--
basis/compiler/tree/cleanup/cleanup.factor | 8 --
.../tree/dead-code/branches/branches.factor | 2 +-
basis/compiler/tree/debugger/debugger.factor | 45 +++++-
.../simplified/simplified-tests.factor | 10 ++
.../tree/def-use/simplified/simplified.factor | 40 ++++++
.../tree/finalization/finalization.factor | 31 +----
.../late-optimizations.factor | 29 ++++
.../modular-arithmetic-tests.factor | 130 ++++++++++++++++++
.../modular-arithmetic.factor | 108 +++++++++++++++
.../compiler/tree/optimizer/optimizer.factor | 5 +-
.../tree/propagation/inlining/inlining.factor | 13 +-
.../known-words/known-words.factor | 26 ++++
.../tree/propagation/propagation-tests.factor | 27 ++--
.../partial-dispatch-tests.factor | 17 ++-
.../partial-dispatch/partial-dispatch.factor | 54 ++++++--
16 files changed, 482 insertions(+), 79 deletions(-)
create mode 100644 basis/compiler/tree/def-use/simplified/simplified-tests.factor
create mode 100644 basis/compiler/tree/def-use/simplified/simplified.factor
create mode 100644 basis/compiler/tree/late-optimizations/late-optimizations.factor
create mode 100644 basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
create mode 100644 basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor
index 2e8eb15959..b3ba62b73b 100644
--- a/basis/compiler/tree/cleanup/cleanup-tests.factor
+++ b/basis/compiler/tree/cleanup/cleanup-tests.factor
@@ -13,10 +13,8 @@ compiler.tree.builder
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
-compiler.tree.checker ;
-
-: cleaned-up-tree ( quot -- nodes )
- build-tree analyze-recursive normalize propagate cleanup dup check-nodes ;
+compiler.tree.checker
+compiler.tree.debugger ;
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
@@ -34,12 +32,6 @@ compiler.tree.checker ;
[ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
-: inlined? ( quot seq/word -- ? )
- [ cleaned-up-tree ] dip
- dup word? [ 1array ] when
- '[ dup #call? [ word>> _ member? ] [ drop f ] if ]
- contains-node? not ;
-
[ f ] [
[ { integer } declare >fixnum ]
\ >fixnum inlined?
@@ -498,3 +490,7 @@ cell-bits 32 = [
[ 2 swap >fixnum ribs ]
{ <-integer-fixnum +-integer-fixnum } inlined?
] unit-test
+
+[ t ] [
+ [ hashtable new ] \ new inlined?
+] unit-test
diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index 58dc07d868..563926f233 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -64,14 +64,6 @@ GENERIC: cleanup* ( node -- node/nodes )
] [ body>> cleanup ] bi ;
! Removing overflow checks
-: no-overflow-variant ( op -- fast-op )
- H{
- { fixnum+ fixnum+fast }
- { fixnum- fixnum-fast }
- { fixnum* fixnum*fast }
- { fixnum-shift fixnum-shift-fast }
- } at ;
-
: (remove-overflow-check?) ( #call -- ? )
node-output-infos first class>> fixnum class<= ;
diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor
index a19e49494e..719c80f911 100644
--- a/basis/compiler/tree/dead-code/branches/branches.factor
+++ b/basis/compiler/tree/dead-code/branches/branches.factor
@@ -36,7 +36,7 @@ M: #branch remove-dead-code*
'[ _ nth _ key? ] filter ; inline
: drop-indexed-values ( values indices -- node )
- [ drop filter-live ] [ nths ] 2bi
+ [ drop filter-live ] [ swap nths ] 2bi
[ make-values ] keep
[ drop ] [ zip ] 2bi
#shuffle ;
diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor
index 691c564661..4d2881af5a 100644
--- a/basis/compiler/tree/debugger/debugger.factor
+++ b/basis/compiler/tree/debugger/debugger.factor
@@ -1,13 +1,21 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs fry match accessors namespaces make effects
+USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
-combinators io sorting hints
+combinators io sorting hints qualified
compiler.tree
+compiler.tree.recursive
+compiler.tree.normalization
+compiler.tree.cleanup
+compiler.tree.propagation
+compiler.tree.propagation.info
+compiler.tree.def-use
compiler.tree.builder
compiler.tree.optimizer
-compiler.tree.combinators ;
+compiler.tree.combinators
+compiler.tree.checker ;
+RENAME: _ match => __
IN: compiler.tree.debugger
! A simple tool for turning tree IR into quotations and
@@ -42,7 +50,7 @@ MATCH-VARS: ?a ?b ?c ;
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
{ { { ?a ?b } { ?b } } [ nip ] }
{ { { ?a ?b ?c } { ?c } } [ 2nip ] }
- { _ f }
+ { __ f }
} match-choose ;
TUPLE: shuffle-node { effect effect } ;
@@ -146,3 +154,32 @@ SYMBOL: node-count
: optimizer-report. ( word -- )
make-report report. ;
+
+! More utilities
+
+: final-info ( quot -- seq )
+ build-tree
+ analyze-recursive
+ normalize
+ propagate
+ compute-def-use
+ dup check-nodes
+ peek node-input-infos ;
+
+: final-classes ( quot -- seq )
+ final-info [ class>> ] map ;
+
+: final-literals ( quot -- seq )
+ final-info [ literal>> ] map ;
+
+: cleaned-up-tree ( quot -- nodes )
+ [
+ check-optimizer? on
+ build-tree optimize-tree
+ ] with-scope ;
+
+: inlined? ( quot seq/word -- ? )
+ [ cleaned-up-tree ] dip
+ dup word? [ 1array ] when
+ '[ dup #call? [ word>> _ member? ] [ drop f ] if ]
+ contains-node? not ;
diff --git a/basis/compiler/tree/def-use/simplified/simplified-tests.factor b/basis/compiler/tree/def-use/simplified/simplified-tests.factor
new file mode 100644
index 0000000000..a1a768d429
--- /dev/null
+++ b/basis/compiler/tree/def-use/simplified/simplified-tests.factor
@@ -0,0 +1,10 @@
+USING: kernel tools.test compiler.tree compiler.tree.builder
+compiler.tree.def-use compiler.tree.def-use.simplified accessors
+sequences sorting classes ;
+IN: compiler.tree.def-use.simplified
+
+[ { #call #return } ] [
+ [ 1 dup reverse ] build-tree compute-def-use
+ first out-d>> first actually-used-by
+ [ node>> class ] map natural-sort
+] unit-test
diff --git a/basis/compiler/tree/def-use/simplified/simplified.factor b/basis/compiler/tree/def-use/simplified/simplified.factor
new file mode 100644
index 0000000000..edfe633057
--- /dev/null
+++ b/basis/compiler/tree/def-use/simplified/simplified.factor
@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences sequences.deep kernel
+compiler.tree compiler.tree.def-use ;
+IN: compiler.tree.def-use.simplified
+
+! Simplified def-use follows chains of copies.
+
+! A 'real' usage is a usage of a value that is not a #renaming.
+TUPLE: real-usage value node ;
+
+GENERIC: actually-used-by* ( value node -- real-usages )
+
+! Def
+GENERIC: actually-defined-by* ( value node -- real-usage )
+
+: actually-defined-by ( value -- real-usage )
+ dup defined-by actually-defined-by* ;
+
+M: #renaming actually-defined-by*
+ inputs/outputs swap [ index ] dip nth actually-defined-by ;
+
+M: #return-recursive actually-defined-by* real-usage boa ;
+
+M: node actually-defined-by* real-usage boa ;
+
+! Use
+: (actually-used-by) ( value -- real-usages )
+ dup used-by [ actually-used-by* ] with map ;
+
+M: #renaming actually-used-by*
+ inputs/outputs [ indices ] dip nths
+ [ (actually-used-by) ] map ;
+
+M: #return-recursive actually-used-by* real-usage boa ;
+
+M: node actually-used-by* real-usage boa ;
+
+: actually-used-by ( value -- real-usages )
+ (actually-used-by) flatten ;
diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor
index ba7e4ff652..c312cb68dc 100644
--- a/basis/compiler/tree/finalization/finalization.factor
+++ b/basis/compiler/tree/finalization/finalization.factor
@@ -6,27 +6,20 @@ classes.tuple.private slots.private combinators layouts
byte-arrays alien.accessors
compiler.intrinsics
compiler.tree
-compiler.tree.builder
-compiler.tree.recursive
-compiler.tree.normalization
-compiler.tree.propagation
+compiler.tree.combinators
compiler.tree.propagation.info
-compiler.tree.cleanup
-compiler.tree.def-use
-compiler.tree.dead-code
-compiler.tree.combinators ;
+compiler.tree.late-optimizations ;
IN: compiler.tree.finalization
+! This is a late-stage optimization.
+! See the comment in compiler.tree.late-optimizations.
+
! This pass runs after propagation, so that it can expand
! built-in type predicates and memory allocation; these cannot
! be expanded before propagation since we need to see 'fixnum?'
! instead of 'tag 0 eq?' and so on, for semantic reasoning.
! We also delete empty stack shuffles and copies to facilitate
-! tail call optimization in the code generator. After this pass
-! runs, stack flow information is no longer accurate, since we
-! punt in 'splice-quot' and don't update everything that we
-! should; this simplifies the code, improves performance, and we
-! don't need the stack flow information after this pass anyway.
+! tail call optimization in the code generator.
GENERIC: finalize* ( node -- nodes )
@@ -37,18 +30,6 @@ M: #shuffle finalize*
[ in>> ] [ out>> ] bi sequence=
[ drop f ] when ;
-: splice-quot ( quot -- nodes )
- [
- build-tree
- analyze-recursive
- normalize
- propagate
- cleanup
- compute-def-use
- remove-dead-code
- but-last
- ] with-scope ;
-
: builtin-predicate? ( #call -- ? )
word>> "predicating" word-prop builtin-class? ;
diff --git a/basis/compiler/tree/late-optimizations/late-optimizations.factor b/basis/compiler/tree/late-optimizations/late-optimizations.factor
new file mode 100644
index 0000000000..e2641416b2
--- /dev/null
+++ b/basis/compiler/tree/late-optimizations/late-optimizations.factor
@@ -0,0 +1,29 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences namespaces compiler.tree.builder
+compiler.tree.recursive
+compiler.tree.normalization
+compiler.tree.propagation
+compiler.tree.propagation.info
+compiler.tree.cleanup
+compiler.tree.def-use
+compiler.tree.dead-code ;
+IN: compiler.tree.late-optimizations
+
+! Late optimizations modify the tree such that stack flow
+! information is no longer accurate, since we punt in
+! 'splice-quot' and don't update everything that we should;
+! this simplifies the code, improves performance, and we
+! don't need the stack flow information after this pass anyway.
+
+: splice-quot ( quot -- nodes )
+ [
+ build-tree
+ analyze-recursive
+ normalize
+ propagate
+ cleanup
+ compute-def-use
+ remove-dead-code
+ but-last
+ ] with-scope ;
diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
new file mode 100644
index 0000000000..b535dfe39c
--- /dev/null
+++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
@@ -0,0 +1,130 @@
+IN: compiler.tree.modular-arithmetic.tests
+USING: kernel kernel.private tools.test math math.partial-dispatch
+math.private accessors slots.private sequences strings sbufs
+compiler.tree.builder
+compiler.tree.optimizer
+compiler.tree.debugger ;
+
+: test-modular-arithmetic ( quot -- quot' )
+ build-tree optimize-tree nodes>quot ;
+
+[ [ >r >fixnum r> >fixnum fixnum+fast ] ]
+[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
+
+[ [ +-integer-integer dup >fixnum ] ]
+[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test
+
+[ [ >r >fixnum r> >fixnum fixnum+fast 4 fixnum*fast ] ]
+[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
+
+TUPLE: declared-fixnum { x fixnum } ;
+
+[ t ] [
+ [ { declared-fixnum } declare [ 1 + ] change-x ]
+ { + fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { declared-fixnum } declare x>> drop ]
+ { slot } inlined?
+] unit-test
+
+[ f ] [
+ [ { integer } declare -63 shift 4095 bitand ]
+ \ shift inlined?
+] unit-test
+
+[ t ] [
+ [ { integer } declare 127 bitand 3 + ]
+ { + +-integer-fixnum bitand } inlined?
+] unit-test
+
+[ f ] [
+ [ { integer } declare 127 bitand 3 + ]
+ { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare
+ dup 0 >= [
+ 615949 * 797807 + 20 2^ mod dup 19 2^ -
+ ] [ dup ] if
+ ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { fixnum } declare
+ 615949 * 797807 + 20 2^ mod dup 19 2^ -
+ ] { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare 0 swap
+ [
+ drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+ ] map
+ ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { fixnum } declare 0 swap
+ [
+ drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+ ] map
+ ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
+] unit-test
+
+[ t ] [
+ [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
+] unit-test
+
+[ t ] [
+ [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
+] unit-test
+
+
+
+[ t ] [
+ [
+ { integer } declare [ 256 mod ] map
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+
+[ f ] [
+ [
+ 256 mod
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ f ] [
+ [
+ dup 0 >= [ 256 mod ] when
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare dup 0 >= [ 256 mod ] when
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare 256 rem
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare [ 256 rem ] map
+ ] { mod fixnum-mod rem } inlined?
+] unit-test
diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
new file mode 100644
index 0000000000..d65b1def16
--- /dev/null
+++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
@@ -0,0 +1,108 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.partial-dispatch namespaces sequences sets
+accessors assocs words kernel memoize fry combinators
+compiler.tree
+compiler.tree.combinators
+compiler.tree.def-use
+compiler.tree.def-use.simplified
+compiler.tree.late-optimizations ;
+IN: compiler.tree.modular-arithmetic
+
+! This is a late-stage optimization.
+! See the comment in compiler.tree.late-optimizations.
+
+! Modular arithmetic optimization pass.
+!
+! { integer integer } declare + >fixnum
+! ==>
+! [ >fixnum ] bi@ fixnum+fast
+
+{ + - * bitand bitor bitxor } [
+ [
+ t "modular-arithmetic" set-word-prop
+ ] each-integer-derived-op
+] each
+
+{ bitand bitor bitxor bitnot }
+[ t "modular-arithmetic" set-word-prop ] each
+
+SYMBOL: modularize-values
+
+: modular-value? ( value -- ? )
+ modularize-values get key? ;
+
+: modularize-value ( value -- ) modularize-values get conjoin ;
+
+GENERIC: maybe-modularize* ( value node -- )
+
+: maybe-modularize ( value -- )
+ actually-defined-by [ value>> ] [ node>> ] bi
+ over actually-used-by length 1 = [
+ maybe-modularize*
+ ] [ 2drop ] if ;
+
+M: #call maybe-modularize*
+ dup word>> "modular-arithmetic" word-prop [
+ [ modularize-value ]
+ [ in-d>> [ maybe-modularize ] each ] bi*
+ ] [ 2drop ] if ;
+
+M: node maybe-modularize* 2drop ;
+
+GENERIC: compute-modularized-values* ( node -- )
+
+M: #call compute-modularized-values*
+ dup word>> {
+ { [ \ >fixnum eq? ] [ in-d>> first maybe-modularize ] }
+ ! { [
+ ! {
+ ! mod-integer-fixnum
+ ! mod-integer-integer
+ ! mod-fixnum-integer
+ ! } memq?
+ ! ] [ ] }
+ [ drop ]
+ } cond ;
+
+M: node compute-modularized-values* drop ;
+
+: compute-modularized-values ( nodes -- )
+ [ compute-modularized-values* ] each-node ;
+
+GENERIC: optimize-modular-arithmetic* ( node -- nodes )
+
+: redundant->fixnum? ( #call -- ? )
+ in-d>> first actually-defined-by value>> modular-value? ;
+
+: optimize->fixnum ( #call -- nodes )
+ dup redundant->fixnum? [ drop f ] when ;
+
+MEMO: fixnum-coercion ( flags -- nodes )
+ [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
+
+: optimize-modular-op ( #call -- nodes )
+ dup out-d>> first modular-value? [
+ [ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri
+ [
+ [
+ [ actually-defined-by value>> modular-value? ]
+ [ fixnum eq? ]
+ bi* or
+ ] 2map fixnum-coercion
+ ] [ [ modular-variant ] change-word ] bi* suffix
+ ] when ;
+
+M: #call optimize-modular-arithmetic*
+ dup word>> {
+ { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
+ { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
+ [ drop ]
+ } cond ;
+
+M: node optimize-modular-arithmetic* ;
+
+: optimize-modular-arithmetic ( nodes -- nodes' )
+ H{ } clone modularize-values set
+ dup compute-modularized-values
+ [ optimize-modular-arithmetic* ] map-nodes ;
diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor
index 3196253d45..e37323a2ec 100644
--- a/basis/compiler/tree/optimizer/optimizer.factor
+++ b/basis/compiler/tree/optimizer/optimizer.factor
@@ -10,7 +10,7 @@ compiler.tree.tuple-unboxing
compiler.tree.identities
compiler.tree.def-use
compiler.tree.dead-code
-compiler.tree.strength-reduction
+compiler.tree.modular-arithmetic
compiler.tree.finalization
compiler.tree.checker ;
IN: compiler.tree.optimizer
@@ -27,9 +27,10 @@ SYMBOL: check-optimizer?
apply-identities
compute-def-use
remove-dead-code
- ! strength-reduce
check-optimizer? get [
compute-def-use
dup check-nodes
] when
+ compute-def-use
+ optimize-modular-arithmetic
finalize ;
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 48864d8782..197d1820bf 100644
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -3,7 +3,7 @@
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
-words namespaces
+words namespaces continuations
compiler.tree
compiler.tree.builder
compiler.tree.recursive
@@ -33,7 +33,7 @@ M: quotation splicing-nodes
body>> (propagate) ;
! Dispatch elimination
-: eliminate-dispatch ( #call class/f word/f -- ? )
+: eliminate-dispatch ( #call class/f word/quot/f -- ? )
dup [
[ >>class ] dip
over method>> over = [ drop ] [
@@ -156,12 +156,19 @@ SYMBOL: history
: always-inline-word? ( word -- ? )
{ curry compose } memq? ;
+: custom-inlining? ( word -- ? )
+ "custom-inlining" word-prop ;
+
+: inline-custom ( #call word -- ? )
+ [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
+ first object swap eliminate-dispatch ;
+
: do-inlining ( #call word -- ? )
{
+ { [ dup custom-inlining? ] [ inline-custom ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
- { [ dup math-partial? ] [ inline-math-partial ] }
{ [ dup method-body? ] [ inline-method-body ] }
[ 2drop f ]
} cond ;
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index d208d31389..9f208bdc12 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -230,6 +230,32 @@ generic-comparison-ops [
] "outputs" set-word-prop
] assoc-each
+{
+ mod-integer-integer
+ mod-integer-fixnum
+ mod-fixnum-integer
+ fixnum-mod
+ rem
+} [
+ [
+ in-d>> second value-info >literal<
+ [ power-of-2? [ 1- bitand ] f ? ] when
+ ] "custom-inlining" set-word-prop
+] each
+
+{
+ bitand-integer-integer
+ bitand-integer-fixnum
+ bitand-fixnum-integer
+} [
+ [
+ in-d>> second value-info >literal< [
+ 0 most-positive-fixnum between?
+ [ [ >fixnum ] bi@ fixnum-bitand ] f ?
+ ] when
+ ] "custom-inlining" set-word-prop
+] each
+
{
alien-signed-1
alien-unsigned-1
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index a115ee53c2..6638951723 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -6,27 +6,12 @@ alien.accessors alien.c-types sequences.private
byte-arrays classes.algebra classes.tuple.private
math.functions math.private strings layouts
compiler.tree.propagation.info compiler.tree.def-use
-compiler.tree.checker slots.private words hashtables
-classes assocs ;
+compiler.tree.debugger compiler.tree.checker
+slots.private words hashtables classes assocs ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
-: final-info ( quot -- seq )
- build-tree
- analyze-recursive
- normalize
- propagate
- compute-def-use
- dup check-nodes
- peek node-input-infos ;
-
-: final-classes ( quot -- seq )
- final-info [ class>> ] map ;
-
-: final-literals ( quot -- seq )
- final-info [ literal>> ] map ;
-
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
@@ -594,6 +579,14 @@ MIXIN: empty-mixin
[ { float } declare 0 eq? ] final-classes
] unit-test
+[ V{ integer } ] [
+ [ { integer fixnum } declare mod ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+ [ { fixnum integer } declare bitand ] final-classes
+] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
diff --git a/basis/math/partial-dispatch/partial-dispatch-tests.factor b/basis/math/partial-dispatch/partial-dispatch-tests.factor
index 64605b1818..388b4127cd 100644
--- a/basis/math/partial-dispatch/partial-dispatch-tests.factor
+++ b/basis/math/partial-dispatch/partial-dispatch-tests.factor
@@ -1,5 +1,6 @@
IN: math.partial-dispatch.tests
-USING: math.partial-dispatch tools.test math kernel sequences ;
+USING: math.partial-dispatch math.private
+tools.test math kernel sequences ;
[ t ] [ \ + integer fixnum math-both-known? ] unit-test
[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
@@ -10,3 +11,17 @@ USING: math.partial-dispatch tools.test math kernel sequences ;
[ f ] [ \ number= fixnum object math-both-known? ] unit-test
[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
+
+[ { integer fixnum } ] [ \ +-integer-fixnum integer-op-input-classes ] unit-test
+[ { fixnum fixnum } ] [ \ fixnum+ integer-op-input-classes ] unit-test
+[ { fixnum fixnum } ] [ \ fixnum+fast integer-op-input-classes ] unit-test
+[ { integer } ] [ \ bitnot integer-op-input-classes ] unit-test
+
+[ shift ] [ \ fixnum-shift generic-variant ] unit-test
+[ fixnum-shift-fast ] [ \ fixnum-shift no-overflow-variant ] unit-test
+
+[ fixnum-shift-fast ] [ \ shift modular-variant ] unit-test
+[ fixnum-bitnot ] [ \ bitnot modular-variant ] unit-test
+[ fixnum+fast ] [ \ fixnum+ modular-variant ] unit-test
+[ fixnum+fast ] [ \ fixnum+fast modular-variant ] unit-test
+
diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor
index b162406e5a..61678eb088 100644
--- a/basis/math/partial-dispatch/partial-dispatch.factor
+++ b/basis/math/partial-dispatch/partial-dispatch.factor
@@ -6,13 +6,41 @@ generic generic.math hashtables effects compiler.units
classes.algebra ;
IN: math.partial-dispatch
-! Partial dispatch.
-
-! This code will be overhauled and generalized when
-! multi-methods go into the core.
PREDICATE: math-partial < word
"derived-from" word-prop >boolean ;
+GENERIC: integer-op-input-classes ( word -- classes )
+
+M: math-partial integer-op-input-classes
+ "derived-from" word-prop rest ;
+
+M: word integer-op-input-classes
+ "input-classes" word-prop
+ [ "Bug: integer-op-input-classes" throw ] unless* ;
+
+: generic-variant ( op -- generic-op/f )
+ dup "derived-from" word-prop [ first ] [ ] ?if ;
+
+: no-overflow-variant ( op -- fast-op )
+ H{
+ { fixnum+ fixnum+fast }
+ { fixnum- fixnum-fast }
+ { fixnum* fixnum*fast }
+ { fixnum-shift fixnum-shift-fast }
+ } at ;
+
+: modular-variant ( op -- fast-op )
+ generic-variant dup H{
+ { + fixnum+fast }
+ { - fixnum-fast }
+ { * fixnum*fast }
+ { shift fixnum-shift-fast }
+ { bitand fixnum-bitand }
+ { bitor fixnum-bitor }
+ { bitxor fixnum-bitxor }
+ { bitnot fixnum-bitnot }
+ } at swap or ;
+
:: fixnum-integer-op ( a b fix-word big-word -- c )
b tag 0 eq? [
a b fix-word execute
@@ -69,10 +97,17 @@ PREDICATE: math-partial < word
} swap [ prefix ] curry map ;
: define-integer-ops ( word fix-word big-word -- )
- >r >r integer-op-triples r> r>
- [ define-integer-op-words ]
- [ 2drop [ dup integer-op-word ] { } map>assoc % ]
- 3bi ;
+ [
+ rot tuck
+ [ fixnum fixnum 3array "derived-from" set-word-prop ]
+ [ bignum bignum 3array "derived-from" set-word-prop ]
+ 2bi*
+ ] [
+ [ integer-op-triples ] 2dip
+ [ define-integer-op-words ]
+ [ 2drop [ dup integer-op-word ] { } map>assoc % ]
+ 3bi
+ ] 3bi ;
: define-math-ops ( op -- )
{ fixnum bignum float }
@@ -125,6 +160,9 @@ SYMBOL: fast-math-ops
: each-fast-derived-op ( word quot -- )
>r fast-derived-ops r> each ; inline
+: each-integer-derived-op ( word quot -- )
+ >r integer-derived-ops r> each ; inline
+
[
[
\ + define-math-ops
From 379566374cd568810d33a39dc947dad5a80ae478 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 12 Sep 2008 18:15:22 -0500
Subject: [PATCH 03/16] Fix usages of nths
---
extra/math/combinatorics/combinatorics.factor | 2 +-
extra/project-euler/186/186.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor
index 7c5d5ba4c0..a0c6df083b 100644
--- a/extra/math/combinatorics/combinatorics.factor
+++ b/extra/math/combinatorics/combinatorics.factor
@@ -39,7 +39,7 @@ PRIVATE>
twiddle [ nPk ] keep factorial / ;
: permutation ( n seq -- seq )
- tuck permutation-indices nths ;
+ tuck permutation-indices swap nths ;
: all-permutations ( seq -- seq )
[
diff --git a/extra/project-euler/186/186.factor b/extra/project-euler/186/186.factor
index ac846f6064..5308662daf 100644
--- a/extra/project-euler/186/186.factor
+++ b/extra/project-euler/186/186.factor
@@ -9,7 +9,7 @@ IN: project-euler.186
55 [1,b] [ (generator) ] map <circular> ;
: advance ( lag -- )
- [ { 0 31 } nths sum 1000000 rem ] keep push-circular ;
+ [ { 0 31 } swap nths sum 1000000 rem ] keep push-circular ;
: next ( lag -- n )
[ first ] [ advance ] bi ;
From f2eeeb4ae80e5686a80f0ce260a2d61059c53b55 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 12 Sep 2008 18:15:26 -0500
Subject: [PATCH 04/16] Cleanup
---
extra/benchmark/spectral-norm/spectral-norm.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor
index 6d4d42116c..3c20a1ceff 100644
--- a/extra/benchmark/spectral-norm/spectral-norm.factor
+++ b/extra/benchmark/spectral-norm/spectral-norm.factor
@@ -41,7 +41,7 @@ IN: benchmark.spectral-norm
] times ; inline
: spectral-norm ( n -- norm )
- u/v [ v. ] keep norm-sq /f sqrt ;
+ u/v [ v. ] [ norm-sq ] bi /f sqrt ;
HINTS: spectral-norm fixnum ;
From 20cc730501312cdc9da64cfd61066edc26d39943 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 12 Sep 2008 18:57:34 -0500
Subject: [PATCH 05/16] Fix sequences tests
---
core/sequences/sequences-tests.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index f8765bc946..e27f2410b3 100755
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -250,11 +250,11 @@ unit-test
[ 50 ] [ 100 [ even? ] count ] unit-test
[ 50 ] [ 100 [ odd? ] count ] unit-test
-[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } nths ] unit-test
-[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } nths ] unit-test
-[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } nths ] unit-test
-[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } nths ] unit-test
-
+[ { "b" "d" } ] [ { 1 3 } { "a" "b" "c" "d" } nths ] unit-test
+[ { "a" "b" "c" "d" } ] [ { 0 1 2 3 } { "a" "b" "c" "d" } nths ] unit-test
+[ { "d" "c" "b" "a" } ] [ { 3 2 1 0 } { "a" "b" "c" "d" } nths ] unit-test
+[ { "d" "a" "b" "c" } ] [ { 3 0 1 2 } { "a" "b" "c" "d" } nths ] unit-test
+
TUPLE: bogus-hashcode ;
M: bogus-hashcode hashcode* 2drop 0 >bignum ;
@@ -265,6 +265,6 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
[ { 1 3 7 } ] [ 2 { 1 3 5 7 } remove-nth ] unit-test
-[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ]
+[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test
[ V{ 0 2 } ] [ "a" { "a" "b" "a" } indices ] unit-test
From dab32f7abe9342a3cb4d435fb187da33ef8b9542 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 12 Sep 2008 21:56:25 -0500
Subject: [PATCH 06/16] unbreak regexp2 for fry change, use dip some, pprint*,
make \^ and \$ parse
---
unfinished/regexp2/backend/backend.factor | 1 -
unfinished/regexp2/dfa/dfa.factor | 2 +-
unfinished/regexp2/parser/parser.factor | 2 ++
unfinished/regexp2/regexp2-tests.factor | 2 ++
unfinished/regexp2/regexp2.factor | 31 ++++++++++++++++++-
unfinished/regexp2/traversal/traversal.factor | 4 ++-
unfinished/regexp2/utils/utils.factor | 2 +-
7 files changed, 39 insertions(+), 5 deletions(-)
diff --git a/unfinished/regexp2/backend/backend.factor b/unfinished/regexp2/backend/backend.factor
index 81ffb334bd..fa5c1f7f97 100644
--- a/unfinished/regexp2/backend/backend.factor
+++ b/unfinished/regexp2/backend/backend.factor
@@ -21,7 +21,6 @@ TUPLE: regexp
0 >>state
V{ } clone >>stack
V{ } clone >>new-states
- H{ } clone >>options
H{ } clone >>visited-states ;
SYMBOL: current-regexp
diff --git a/unfinished/regexp2/dfa/dfa.factor b/unfinished/regexp2/dfa/dfa.factor
index 468ffa73e5..cd2f4186f4 100644
--- a/unfinished/regexp2/dfa/dfa.factor
+++ b/unfinished/regexp2/dfa/dfa.factor
@@ -15,7 +15,7 @@ IN: regexp2.dfa
eps swap find-delta ;
: find-epsilon-closure ( states regexp -- new-states )
- '[ dup , (find-epsilon-closure) union ] [ length ] while-changes
+ '[ dup _ (find-epsilon-closure) union ] [ length ] while-changes
natural-sort ;
: find-closure ( states transition regexp -- new-states )
diff --git a/unfinished/regexp2/parser/parser.factor b/unfinished/regexp2/parser/parser.factor
index 206db3883d..a970f82aab 100644
--- a/unfinished/regexp2/parser/parser.factor
+++ b/unfinished/regexp2/parser/parser.factor
@@ -291,6 +291,8 @@ ERROR: bad-escaped-literals seq ;
{ CHAR: f [ HEX: c <constant> ] }
{ CHAR: a [ HEX: 7 <constant> ] }
{ CHAR: e [ HEX: 1b <constant> ] }
+ { CHAR: $ [ CHAR: $ <constant> ] }
+ { CHAR: ^ [ CHAR: ^ <constant> ] }
{ CHAR: d [ digit-class ] }
{ CHAR: D [ digit-class <negation> ] }
diff --git a/unfinished/regexp2/regexp2-tests.factor b/unfinished/regexp2/regexp2-tests.factor
index 88bbc5f56c..f691c2becf 100644
--- a/unfinished/regexp2/regexp2-tests.factor
+++ b/unfinished/regexp2/regexp2-tests.factor
@@ -222,6 +222,8 @@ IN: regexp2-tests
<regexp> drop
] unit-test
+[ ] [ "(\\$[\\p{XDigit}]|[\\p{Digit}])" <regexp> drop ] unit-test
+
! Comment
[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
diff --git a/unfinished/regexp2/regexp2.factor b/unfinished/regexp2/regexp2.factor
index 24221baeb6..feec8ea97e 100644
--- a/unfinished/regexp2/regexp2.factor
+++ b/unfinished/regexp2/regexp2.factor
@@ -3,7 +3,8 @@
USING: accessors combinators kernel math math.ranges
sequences regexp2.backend regexp2.utils memoize sets
regexp2.parser regexp2.nfa regexp2.dfa regexp2.traversal
-regexp2.transition-tables ;
+regexp2.transition-tables assocs prettyprint.backend
+make ;
IN: regexp2
: default-regexp ( string -- regexp )
@@ -14,6 +15,7 @@ IN: regexp2
<transition-table> >>minimized-table
H{ } clone >>nfa-traversal-flags
H{ } clone >>dfa-traversal-flags
+ H{ } clone >>options
reset-regexp ;
: construct-regexp ( regexp -- regexp' )
@@ -60,3 +62,30 @@ IN: regexp2
: R` CHAR: ` <regexp> ; parsing
: R{ CHAR: } <regexp> ; parsing
: R| CHAR: | <regexp> ; parsing
+
+: find-regexp-syntax ( string -- prefix suffix )
+ {
+ { "R/ " "/" }
+ { "R! " "!" }
+ { "R\" " "\"" }
+ { "R# " "#" }
+ { "R' " "'" }
+ { "R( " ")" }
+ { "R@ " "@" }
+ { "R[ " "]" }
+ { "R` " "`" }
+ { "R{ " "}" }
+ { "R| " "|" }
+ } swap [ subseq? not nip ] curry assoc-find drop ;
+
+: option? ( option regexp -- ? )
+ options>> key? ;
+
+M: regexp pprint*
+ [
+ [
+ dup raw>>
+ dup find-regexp-syntax swap % swap % %
+ case-insensitive swap option? [ "i" % ] when
+ ] "" make
+ ] keep present-text ;
diff --git a/unfinished/regexp2/traversal/traversal.factor b/unfinished/regexp2/traversal/traversal.factor
index 0bc304bfe0..ba9284c110 100644
--- a/unfinished/regexp2/traversal/traversal.factor
+++ b/unfinished/regexp2/traversal/traversal.factor
@@ -45,7 +45,9 @@ TUPLE: dfa-traverser
] when text-finished? ;
: increment-state ( dfa-traverser state -- dfa-traverser )
- >r [ 1+ ] change-current-index dup current-state>> >>last-state r>
+ [
+ [ 1+ ] change-current-index dup current-state>> >>last-state
+ ] dip
first >>current-state ;
: match-failed ( dfa-traverser -- dfa-traverser )
diff --git a/unfinished/regexp2/utils/utils.factor b/unfinished/regexp2/utils/utils.factor
index 48c68d883f..ab51436f8b 100644
--- a/unfinished/regexp2/utils/utils.factor
+++ b/unfinished/regexp2/utils/utils.factor
@@ -9,7 +9,7 @@ IN: regexp2.utils
: (while-changes) ( obj quot pred pred-ret -- obj )
! quot: ( obj -- obj' )
! pred: ( obj -- <=> )
- >r >r dup slip r> pick over call r> dupd =
+ [ [ dup slip ] dip pick over call ] dip dupd =
[ 3drop ] [ (while-changes) ] if ; inline recursive
: while-changes ( obj quot pred -- obj' )
From 7f832de824b131c06a1400baa94b3bb75971c5d7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 12 Sep 2008 22:04:35 -0500
Subject: [PATCH 07/16] fix help-lint
---
basis/mime-types/mime-types-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/mime-types/mime-types-docs.factor b/basis/mime-types/mime-types-docs.factor
index 058a71d838..b7fa46d587 100644
--- a/basis/mime-types/mime-types-docs.factor
+++ b/basis/mime-types/mime-types-docs.factor
@@ -11,7 +11,7 @@ HELP: mime-db
HELP: mime-type
{ $values
- { "path" "a pathname string" }
+ { "filename" "a filename" }
{ "mime-type" "a MIME type string" } }
{ $description "Outputs the MIME type associtated with a path by parsing the path's file extension and looking it up in the table returned by " { $link mime-types } "." } ;
From 7ba28ac8d5c45a638cd8027097e476e99c998d98 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 02:37:16 -0500
Subject: [PATCH 08/16] Clean up raytracer a bit
---
extra/benchmark/raytracer/raytracer.factor | 60 +++++++++++-----------
1 file changed, 31 insertions(+), 29 deletions(-)
diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor
index 69454505a5..34bac61292 100755
--- a/extra/benchmark/raytracer/raytracer.factor
+++ b/extra/benchmark/raytracer/raytracer.factor
@@ -3,7 +3,7 @@
USING: arrays accessors float-arrays io io.files
io.encodings.binary kernel math math.functions math.vectors
-math.parser make sequences sequences.private words ;
+math.parser make sequences sequences.private words hints ;
IN: benchmark.raytracer
! parameters
@@ -38,34 +38,40 @@ TUPLE: sphere { center float-array read-only } { radius float read-only } ;
C: <sphere> sphere
: sphere-v ( sphere ray -- v )
- swap center>> swap orig>> v- ; inline
+ [ center>> ] [ orig>> ] bi* v- ; inline
-: sphere-b ( ray v -- b ) swap dir>> v. ; inline
+: sphere-b ( v ray -- b )
+ dir>> v. ; inline
-: sphere-disc ( sphere v b -- d )
- sq swap norm-sq - swap radius>> sq + ; inline
+: sphere-d ( sphere b v -- d )
+ [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline
-: -+ ( x y -- x-y x+y ) [ - ] 2keep + ; inline
+: -+ ( x y -- x-y x+y )
+ [ - ] [ + ] 2bi ; inline
-: sphere-b/d ( b d -- t )
+: sphere-t ( b d -- t )
-+ dup 0.0 <
[ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
-: ray-sphere ( sphere ray -- t )
- 2dup sphere-v tuck sphere-b [ sphere-disc ] keep
- over 0.0 < [ 2drop 1.0/0.0 ] [ swap sqrt sphere-b/d ] if ;
- inline
+: sphere-b&v ( sphere ray -- b v )
+ [ sphere-v ] [ nip ] 2bi
+ [ sphere-b ] [ drop ] 2bi ; inline
-: sphere-n ( ray sphere l -- n )
- pick dir>> n*v swap center>> v- swap orig>> v+ ;
- inline
+: ray-sphere ( sphere ray -- t )
+ [ drop ] [ sphere-b&v ] 2bi
+ [ drop ] [ sphere-d ] 3bi
+ dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline
: if-ray-sphere ( hit ray sphere quot -- hit )
#! quot: hit ray sphere l -- hit
[
- pick lambda>> [ 2dup swap ray-sphere dup ] dip >=
- [ 3drop ]
- ] dip if ; inline
+ [ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri
+ [ drop ] [ < ] 2bi
+ ] dip [ 3drop ] if ; inline
+
+: sphere-n ( ray sphere l -- n )
+ [ [ orig>> ] [ dir>> ] bi ] [ center>> ] [ ] tri*
+ swap [ v*n ] dip v- v+ ; inline
M: sphere intersect-scene ( hit ray sphere -- hit )
[ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
@@ -79,21 +85,17 @@ TUPLE: group < sphere { objs array read-only } ;
swap [ { } make ] dip <group> ; inline
M: group intersect-scene ( hit ray group -- hit )
- [
- drop
- objs>> [ [ tuck ] dip intersect-scene swap ] each
- drop
- ] if-ray-sphere ;
+ [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
-: initial-hit T{ hit f F{ 0.0 0.0 0.0 } 1.0/0.0 } ; inline
+: initial-hit T{ hit f F{ 0.0 0.0 0.0 } 1/0. } ; inline
: initial-intersect ( ray scene -- hit )
- initial-hit -rot intersect-scene ; inline
+ [ initial-hit ] 2dip intersect-scene ; inline
: ray-o ( ray hit -- o )
- over dir>> over lambda>> v*n
- swap normal>> delta v*n v+
- swap orig>> v+ ; inline
+ [ [ orig>> ] [ normal>> delta v*n ] bi* ]
+ [ [ dir>> ] [ lambda>> ] bi* v*n ]
+ 2bi v+ v+ ; inline
: sray-intersect ( ray scene hit -- ray )
swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline
@@ -101,10 +103,10 @@ M: group intersect-scene ( hit ray group -- hit )
: ray-g ( hit -- g ) normal>> light v. ; inline
: cast-ray ( ray scene -- g )
- 2dup initial-intersect dup lambda>> 1.0/0.0 = [
+ 2dup initial-intersect dup lambda>> 1/0. = [
3drop 0.0
] [
- [ sray-intersect lambda>> 1.0/0.0 = ] keep swap
+ [ sray-intersect lambda>> 1/0. = ] keep swap
[ ray-g neg ] [ drop 0.0 ] if
] if ; inline
From 2cc40052bfeffb82a31f76a005ace9c6e3e6249d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 03:06:36 -0500
Subject: [PATCH 09/16] Rewrite locals-in-literals in idiomatic Factor, and fix
a performance regression with locals in tuples
---
basis/locals/locals-tests.factor | 4 +-
basis/locals/locals.factor | 93 +++++++++++---------------------
2 files changed, 35 insertions(+), 62 deletions(-)
diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor
index 59ec325f39..eb06d05146 100755
--- a/basis/locals/locals-tests.factor
+++ b/basis/locals/locals-tests.factor
@@ -329,4 +329,6 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
[ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
[ T{ slice f 0 3 "abc" } ]
-[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test
\ No newline at end of file
+[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test
+
+{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
\ No newline at end of file
diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
index bfc92ee9e2..05ea3cb524 100755
--- a/basis/locals/locals.factor
+++ b/basis/locals/locals.factor
@@ -6,7 +6,7 @@ quotations debugger macros arrays macros splitting combinators
prettyprint.backend definitions prettyprint hashtables
prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors
-locals.backend memoize macros.expander lexer
+locals.backend memoize macros.expander lexer classes
stack-checker.known-words ;
IN: locals
@@ -195,70 +195,41 @@ M: block lambda-rewrite*
swap point-free ,
] keep length \ curry <repetition> % ;
+GENERIC: rewrite-element ( obj -- )
+
+: rewrite-elements ( seq -- )
+ [ rewrite-element ] each ;
+
+: rewrite-sequence ( seq -- )
+ [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
+
+M: array rewrite-element rewrite-sequence ;
+
+M: vector rewrite-element rewrite-sequence ;
+
+M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
+
+M: tuple rewrite-element
+ [ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ;
+
+M: local rewrite-element , ;
+
+M: word rewrite-element literalize , ;
+
+M: object rewrite-element , ;
+
+M: array local-rewrite* rewrite-element ;
+
+M: vector local-rewrite* rewrite-element ;
+
+M: tuple local-rewrite* rewrite-element ;
+
+M: hashtable local-rewrite* rewrite-element ;
+
M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Broil is used to support locals in literals
-
-DEFER: [broil]
-DEFER: [broil-hashtable]
-DEFER: [broil-tuple]
-
-: broil-element ( obj -- quot )
- {
- { [ dup number? ] [ 1quotation ] }
- { [ dup string? ] [ 1quotation ] }
- { [ dup sequence? ] [ [broil] ] }
- { [ dup hashtable? ] [ [broil-hashtable] ] }
- { [ dup tuple? ] [ [broil-tuple] ] }
- { [ dup local? ] [ 1quotation ] }
- { [ dup word? ] [ literalize 1quotation ] }
- { [ t ] [ 1quotation ] }
- }
- cond ;
-
-: [broil] ( seq -- quot )
- [ [ broil-element ] map concat >quotation ]
- [ length ]
- [ ]
- tri
- [ nsequence ] curry curry compose ;
-
-MACRO: broil ( seq -- quot ) [broil] ;
-
-: [broil-hashtable] ( hashtable -- quot )
- >alist
- [ [ broil-element ] map concat >quotation ]
- [ length ]
- [ ]
- tri
- [ nsequence >hashtable ] curry curry compose ;
-
-MACRO: broil-hashtable ( hashtable -- quot ) [broil-hashtable] ;
-
-: [broil-tuple] ( tuple -- quot )
- tuple>array
- [ [ broil-element ] map concat >quotation ]
- [ length ]
- [ ]
- tri
- [ nsequence >tuple ] curry curry compose ;
-
-MACRO: broil-tuple ( tuple -- quot ) [broil-tuple] ;
-
-! Engage broil on arrays and vectors. Can't do it on 'sequence'
-! because that will pick up strings and integers. What do do...
-
-M: array local-rewrite* ( array -- ) [broil] % ;
-M: vector local-rewrite* ( vector -- ) [broil] % ;
-M: tuple local-rewrite* ( tuple -- ) [broil-tuple] % ;
-M: hashtable local-rewrite* ( hashtable -- ) [broil-hashtable] % ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: make-local ( name -- word )
"!" ?tail [
<local-reader>
From 01129fb9bd9ad598bc2889125edb7d2ff681f230 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 03:09:16 -0500
Subject: [PATCH 10/16] Add unit test for locals performance regresion
---
basis/compiler/tree/propagation/propagation-tests.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 6638951723..d73e8b7db1 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -7,7 +7,8 @@ byte-arrays classes.algebra classes.tuple.private
math.functions math.private strings layouts
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
-slots.private words hashtables classes assocs ;
+slots.private words hashtables classes assocs locals
+float-arrays ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@@ -587,6 +588,8 @@ MIXIN: empty-mixin
[ { fixnum integer } declare bitand ] final-classes
] unit-test
+[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
From 87797847987eb8c2252e2b3dc3956e78125fd970 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 03:12:52 -0500
Subject: [PATCH 11/16] Support hints on methods
---
basis/hints/hints-docs.factor | 21 ++++++++++++++++++---
basis/hints/hints.factor | 5 +++--
2 files changed, 21 insertions(+), 5 deletions(-)
diff --git a/basis/hints/hints-docs.factor b/basis/hints/hints-docs.factor
index 99c4a2ddfc..347cfd3ef4 100644
--- a/basis/hints/hints-docs.factor
+++ b/basis/hints/hints-docs.factor
@@ -20,9 +20,24 @@ HELP: specialized-def
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
HELP: HINTS:
-{ $values { "word" word } { "hints..." "a list of sequences of classes" } }
-{ $description "Defines specialization hints for each words. Each sequence of classes in the list will cause a specialized version of the word to be compiled." }
+{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes" } }
+{ $description "Defines specialization hints for a word or a method."
+$nl
+"Each sequence of classes in the list will cause a specialized version of the word to be compiled." }
{ $examples "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
-{ $code "HINTS: append { string string } { array array } ;" } } ;
+{ $code "HINTS: append { string string } { array array } ;" }
+"Specializers can also be defined on methods:"
+{ $code
+ "GENERIC: count-occurrences ( elt obj -- n )"
+ ""
+ "M: sequence count-occurrences [ = ] with count ;"
+ ""
+ "M: assoc count-occurrences"
+ " swap [ = nip ] curry assoc-filter assoc-size ;"
+ ""
+ "HINTS: { sequence count-occurrences } { object array } ;"
+ "HINTS: { assoc count-occurrences } { object hashtable } ;"
+}
+} ;
ABOUT: "hints"
diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index 1138ad872a..a10588d730 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -42,11 +42,11 @@ IN: hints
: specialized-def ( word -- quot )
dup def>> swap {
- { [ dup standard-method? ] [ specialize-method ] }
{
[ dup "specializer" word-prop ]
[ "specializer" word-prop specialize-quot ]
}
+ { [ dup standard-method? ] [ specialize-method ] }
[ drop ]
} cond ;
@@ -54,7 +54,8 @@ IN: hints
dup [ array? ] all? [ first ] when length ;
: HINTS:
- scan-word
+ scan-object
+ dup method-spec? [ first2 method ] when
[ redefined ]
[ parse-definition "specializer" set-word-prop ] bi ;
parsing
From d2646cfe1bc7cba51179131d17adc399c47e6462 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 13 Sep 2008 04:09:13 -0500
Subject: [PATCH 12/16] tools.annotations: Use fry in '(watch)'
---
basis/tools/annotations/annotations.factor | 7 ++-----
1 file changed, 2 insertions(+), 5 deletions(-)
diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
index 96c2ec2fcc..6a7e33e615 100755
--- a/basis/tools/annotations/annotations.factor
+++ b/basis/tools/annotations/annotations.factor
@@ -3,7 +3,7 @@
USING: accessors kernel words parser io summary quotations
sequences prettyprint continuations effects definitions
compiler.units namespaces assocs tools.walker generic
-inspector ;
+inspector fry ;
IN: tools.annotations
GENERIC: reset ( word -- )
@@ -49,10 +49,7 @@ M: word reset
.s
] if* "\\--" print flush ;
-: (watch) ( word def -- def )
- over [ entering ] curry
- rot [ leaving ] curry
- swapd 3append ;
+: (watch) ( word def -- def ) over '[ _ entering @ _ leaving ] ;
: watch ( word -- )
dup [ (watch) ] annotate ;
From a211e44bb9264a9e345c132541c462251c6fb5ea Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 04:43:29 -0500
Subject: [PATCH 13/16] Found a place to use the locals in literals feature
---
basis/compiler/tree/dead-code/recursive/recursive.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor
index 03d4e919ee..02dc42f058 100644
--- a/basis/compiler/tree/dead-code/recursive/recursive.factor
+++ b/basis/compiler/tree/dead-code/recursive/recursive.factor
@@ -84,7 +84,7 @@ M:: #recursive remove-dead-code* ( node -- nodes )
drop-outputs [ node drop-recursive-outputs ] |
node [ (remove-dead-code) ] change-child drop
node label>> [ filter-live ] change-enter-out drop
- drop-inputs node drop-outputs 3array
+ { drop-inputs node drop-outputs }
] ;
M: #return-recursive remove-dead-code* ;
From d47a76b69bc9881f74602d75baf6eb15e6f5eebc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 06:13:49 -0500
Subject: [PATCH 14/16] 15% improvement
---
extra/benchmark/spectral-norm/spectral-norm.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor
index 3c20a1ceff..245027ef77 100644
--- a/extra/benchmark/spectral-norm/spectral-norm.factor
+++ b/extra/benchmark/spectral-norm/spectral-norm.factor
@@ -32,8 +32,10 @@ IN: benchmark.spectral-norm
: eval-AtA-times-u ( u n -- seq )
[ eval-A-times-u ] [ eval-At-times-u ] bi ; inline
+: ones ( n -- seq ) [ 1.0 ] F{ } replicate-as ; inline
+
:: u/v ( n -- u v )
- n 1.0 <repetition> >float-array dup
+ n ones dup
10 [
drop
n eval-AtA-times-u
From 1bf65e6dc5a91fd8bd2fa3ca22c5af53f5ea32f1 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 13 Sep 2008 11:12:36 -0500
Subject: [PATCH 15/16] tools.annotations: Use fry in '(watch-vars)'
---
basis/tools/annotations/annotations.factor | 11 ++++++-----
1 file changed, 6 insertions(+), 5 deletions(-)
diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
index 6a7e33e615..c836bfc2b6 100755
--- a/basis/tools/annotations/annotations.factor
+++ b/basis/tools/annotations/annotations.factor
@@ -55,11 +55,12 @@ M: word reset
dup [ (watch) ] annotate ;
: (watch-vars) ( quot word vars -- newquot )
- [
- "--- Entering: " write swap .
- "--- Variable values:" print
- [ dup get ] H{ } map>assoc describe
- ] 2curry prepose ;
+ rot
+ '[
+ "--- Entering: " write _ .
+ "--- Variable values:" print _ [ dup get ] H{ } map>assoc describe
+ @
+ ] ;
: watch-vars ( word vars -- )
dupd [ (watch-vars) ] 2curry annotate ;
From 8b9784108e5d8b7d50fc0104ab745652b1cc1b37 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 14:25:06 -0500
Subject: [PATCH 16/16] Don't clobber RBX
---
basis/cpu/x86/32/32.factor | 4 ----
basis/cpu/x86/64/64.factor | 15 +++++----------
basis/cpu/x86/architecture/architecture.factor | 2 --
3 files changed, 5 insertions(+), 16 deletions(-)
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 67a8ec8a2c..5328f2a263 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -62,10 +62,6 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
: with-aligned-stack ( n quot -- )
swap dup align-sub slip align-add ; inline
-! On x86, we can always use an address as an operand
-! directly.
-M: x86.32 address-operand ;
-
M: x86.32 fixnum>slot@ 1 SHR ;
M: x86.32 prepare-division CDQ ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 4770c09a83..c135d0490d 100755
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -33,13 +33,6 @@ M: float-regs vregs
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-M: x86.64 address-operand ( address -- operand )
- #! On AMD64, we have to load 64-bit addresses into a
- #! scratch register first. The usage of R11 here is a hack.
- #! This word can only be called right before a subroutine
- #! call, where all vregs have been flushed anyway.
- temp-reg v>operand [ swap MOV ] keep ;
-
M: x86.64 fixnum>slot@ drop ;
M: x86.64 prepare-division CQO ;
@@ -49,8 +42,8 @@ M: x86.64 load-indirect ( literal reg -- )
M: stack-params %load-param-reg
drop
- >r temp-reg v>operand swap stack@ MOV
- r> stack@ temp-reg v>operand MOV ;
+ >r R11 swap stack@ MOV
+ r> stack@ R11 MOV ;
M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-param-reg ;
@@ -138,7 +131,9 @@ M: x86.64 %alien-global
[ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
M: x86.64 %alien-invoke
- 0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
+ R11 0 MOV
+ rc-absolute-cell rel-dlsym
+ R11 CALL ;
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 171e67bcfb..04b496f12a 100755
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -39,8 +39,6 @@ GENERIC: store-return-reg ( stack@ reg-class -- )
HOOK: temp-reg-1 cpu ( -- reg )
HOOK: temp-reg-2 cpu ( -- reg )
-HOOK: address-operand cpu ( address -- operand )
-
HOOK: fixnum>slot@ cpu ( op -- )
HOOK: prepare-division cpu ( -- )