Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
ea621cd888
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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<= ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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* ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -6,27 +6,13 @@ 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 locals
|
||||
float-arrays ;
|
||||
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 +580,16 @@ 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{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
|
||||
|
||||
! [ V{ string } ] [
|
||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||
! ] unit-test
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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' ) ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ 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
|
||||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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,20 +49,18 @@ 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 ;
|
||||
|
||||
: (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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -41,7 +43,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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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> ] }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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' )
|
||||
|
|
|
|||
Loading…
Reference in New Issue