steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of factorcode.org:/git/factor

db4
Eduardo Cavazos 2008-04-19 14:14:33 -05:00
parent 827d0653a5 7faa9a8312
commit 17dd323941
47 changed files with 1059 additions and 502 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/alien/compiler/compiler-tests.factor
View File

@ -280,6 +280,10 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ;

44
core/classes/algebra/algebra-tests.factor
View File

@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects kernel.private ;
random inference effects kernel.private sbufs ;
: class= [ class< ] 2keep swap class< and ;
@ -144,6 +144,48 @@ UNION: z1 b1 c1 ;
[ f ] [ null class-not null class= ] unit-test
[ t ] [
fixnum class-not
fixnum fixnum class-not class-or
class<
] unit-test
! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test
[ string ] [
\ string
[ integer string array reversed sbuf
slice vector quotation ]
sort-classes min-class
] unit-test
[ fixnum ] [
\ fixnum
[ fixnum integer object ]
sort-classes min-class
] unit-test
[ integer ] [
\ fixnum
[ integer float object ]
sort-classes min-class
] unit-test
[ object ] [
\ word
[ integer float object ]
sort-classes min-class
] unit-test
[ reversed ] [
\ reversed
[ integer reversed slice ]
sort-classes min-class
] unit-test
[ f ] [ null { number fixnum null } min-class ] unit-test
! Test for hangs?
: random-class classes random ;

7
core/classes/algebra/algebra.factor
View File

@ -77,10 +77,10 @@ C: <anonymous-complement> anonymous-complement
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
{ [ over anonymous-union? ] [ left-anonymous-union< ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ over members ] [ left-union-class< ] }
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ dup members ] [ right-union-class< ] }
{ [ over superclass ] [ superclass< ] }
@ -193,9 +193,8 @@ C: <anonymous-complement> anonymous-complement
[ ] unfold nip ;
: min-class ( class seq -- class/f )
[ dupd classes-intersect? ] subset dup empty? [
2drop f
] [
over [ classes-intersect? ] curry subset
dup empty? [ 2drop f ] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;

3
core/cpu/architecture/architecture.factor
View File

@ -187,6 +187,9 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src -- )
! GC check
HOOK: %gc cpu
: operand ( var -- op ) get v>operand ; inline
: unique-operands ( operands quot -- )

15
core/cpu/ppc/allot/allot.factor
View File

@ -7,7 +7,7 @@ cpu.architecture alien ;
IN: cpu.ppc.allot
: load-zone-ptr ( reg -- )
"nursery" f pick %load-dlsym dup 0 LWZ ;
"nursery" f pick %load-dlsym ;
: %allot ( header size -- )
#! Store a pointer to 'size' bytes allocated from the
@ -25,6 +25,19 @@ IN: cpu.ppc.allot
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand 11 r> tag-number ORI ;
M: ppc %gc
"end" define-label
12 load-zone-ptr
11 12 cell LWZ ! nursery.here -> r11
12 12 3 cells LWZ ! nursery.end -> r12
11 12 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
0 11 12 CMPI ! is here >= end?
"end" get BLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: %allot-float ( reg -- )
#! exits with tagged ptr to object in r12, untagged in r11
float 16 %allot

2
core/cpu/x86/32/32.factor
View File

@ -17,6 +17,8 @@ M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 stack-save-reg EDX ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
M: temp-reg v>operand drop EBX ;

2
core/cpu/x86/64/64.factor
View File

@ -12,6 +12,8 @@ M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 stack-save-reg RSI ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
M: temp-reg v>operand drop RBX ;

19
core/cpu/x86/allot/allot.factor
View File

@ -16,12 +16,12 @@ IN: cpu.x86.allot
: object@ ( n -- operand ) cells (object@) ;
: load-zone-ptr ( -- )
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
"nursery" f allot-reg %alien-global ;
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
: load-allot-ptr ( -- )
load-zone-ptr
allot-reg load-zone-ptr
allot-reg PUSH
allot-reg dup cell [+] MOV ;
@ -29,6 +29,19 @@ IN: cpu.x86.allot
allot-reg POP
allot-reg cell [+] swap 8 align ADD ;
M: x86.32 %gc ( -- )
"end" define-label
temp-reg-1 load-zone-ptr
temp-reg-2 temp-reg-1 cell [+] MOV
temp-reg-2 1024 ADD
temp-reg-1 temp-reg-1 3 cells [+] MOV
temp-reg-2 temp-reg-1 CMP
"end" get JLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: store-header ( header -- )
0 object@ swap type-number tag-fixnum MOV ;

4
core/cpu/x86/architecture/architecture.factor
View File

@ -34,6 +34,10 @@ GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-return-reg ( stack@ reg-class -- )
! Only used by inline allocation
HOOK: temp-reg-1 cpu
HOOK: temp-reg-2 cpu
HOOK: address-operand cpu ( address -- operand )
HOOK: fixnum>slot@ cpu

5
core/generator/registers/registers.factor
View File

@ -468,11 +468,6 @@ M: loc lazy-store
: finalize-contents ( -- )
finalize-locs finalize-vregs reset-phantoms ;
: %gc ( -- )
0 frame-required
%prepare-alien-invoke
"simple_gc" f %alien-invoke ;
! Loading stacks to vregs
: free-vregs? ( int# float# -- ? )
double-float-regs free-vregs length <=

3
core/generic/generic.factor
View File

@ -29,6 +29,9 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
: specific-method ( class word -- class )
order min-class ;
GENERIC: effective-method ( ... generic -- method )
: next-method-class ( class generic -- class/f )

4
core/inference/backend/backend-docs.factor
View File

@ -48,10 +48,6 @@ HELP: no-effect
{ $description "Throws a " { $link no-effect } " error." }
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
HELP: collect-recursion
{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } }
{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ;
HELP: inline-word
{ $values { "word" word } }
{ $description "Called during inference to infer stack effects of inline words."

39
core/inference/backend/backend.factor
View File

@ -409,6 +409,25 @@ TUPLE: recursive-declare-error word ;
\ recursive-declare-error inference-error
] if* ;
GENERIC: collect-label-info* ( label node -- )
M: node collect-label-info* 2drop ;
: (collect-label-info) ( label node vector -- )
>r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ;
inline
M: #call-label collect-label-info*
over calls>> (collect-label-info) ;
M: #return collect-label-info*
over returns>> (collect-label-info) ;
: collect-label-info ( #label -- )
V{ } clone >>calls
V{ } clone >>returns
dup [ collect-label-info* ] with each-node ;
: nest-node ( -- ) #entry node, ;
: unnest-node ( new-node -- new-node )
@ -419,27 +438,17 @@ TUPLE: recursive-declare-error word ;
: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
: inline-block ( word -- node-block data )
: inline-block ( word -- #label data )
[
copy-inference nest-node
dup word-def swap <inlined-block>
[ infer-quot-recursive ] 2keep
#label unnest-node
dup collect-label-info
] H{ } make-assoc ;
GENERIC: collect-recursion* ( label node -- )
M: node collect-recursion* 2drop ;
M: #call-label collect-recursion*
tuck node-param eq? [ , ] [ drop ] if ;
: collect-recursion ( #label -- seq )
dup node-param
[ [ swap collect-recursion* ] curry each-node ] { } make ;
: join-values ( node -- )
collect-recursion [ node-in-d ] map meta-d get suffix
: join-values ( #label -- )
calls>> [ node-in-d ] map meta-d get suffix
unify-lengths unify-stacks
meta-d [ length tail* ] change ;
@ -460,7 +469,7 @@ M: #call-label collect-recursion*
drop join-values inline-block apply-infer
r> over set-node-in-d
dup node,
collect-recursion [
calls>> [
[ flatten-curries ] modify-values
] each
] [

283
core/inference/class/class-tests.factor
View File

@ -4,7 +4,12 @@ inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts vectors ;
system layouts vectors optimizer.math.partial accessors
optimizer.inlining ;
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
[ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@ -13,9 +18,15 @@ system layouts vectors ;
! Ensure type inference works as it is supposed to by checking
! if various methods get inlined
: inlined? ( quot word -- ? )
: inlined? ( quot seq/word -- ? )
dup word? [ 1array ] when
swap dataflow optimize
[ node-param eq? ] with node-exists? not ;
[ node-param swap member? ] with node-exists? not ;
[ f ] [
[ { integer } declare >fixnum ]
\ >fixnum inlined?
] unit-test
GENERIC: mynot ( x -- y )
@ -109,12 +120,17 @@ M: object xyz ;
[ { fixnum } declare [ ] times ] \ fixnum+ inlined?
] unit-test
[ f ] [
[ t ] [
[ { integer fixnum } declare dupd < [ 1 + ] when ]
\ + inlined?
] unit-test
[ f ] [ [ dup 0 < [ neg ] when ] \ neg inlined? ] unit-test
[ f ] [
[ { integer fixnum } declare dupd < [ 1 + ] when ]
\ +-integer-fixnum inlined?
] unit-test
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
[ f ] [
[
@ -137,13 +153,13 @@ M: object xyz ;
DEFER: blah
[ t ] [
[ ] [
[
\ blah
[ dup V{ } eq? [ foo ] when ] dup second dup push define
] with-compilation-unit
\ blah compiled?
\ blah word-def dataflow optimize drop
] unit-test
GENERIC: detect-fx ( n -- n )
@ -158,14 +174,20 @@ M: fixnum detect-fx ;
] \ detect-fx inlined?
] unit-test
[ t ] [
[
1000000000000000000000000000000000 [ ] times
] \ + inlined?
] unit-test
[ f ] [
[
1000000000000000000000000000000000 [ ] times
] \ 1+ inlined?
] \ +-integer-fixnum inlined?
] unit-test
[ f ] [
[ { bignum } declare [ ] times ] \ 1+ inlined?
[ { bignum } declare [ ] times ]
\ +-integer-fixnum inlined?
] unit-test
@ -251,19 +273,24 @@ M: float detect-float ;
[ 3 + = ] \ equal? inlined?
] unit-test
[ t ] [
[ f ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
\ shift inlined?
\ fixnum-shift-fast inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
\ fixnum-shift inlined?
{ shift fixnum-shift } inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
\ fixnum-shift inlined?
{ shift fixnum-shift } inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
{ fixnum-shift-fast } inlined?
] unit-test
cell-bits 32 = [
@ -278,6 +305,11 @@ cell-bits 32 = [
] unit-test
] when
[ f ] [
[ { integer } declare -63 shift 4095 bitand ]
\ shift inlined?
] unit-test
[ t ] [
[ B{ 1 0 } *short 0 number= ]
\ number= inlined?
@ -323,3 +355,228 @@ cell-bits 32 = [
] when
] \ + 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
[ t ] [
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test
: rec ( a -- b )
dup 0 > [ 1 - rec ] when ; inline
[ t ] [
[ { fixnum } declare rec 1 + ]
{ > - + } inlined?
] unit-test
: fib ( m -- n )
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline
[ t ] [
[ 27.0 fib ] { < - + } inlined?
] unit-test
[ f ] [
[ 27.0 fib ] { +-integer-integer } inlined?
] unit-test
[ t ] [
[ 27 fib ] { < - + } inlined?
] unit-test
[ t ] [
[ 27 >bignum fib ] { < - + } inlined?
] unit-test
[ f ] [
[ 27/2 fib ] { < - } inlined?
] unit-test
: hang-regression ( m n -- x )
over 0 number= [
nip
] [
dup [
drop 1 hang-regression
] [
dupd hang-regression hang-regression
] if
] if ; inline
[ t ] [
[ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
] { } inlined? ] unit-test
: detect-null ( a -- b ) dup drop ;
\ detect-null {
{ [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] }
} define-optimizers
[ t ] [
[ { null } declare detect-null ] \ detect-null inlined?
] unit-test
[ t ] [
[ { null null } declare + detect-null ] \ detect-null inlined?
] unit-test
[ f ] [
[ { null fixnum } declare + detect-null ] \ detect-null inlined?
] unit-test
GENERIC: detect-integer ( a -- b )
M: integer detect-integer ;
[ t ] [
[ { null fixnum } declare + detect-integer ] \ detect-integer inlined?
] unit-test
[ t ] [
[ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
] unit-test
[ f ] [
[ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
] unit-test
[ f ] [
[ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
\ fixnum-bitand 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 ] [
[ { fixnum } declare [ drop ] each-integer ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare length [ drop ] each-integer ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare [ drop ] each ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare 0 [ + ] reduce ]
{ < <-integer-fixnum } inlined?
] unit-test
[ f ] [
[ { fixnum } declare 0 [ + ] reduce ]
\ +-integer-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
[ f ] [
[
{ integer } declare [ ] map
] \ >fixnum inlined?
] unit-test
[ f ] [
[
{ integer } declare { } set-nth-unsafe
] \ >fixnum inlined?
] unit-test
[ f ] [
[
{ integer } declare 1 + { } set-nth-unsafe
] \ >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 ] [
[ { integer } declare bitnot detect-integer ]
\ detect-integer inlined?
] unit-test
! Later
! [ t ] [
! [
! { integer } declare [ 256 mod ] map
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare [ 0 >= ] map
! ] { >= fixnum>= } inlined?
! ] unit-test

203
core/inference/class/class.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables inference kernel
math namespaces sequences words parser math.intervals
effects classes classes.algebra inference.dataflow
inference.backend combinators ;
inference.backend combinators accessors ;
IN: inference.class
! Class inference
@ -25,12 +25,10 @@ C: <literal-constraint> literal-constraint
M: literal-constraint equal?
over literal-constraint? [
2dup
[ literal-constraint-literal ] bi@ eql? >r
[ literal-constraint-value ] bi@ = r> and
] [
2drop f
] if ;
[ [ literal>> ] bi@ eql? ]
[ [ value>> ] bi@ = ]
2bi and
] [ 2drop f ] if ;
TUPLE: class-constraint class value ;
@ -43,8 +41,8 @@ C: <interval-constraint> interval-constraint
GENERIC: apply-constraint ( constraint -- )
GENERIC: constraint-satisfied? ( constraint -- ? )
: `input node get node-in-d nth ;
: `output node get node-out-d nth ;
: `input node get in-d>> nth ;
: `output node get out-d>> nth ;
: class, <class-constraint> , ;
: literal, <literal-constraint> , ;
: interval, <interval-constraint> , ;
@ -84,14 +82,12 @@ SYMBOL: value-classes
set-value-interval* ;
M: interval-constraint apply-constraint
dup interval-constraint-interval
swap interval-constraint-value intersect-value-interval ;
[ interval>> ] [ value>> ] bi intersect-value-interval ;
: set-class-interval ( class value -- )
over class? [
over "interval" word-prop [
>r "interval" word-prop r> set-value-interval*
] [ 2drop ] if
>r "interval" word-prop r> over
[ set-value-interval* ] [ 2drop ] if
] [ 2drop ] if ;
: value-class* ( value -- class )
@ -110,18 +106,21 @@ M: interval-constraint apply-constraint
[ value-class* class-and ] keep set-value-class* ;
M: class-constraint apply-constraint
dup class-constraint-class
swap class-constraint-value intersect-value-class ;
[ class>> ] [ value>> ] bi intersect-value-class ;
: literal-interval ( value -- interval/f )
dup real? [ [a,a] ] [ drop f ] if ;
: set-value-literal* ( literal value -- )
over class over set-value-class*
over real? [ over [a,a] over set-value-interval* ] when
2dup <literal-constraint> assume
value-literals get set-at ;
{
[ >r class r> set-value-class* ]
[ >r literal-interval r> set-value-interval* ]
[ <literal-constraint> assume ]
[ value-literals get set-at ]
} 2cleave ;
M: literal-constraint apply-constraint
dup literal-constraint-literal
swap literal-constraint-value set-value-literal* ;
[ literal>> ] [ value>> ] bi set-value-literal* ;
! For conditionals, an assoc of child node # --> constraint
GENERIC: child-constraints ( node -- seq )
@ -133,19 +132,18 @@ GENERIC: infer-classes-around ( node -- )
M: node infer-classes-before drop ;
M: node child-constraints
node-children length
children>> length
dup zero? [ drop f ] [ f <repetition> ] if ;
: value-literal* ( value -- obj ? )
value-literals get at* ;
M: literal-constraint constraint-satisfied?
dup literal-constraint-value value-literal*
[ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
dup value>> value-literal*
[ swap literal>> eql? ] [ 2drop f ] if ;
M: class-constraint constraint-satisfied?
dup class-constraint-value value-class*
swap class-constraint-class class< ;
[ value>> value-class* ] [ class>> ] bi class< ;
M: pair apply-constraint
first2 2dup constraints get set-at
@ -154,19 +152,18 @@ M: pair apply-constraint
M: pair constraint-satisfied?
first constraint-satisfied? ;
: extract-keys ( assoc seq -- newassoc )
dup length <hashtable> swap [
dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if
] each nip f assoc-like ;
: extract-keys ( seq assoc -- newassoc )
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
: annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of
#! value classes.
dup node-values
value-intervals get over extract-keys pick set-node-intervals
value-classes get over extract-keys pick set-node-classes
value-literals get over extract-keys pick set-node-literals
2drop ;
dup node-values {
[ value-intervals get extract-keys >>intervals ]
[ value-classes get extract-keys >>classes ]
[ value-literals get extract-keys >>literals ]
[ 2drop ]
} cleave ;
: intersect-classes ( classes values -- )
[ intersect-value-class ] 2each ;
@ -190,31 +187,29 @@ M: pair constraint-satisfied?
] 2bi ;
: compute-constraints ( #call -- )
dup node-param "constraints" word-prop [
dup param>> "constraints" word-prop [
call
] [
dup node-param "predicating" word-prop dup
dup param>> "predicating" word-prop dup
[ swap predicate-constraints ] [ 2drop ] if
] if* ;
: compute-output-classes ( node word -- classes intervals )
dup node-param "output-classes" word-prop
dup param>> "output-classes" word-prop
dup [ call ] [ 2drop f f ] if ;
: output-classes ( node -- classes intervals )
dup compute-output-classes >r
[ ] [ node-param "default-output-classes" word-prop ] ?if
[ ] [ param>> "default-output-classes" word-prop ] ?if
r> ;
M: #call infer-classes-before
dup compute-constraints
dup node-out-d swap output-classes
>r over intersect-classes
r> swap intersect-intervals ;
[ compute-constraints ] keep
[ output-classes ] [ out-d>> ] bi
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
M: #push infer-classes-before
node-out-d
[ [ value-literal ] keep set-value-literal* ] each ;
out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
M: #if child-constraints
[
@ -224,19 +219,17 @@ M: #if child-constraints
M: #dispatch child-constraints
dup [
node-children length [
0 `input literal,
] each
children>> length [ 0 `input literal, ] each
] make-constraints ;
M: #declare infer-classes-before
dup node-param swap node-in-d
[ param>> ] [ in-d>> ] bi
[ intersect-value-class ] 2each ;
DEFER: (infer-classes)
: infer-children ( node -- )
dup node-children swap child-constraints [
[ children>> ] [ child-constraints ] bi [
[
value-classes [ clone ] change
value-literals [ clone ] change
@ -251,27 +244,27 @@ DEFER: (infer-classes)
>r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
: (merge-classes) ( nodes -- seq )
[ node-input-classes ] map
null pad-all flip [ null [ class-or ] reduce ] map ;
dup length 1 = [
first node-input-classes
] [
[ node-input-classes ] map null pad-all flip
[ null [ class-or ] reduce ] map
] if ;
: set-classes ( seq node -- )
node-out-d [ set-value-class* ] 2reverse-each ;
out-d>> [ set-value-class* ] 2reverse-each ;
: merge-classes ( nodes node -- )
>r (merge-classes) r> set-classes ;
: (merge-intervals) ( nodes quot -- seq )
>r
[ node-input-intervals ] map
f pad-all flip
r> map ; inline
: set-intervals ( seq node -- )
node-out-d [ set-value-interval* ] 2reverse-each ;
out-d>> [ set-value-interval* ] 2reverse-each ;
: merge-intervals ( nodes node -- )
>r [ dup first [ interval-union ] reduce ]
(merge-intervals) r> set-intervals ;
>r
[ node-input-intervals ] map f pad-all flip
[ dup first [ interval-union ] reduce ] map
r> set-intervals ;
: annotate-merge ( nodes #merge/#entry -- )
[ merge-classes ] [ merge-intervals ] 2bi ;
@ -280,28 +273,70 @@ DEFER: (infer-classes)
dup node-successor dup #merge? [
swap active-children dup empty?
[ 2drop ] [ swap annotate-merge ] if
] [
2drop
] if ;
] [ 2drop ] if ;
: classes= ( inferred current -- ? )
2dup min-length [ tail* ] curry bi@ sequence= ;
SYMBOL: fixed-point?
SYMBOL: nested-labels
: annotate-entry ( nodes #label -- )
node-child merge-classes ;
>r (merge-classes) r> node-child
2dup node-output-classes classes=
[ 2drop ] [ set-classes fixed-point? off ] if ;
: init-recursive-calls ( #label -- )
#! We set recursive calls to output the empty type, then
#! repeat inference until a fixed point is reached.
#! Hopefully, our type functions are monotonic so this
#! will always converge.
returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
M: #label infer-classes-before ( #label -- )
#! First, infer types under the hypothesis which hold on
#! entry to the recursive label.
[ 1array ] keep annotate-entry ;
[ init-recursive-calls ]
[ [ 1array ] keep annotate-entry ] bi ;
: infer-label-loop ( #label -- )
fixed-point? on
dup node-child (infer-classes)
dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
fixed-point? get [ drop ] [ infer-label-loop ] if ;
M: #label infer-classes-around ( #label -- )
#! Now merge the types at every recursion point with the
#! entry types.
{
[ annotate-node ]
[ infer-classes-before ]
[ infer-children ]
[ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
[ node-child (infer-classes) ]
} cleave ;
[
{
[ nested-labels get push ]
[ annotate-node ]
[ infer-classes-before ]
[ infer-label-loop ]
[ drop nested-labels get pop* ]
} cleave
] with-scope ;
: find-label ( param -- #label )
param>> nested-labels get [ param>> eq? ] with find nip ;
M: #call-label infer-classes-before ( #call-label -- )
[ find-label returns>> (merge-classes) ] [ out-d>> ] bi
[ set-value-class* ] 2each ;
M: #return infer-classes-around
nested-labels get length 0 > [
dup param>> nested-labels get peek param>> eq? [
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
classes= [
drop
] [
fixed-point? off
[ in-d>> value-classes get extract-keys ] keep
set-node-classes
] if
] [ drop ] if
] [ drop ] if ;
M: object infer-classes-around
{
@ -314,11 +349,13 @@ M: object infer-classes-around
: (infer-classes) ( node -- )
[
[ infer-classes-around ]
[ node-successor (infer-classes) ] bi
[ node-successor ] bi
(infer-classes)
] when* ;
: infer-classes-with ( node classes literals intervals -- )
[
V{ } clone nested-labels set
H{ } assoc-like value-intervals set
H{ } assoc-like value-literals set
H{ } assoc-like value-classes set
@ -326,13 +363,11 @@ M: object infer-classes-around
(infer-classes)
] with-scope ;
: infer-classes ( node -- )
f f f infer-classes-with ;
: infer-classes ( node -- node )
dup f f f infer-classes-with ;
: infer-classes/node ( node existing -- )
#! Infer classes, using the existing node's class info as a
#! starting point.
dup node-classes
over node-literals
rot node-intervals
[ node-classes ] [ node-literals ] [ node-intervals ] tri
infer-classes-with ;

5
core/inference/dataflow/dataflow.factor
View File

@ -90,7 +90,7 @@ M: object flatten-curry , ;
: node-child node-children first ;
TUPLE: #label < node word loop? ;
TUPLE: #label < node word loop? returns calls ;
: #label ( word label -- node )
\ #label param-node swap >>word ;
@ -290,6 +290,9 @@ SYMBOL: node-stack
: node-input-classes ( node -- seq )
dup in-d>> [ node-class ] with map ;
: node-output-classes ( node -- seq )
dup out-d>> [ node-class ] with map ;
: node-input-intervals ( node -- seq )
dup in-d>> [ node-interval ] with map ;

7
core/math/integers/integers-tests.factor
View File

@ -184,3 +184,10 @@ unit-test
[ HEX: 988a259c3433f237 ] [
B{ HEX: 37 HEX: f2 HEX: 33 HEX: 34 HEX: 9c HEX: 25 HEX: 8a HEX: 98 } byte-array>bignum
] unit-test
[ t ] [ 256 power-of-2? ] unit-test
[ f ] [ 123 power-of-2? ] unit-test
[ f ] [ -128 power-of-2? ] unit-test
[ f ] [ 0 power-of-2? ] unit-test
[ t ] [ 1 power-of-2? ] unit-test

2
core/math/intervals/intervals.factor
View File

@ -96,6 +96,8 @@ C: <interval> interval
: interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
: interval-sq ( i1 -- i2 ) dup interval* ;
: make-interval ( from to -- int )
over first over first {
{ [ 2dup > ] [ 2drop 2drop f ] }

12
core/math/math-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel sequences quotations
math.private math.functions ;
math.private ;
IN: math
ARTICLE: "division-by-zero" "Division by zero"
@ -26,17 +26,13 @@ $nl
{ $subsection < }
{ $subsection <= }
{ $subsection > }
{ $subsection >= }
"Inexact comparison:"
{ $subsection ~ } ;
{ $subsection >= } ;
ARTICLE: "modular-arithmetic" "Modular arithmetic"
{ $subsection mod }
{ $subsection rem }
{ $subsection /mod }
{ $subsection /i }
{ $subsection mod-inv }
{ $subsection ^mod }
{ $see-also "integer-functions" } ;
ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
@ -363,6 +359,10 @@ HELP: next-power-of-2
{ $values { "m" "a non-negative integer" } { "n" "an integer" } }
{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;
HELP: power-of-2?
{ $values { "n" integer } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
HELP: each-integer
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." }

24
core/math/math.factor
View File

@ -55,26 +55,26 @@ GENERIC: zero? ( x -- ? ) foldable
M: object zero? drop f ;
: 1+ ( x -- y ) 1 + ; foldable
: 1- ( x -- y ) 1 - ; foldable
: 2/ ( x -- y ) -1 shift ; foldable
: sq ( x -- y ) dup * ; foldable
: neg ( x -- -x ) 0 swap - ; foldable
: recip ( x -- y ) 1 swap / ; foldable
: 1+ ( x -- y ) 1 + ; inline
: 1- ( x -- y ) 1 - ; inline
: 2/ ( x -- y ) -1 shift ; inline
: sq ( x -- y ) dup * ; inline
: neg ( x -- -x ) 0 swap - ; inline
: recip ( x -- y ) 1 swap / ; inline
: ?1+ [ 1+ ] [ 0 ] if* ; inline
: /f ( x y -- z ) >r >float r> >float float/f ; inline
: max ( x y -- z ) [ > ] most ; foldable
: min ( x y -- z ) [ < ] most ; foldable
: max ( x y -- z ) [ > ] most ; inline
: min ( x y -- z ) [ < ] most ; inline
: between? ( x y z -- ? )
pick >= [ >= ] [ 2drop f ] if ; inline
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: [-] ( x y -- z ) - 0 max ; inline
@ -121,7 +121,11 @@ M: float fp-nan?
: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
: power-of-2? ( n -- ? )
dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
: align ( m w -- n )
1- [ + ] keep bitnot bitand ; inline
<PRIVATE

10
core/optimizer/collect/collect.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: inference.dataflow inference.backend kernel ;
IN: optimizer
: collect-label-infos ( node -- node )
dup [
dup #label? [ collect-label-info ] [ drop ] if
] each-node ;

32
core/optimizer/control/control-tests.factor
View File

@ -27,22 +27,22 @@ optimizer ;
dup [ 1+ loop-test-1 ] [ drop ] if ; inline
[ t ] [
[ loop-test-1 ] dataflow dup detect-loops
[ loop-test-1 ] dataflow detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ loop-test-1 1 2 3 ] dataflow dup detect-loops
[ loop-test-1 1 2 3 ] dataflow detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] dataflow dup detect-loops
[ [ loop-test-1 ] each ] dataflow detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] dataflow dup detect-loops
[ [ loop-test-1 ] each ] dataflow detect-loops
\ (each-integer) label-is-loop?
] unit-test
@ -50,7 +50,7 @@ optimizer ;
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
[ t ] [
[ loop-test-2 ] dataflow dup detect-loops
[ loop-test-2 ] dataflow detect-loops
\ loop-test-2 label-is-not-loop?
] unit-test
@ -58,7 +58,7 @@ optimizer ;
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
[ t ] [
[ loop-test-3 ] dataflow dup detect-loops
[ loop-test-3 ] dataflow detect-loops
\ loop-test-3 label-is-not-loop?
] unit-test
@ -73,7 +73,7 @@ optimizer ;
dup #label? [ node-successor find-label ] unless ;
: test-loop-exits
dataflow dup detect-loops find-label
dataflow detect-loops find-label
dup node-param swap
[ node-child find-tail find-loop-exits [ class ] map ] keep
#label-loop? ;
@ -113,7 +113,7 @@ optimizer ;
] unit-test
[ f ] [
[ [ [ ] map ] map ] dataflow dup detect-loops
[ [ [ ] map ] map ] dataflow detect-loops
[ dup #label? swap #loop? not and ] node-exists?
] unit-test
@ -128,22 +128,22 @@ DEFER: a
blah [ b ] [ a ] if ; inline
[ t ] [
[ a ] dataflow dup detect-loops
[ a ] dataflow detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] dataflow dup detect-loops
[ a ] dataflow detect-loops
\ b label-is-loop?
] unit-test
[ t ] [
[ b ] dataflow dup detect-loops
[ b ] dataflow detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] dataflow dup detect-loops
[ a ] dataflow detect-loops
\ b label-is-loop?
] unit-test
@ -156,12 +156,12 @@ DEFER: a'
blah [ b' ] [ a' ] if ; inline
[ f ] [
[ a' ] dataflow dup detect-loops
[ a' ] dataflow detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ b' ] dataflow dup detect-loops
[ b' ] dataflow detect-loops
\ b' label-is-loop?
] unit-test
@ -171,11 +171,11 @@ DEFER: a'
! a standard iterative dataflow problem after all -- so I'm
! tempted to believe the computer here
[ t ] [
[ b' ] dataflow dup detect-loops
[ b' ] dataflow detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ a' ] dataflow dup detect-loops
[ a' ] dataflow detect-loops
\ b' label-is-loop?
] unit-test

3
core/optimizer/control/control.factor
View File

@ -109,8 +109,9 @@ SYMBOL: potential-loops
] [ 2drop ] if
] assoc-each [ remove-non-loop-calls ] when ;
: detect-loops ( nodes -- )
: detect-loops ( node -- node )
[
dup
collect-label-info
remove-non-tail-calls
remove-non-loop-calls

4
core/optimizer/def-use/def-use-tests.factor
View File

@ -3,12 +3,12 @@ USING: inference inference.dataflow optimizer optimizer.def-use
namespaces assocs kernel sequences math tools.test words ;
[ 3 { 1 1 1 } ] [
[ 1 2 3 ] dataflow compute-def-use
[ 1 2 3 ] dataflow compute-def-use drop
def-use get values dup length swap [ length ] map
] unit-test
: kill-set ( quot -- seq )
dataflow compute-def-use compute-dead-literals keys
dataflow compute-def-use drop compute-dead-literals keys
[ value-literal ] map ;
: subset? [ member? ] curry all? ;

50
core/optimizer/def-use/def-use.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.def-use
USING: namespaces assocs sequences inference.dataflow
inference.backend kernel generic assocs classes vectors ;
inference.backend kernel generic assocs classes vectors
accessors combinators ;
IN: optimizer.def-use
SYMBOL: def-use
@ -21,17 +22,20 @@ SYMBOL: def-use
GENERIC: node-def-use ( node -- )
: compute-def-use ( node -- )
H{ } clone def-use set [ node-def-use ] each-node ;
: compute-def-use ( node -- node )
H{ } clone def-use set
dup [ node-def-use ] each-node ;
: nest-def-use ( node -- def-use )
[ compute-def-use def-use get ] with-scope ;
[ compute-def-use drop def-use get ] with-scope ;
: (node-def-use) ( node -- )
dup dup node-in-d uses-values
dup dup node-in-r uses-values
dup node-out-d defs-values
node-out-r defs-values ;
{
[ dup in-d>> uses-values ]
[ dup in-r>> uses-values ]
[ out-d>> defs-values ]
[ out-r>> defs-values ]
} cleave ;
M: object node-def-use (node-def-use) ;
@ -43,7 +47,7 @@ M: #passthru node-def-use drop ;
M: #return node-def-use
#! Values returned by local labels can be killed.
dup node-param [ drop ] [ (node-def-use) ] if ;
dup param>> [ drop ] [ (node-def-use) ] if ;
! nodes that don't use their values directly
UNION: #killable
@ -56,13 +60,13 @@ UNION: #killable
M: #label node-def-use
[
dup node-in-d ,
dup node-child node-out-d ,
dup collect-recursion [ node-in-d , ] each
dup in-d>> ,
dup node-child out-d>> ,
dup calls>> [ in-d>> , ] each
] { } make purge-invariants uses-values ;
: branch-def-use ( #branch -- )
active-children [ node-in-d ] map
active-children [ in-d>> ] map
purge-invariants t swap uses-values ;
M: #branch node-def-use
@ -85,16 +89,16 @@ M: node kill-node* drop t ;
inline
M: #shuffle kill-node*
[
dup node-in-d empty? swap node-out-d empty? and
] prune-if ;
[ [ in-d>> empty? ] [ out-d>> empty? ] bi and ] prune-if ;
M: #push kill-node*
[ node-out-d empty? ] prune-if ;
[ out-d>> empty? ] prune-if ;
M: #>r kill-node* [ node-in-d empty? ] prune-if ;
M: #>r kill-node*
[ in-d>> empty? ] prune-if ;
M: #r> kill-node* [ node-in-r empty? ] prune-if ;
M: #r> kill-node*
[ in-r>> empty? ] prune-if ;
: kill-node ( node -- node )
dup [
@ -116,7 +120,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
] if ;
: sole-consumer ( #call -- node/f )
node-out-d first used-by
out-d>> first used-by
dup length 1 = [ first ] [ drop f ] if ;
: splice-def-use ( node -- )
@ -128,5 +132,5 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
#! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously
#! flush them away.
[ compute-def-use def-use get keys ] with-scope
nest-def-use keys
def-use get [ [ t swap ?push ] change-at ] curry each ;

10
core/optimizer/inlining/inlining-tests.factor Normal file
View File

@ -0,0 +1,10 @@
IN: optimizer.inlining.tests
USING: tools.test optimizer.inlining ;
\ word-flat-length must-infer
\ inlining-math-method must-infer
\ optimistic-inline? must-infer
\ find-identity must-infer

40
core/optimizer/inlining/inlining.factor
View File

@ -3,10 +3,11 @@
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes classes.algebra generic.math continuations
optimizer.def-use optimizer.backend generic.standard
optimizer.specializers optimizer.def-use optimizer.pattern-match
generic.standard optimizer.control kernel.private ;
combinators classes classes.algebra generic.math
optimizer.math.partial continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control kernel.private ;
IN: optimizer.inlining
: remember-inlining ( node history -- )
@ -53,8 +54,6 @@ DEFER: (flat-length)
[ word-def (flat-length) ] with-scope ;
! Single dispatch method inlining optimization
: specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ;
@ -72,6 +71,7 @@ DEFER: (flat-length)
! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' )
{
null
fixnum bignum integer
ratio rational
float real
@ -79,21 +79,31 @@ DEFER: (flat-length)
object
} [ class< ] with find nip ;
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
: inline-math-method ( #call word -- node )
over node-input-classes
: inlining-math-method ( #call word -- quot/f )
swap node-input-classes
[ first normalize-math-class ]
[ second normalize-math-class ] bi
3dup math-both-known?
[ math-method f splice-quot ]
[ 2drop 2drop t ] if ;
3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
: inline-math-method ( #call word -- node/t )
[ drop ] [ inlining-math-method ] 2bi
dup [ f splice-quot ] [ 2drop t ] if ;
: inline-math-partial ( #call word -- node/t )
[ drop ]
[
"derived-from" word-prop first
inlining-math-method dup
]
[ nip 1quotation ] 2tri
[ = not ] [ drop ] 2bi and
[ f splice-quot ] [ 2drop t ] if ;
: inline-method ( #call -- node )
dup node-param {
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] }
[ 2drop t ]
} cond ;
@ -183,7 +193,7 @@ DEFER: (flat-length)
nip dup [ second ] when ;
: apply-identities ( node -- node/f )
dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
dup find-identity f splice-quot ;
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [

12
core/optimizer/known-words/known-words.factor
View File

@ -83,21 +83,11 @@ sequences.private combinators ;
] "constraints" set-word-prop
! eq? on the same object is always t
{ eq? bignum= float= number= = } {
{ eq? = } {
{ { @ @ } [ 2drop t ] }
} define-identities
! Specializers
{ 1+ 1- sq neg recip sgn } [
{ number } "specializer" set-word-prop
] each
\ 2/ { fixnum } "specializer" set-word-prop
{ min max } [
{ number number } "specializer" set-word-prop
] each
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each

331
core/optimizer/math/math.factor
View File

@ -8,103 +8,104 @@ namespaces assocs quotations math.intervals sequences.private
combinators splitting layouts math.parser classes
classes.algebra generic.math optimizer.pattern-match
optimizer.backend optimizer.def-use optimizer.inlining
generic.standard system ;
optimizer.math.partial generic.standard system accessors ;
{ + bignum+ float+ fixnum+fast } {
: define-math-identities ( word identities -- )
>r all-derived-ops r> define-identities ;
\ number= {
{ { @ @ } [ 2drop t ] }
} define-math-identities
\ + {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
} define-identities
} define-math-identities
{ fixnum+ } {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
} define-identities
{ - fixnum- bignum- float- fixnum-fast } {
\ - {
{ { number 0 } [ drop ] }
{ { @ @ } [ 2drop 0 ] }
} define-identities
} define-math-identities
{ < fixnum< bignum< float< } {
\ < {
{ { @ @ } [ 2drop f ] }
} define-identities
} define-math-identities
{ <= fixnum<= bignum<= float<= } {
\ <= {
{ { @ @ } [ 2drop t ] }
} define-identities
} define-math-identities
{ > fixnum> bignum> float>= } {
\ > {
{ { @ @ } [ 2drop f ] }
} define-identities
} define-math-identities
{ >= fixnum>= bignum>= float>= } {
\ >= {
{ { @ @ } [ 2drop t ] }
} define-identities
} define-math-identities
{ * fixnum* bignum* float* } {
\ * {
{ { number 1 } [ drop ] }
{ { 1 number } [ nip ] }
{ { number 0 } [ nip ] }
{ { 0 number } [ drop ] }
{ { number -1 } [ drop 0 swap - ] }
{ { -1 number } [ nip 0 swap - ] }
} define-identities
} define-math-identities
{ / fixnum/i bignum/i float/f } {
\ / {
{ { number 1 } [ drop ] }
{ { number -1 } [ drop 0 swap - ] }
} define-identities
} define-math-identities
{ fixnum-mod bignum-mod } {
{ { number 1 } [ 2drop 0 ] }
} define-identities
\ mod {
{ { integer 1 } [ 2drop 0 ] }
} define-math-identities
{ bitand fixnum-bitand bignum-bitand } {
\ rem {
{ { integer 1 } [ 2drop 0 ] }
} define-math-identities
\ bitand {
{ { number -1 } [ drop ] }
{ { -1 number } [ nip ] }
{ { @ @ } [ drop ] }
{ { number 0 } [ nip ] }
{ { 0 number } [ drop ] }
} define-identities
} define-math-identities
{ bitor fixnum-bitor bignum-bitor } {
\ bitor {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
{ { @ @ } [ drop ] }
{ { number -1 } [ nip ] }
{ { -1 number } [ drop ] }
} define-identities
} define-math-identities
{ bitxor fixnum-bitxor bignum-bitxor } {
\ bitxor {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
{ { number -1 } [ drop bitnot ] }
{ { -1 number } [ nip bitnot ] }
{ { @ @ } [ 2drop 0 ] }
} define-identities
} define-math-identities
{ shift fixnum-shift fixnum-shift-fast bignum-shift } {
\ shift {
{ { 0 number } [ drop ] }
{ { number 0 } [ drop ] }
} define-identities
} define-math-identities
: math-closure ( class -- newclass )
{ fixnum integer rational real }
{ null fixnum bignum integer rational float real number }
[ class< ] with find nip number or ;
: fits? ( interval class -- ? )
"interval" word-prop dup
[ interval-subset? ] [ 2drop t ] if ;
: math-output-class ( node min -- newclass )
#! if min is f, it means we just want to use the declared
#! output class from the "infer-effect".
dup [
swap node-in-d
[ value-class* math-closure math-class-max ] each
] [
2drop f
] if ;
: math-output-class ( node upgrades -- newclass )
>r
in-d>> null [ value-class* math-closure math-class-max ] reduce
dup r> at swap or ;
: won't-overflow? ( interval node -- ? )
node-in-d [ value-class* fixnum class< ] all?
@ -123,28 +124,18 @@ generic.standard system ;
2drop f
] if ; inline
: math-output-class/interval-1 ( node min word -- classes intervals )
pick >r
>r over r>
math-output-interval-1
>r math-output-class r>
r> post-process ; inline
: math-output-class/interval-1 ( node word -- classes intervals )
[ drop { } math-output-class 1array ]
[ math-output-interval-1 1array ] 2bi ;
{
{ 1+ integer interval-1+ }
{ 1- integer interval-1- }
{ neg integer interval-neg }
{ shift integer interval-recip }
{ bitnot fixnum interval-bitnot }
{ fixnum-bitnot f interval-bitnot }
{ bignum-bitnot f interval-bitnot }
{ 2/ fixnum interval-2/ }
{ sq integer f }
{ bitnot interval-bitnot }
{ fixnum-bitnot interval-bitnot }
{ bignum-bitnot interval-bitnot }
} [
first3 [
math-output-class/interval-1
] 2curry "output-classes" set-word-prop
] each
[ math-output-class/interval-1 ] curry
"output-classes" set-word-prop
] assoc-each
: intervals ( node -- i1 i2 )
node-in-d first2 [ value-interval* ] bi@ ;
@ -156,7 +147,7 @@ generic.standard system ;
2drop f
] if ; inline
: math-output-class/interval-2 ( node min word -- classes intervals )
: math-output-class/interval-2 ( node upgrades word -- classes intervals )
pick >r
>r over r>
math-output-interval-2
@ -164,47 +155,18 @@ generic.standard system ;
r> post-process ; inline
{
{ + integer interval+ }
{ - integer interval- }
{ * integer interval* }
{ / rational interval/ }
{ /i integer interval/i }
{ fixnum+ f interval+ }
{ fixnum+fast f interval+ }
{ fixnum- f interval- }
{ fixnum-fast f interval- }
{ fixnum* f interval* }
{ fixnum*fast f interval* }
{ fixnum/i f interval/i }
{ bignum+ f interval+ }
{ bignum- f interval- }
{ bignum* f interval* }
{ bignum/i f interval/i }
{ bignum-shift f interval-shift-safe }
{ float+ f interval+ }
{ float- f interval- }
{ float* f interval* }
{ float/f f interval/ }
{ min fixnum interval-min }
{ max fixnum interval-max }
{ + { { fixnum integer } } interval+ }
{ - { { fixnum integer } } interval- }
{ * { { fixnum integer } } interval* }
{ / { { fixnum rational } { integer rational } } interval/ }
{ /i { { fixnum integer } } interval/i }
{ shift { { fixnum integer } } interval-shift-safe }
} [
first3 [
math-output-class/interval-2
] 2curry "output-classes" set-word-prop
] each
{ fixnum-shift fixnum-shift-fast shift } [
[
dup
node-in-d second value-interval*
-1./0. 0 [a,b] interval-subset? fixnum integer ?
\ interval-shift-safe
math-output-class/interval-2
] "output-classes" set-word-prop
[
math-output-class/interval-2
] 2curry "output-classes" set-word-prop
] 2curry each-derived-op
] each
: real-value? ( value -- n ? )
@ -235,22 +197,18 @@ generic.standard system ;
r> post-process ; inline
{
{ mod fixnum mod-range }
{ fixnum-mod f mod-range }
{ bignum-mod f mod-range }
{ float-mod f mod-range }
{ mod { } mod-range }
{ rem { { fixnum integer } } rem-range }
{ rem integer rem-range }
{ bitand fixnum bitand-range }
{ fixnum-bitand f bitand-range }
{ bitor fixnum f }
{ bitxor fixnum f }
{ bitand { } bitand-range }
{ bitor { } f }
{ bitxor { } f }
} [
first3 [
math-output-class/interval-special
] 2curry "output-classes" set-word-prop
[
math-output-class/interval-special
] 2curry "output-classes" set-word-prop
] 2curry each-derived-op
] each
: twiddle-interval ( i1 -- i2 )
@ -280,26 +238,12 @@ generic.standard system ;
{ <= assume<= assume> }
{ > assume> assume<= }
{ >= assume>= assume< }
{ fixnum< assume< assume>= }
{ fixnum<= assume<= assume> }
{ fixnum> assume> assume<= }
{ fixnum>= assume>= assume< }
{ bignum< assume< assume>= }
{ bignum<= assume<= assume> }
{ bignum> assume> assume<= }
{ bignum>= assume>= assume< }
{ float< assume< assume>= }
{ float<= assume<= assume> }
{ float> assume> assume<= }
{ float>= assume>= assume< }
} [
first3
[
[ comparison-constraints ] with-scope
] 2curry "constraints" set-word-prop
first3 [
[
[ comparison-constraints ] with-scope
] 2curry "constraints" set-word-prop
] 2curry each-derived-op
] each
{
@ -348,22 +292,20 @@ most-negative-fixnum most-positive-fixnum [a,b]
! Removing overflow checks
: remove-overflow-check? ( #call -- ? )
dup node-out-d first node-class fixnum class< ;
dup out-d>> first node-class
[ fixnum class< ] [ null eq? not ] bi and ;
{
{ + [ fixnum+fast ] }
{ +-integer-fixnum [ fixnum+fast ] }
{ - [ fixnum-fast ] }
{ * [ fixnum*fast ] }
{ *-integer-fixnum [ fixnum*fast ] }
{ shift [ fixnum-shift-fast ] }
{ fixnum+ [ fixnum+fast ] }
{ fixnum- [ fixnum-fast ] }
{ fixnum* [ fixnum*fast ] }
! these are here as an optimization. if they weren't given
! explicitly, the same would be inferred after an extra
! optimization step (see optimistic-inline?)
{ 1+ [ 1 fixnum+fast ] }
{ 1- [ 1 fixnum-fast ] }
{ 2/ [ -1 fixnum-shift ] }
{ neg [ 0 swap fixnum-fast ] }
{ fixnum-shift [ fixnum-shift-fast ] }
} [
[
[ dup remove-overflow-check? ] ,
@ -397,26 +339,13 @@ most-negative-fixnum most-positive-fixnum [a,b]
{ <= interval<= }
{ > interval> }
{ >= interval>= }
{ fixnum< interval< }
{ fixnum<= interval<= }
{ fixnum> interval> }
{ fixnum>= interval>= }
{ bignum< interval< }
{ bignum<= interval<= }
{ bignum> interval> }
{ bignum>= interval>= }
{ float< interval< }
{ float<= interval<= }
{ float> interval> }
{ float>= interval>= }
} [
[
dup [ dupd foldable-comparison? ] curry ,
[ fold-comparison ] curry ,
] { } make 1array define-optimizers
[
dup [ dupd foldable-comparison? ] curry ,
[ fold-comparison ] curry ,
] { } make 1array define-optimizers
] curry each-derived-op
] assoc-each
! The following words are handled in a similar way except if
@ -426,44 +355,68 @@ most-negative-fixnum most-positive-fixnum [a,b]
swap sole-consumer
dup #call? [ node-param eq? ] [ 2drop f ] if ;
: coereced-to-fixnum? ( #call -- ? )
\ >fixnum consumed-by? ;
: coerced-to-fixnum? ( #call -- ? )
dup dup node-in-d [ node-class integer class< ] with all?
[ \ >fixnum consumed-by? ] [ drop f ] if ;
{
{ fixnum+ [ fixnum+fast ] }
{ fixnum- [ fixnum-fast ] }
{ fixnum* [ fixnum*fast ] }
{ + [ [ >fixnum ] bi@ fixnum+fast ] }
{ - [ [ >fixnum ] bi@ fixnum-fast ] }
{ * [ [ >fixnum ] bi@ fixnum*fast ] }
} [
[
>r derived-ops r> [
[
dup remove-overflow-check?
over coereced-to-fixnum? or
] ,
[ f splice-quot ] curry ,
] { } make 1array define-optimizers
[
dup remove-overflow-check?
over coerced-to-fixnum? or
] ,
[ f splice-quot ] curry ,
] { } make 1array define-optimizers
] curry each
] assoc-each
: fixnum-shift-fast-pos? ( node -- ? )
#! Shifting 1 to the left won't overflow if the shift
#! count is small enough
dup dup node-in-d first node-literal 1 = [
dup node-in-d second node-interval
0 cell-bits tag-bits get - 2 - [a,b] interval-subset?
] [ drop f ] if ;
: convert-rem-to-and? ( #call -- ? )
dup node-in-d {
{ [ 2dup first node-class integer class< not ] [ f ] }
{ [ 2dup second node-literal integer? not ] [ f ] }
{ [ 2dup second node-literal power-of-2? not ] [ f ] }
[ t ]
} cond 2nip ;
: fixnum-shift-fast-neg? ( node -- ? )
#! Shifting any number to the right won't overflow if the
#! shift count is small enough
dup node-in-d second node-interval
cell-bits 1- neg 0 [a,b] interval-subset? ;
: convert-mod-to-and? ( #call -- ? )
dup dup node-in-d first node-interval 0 [a,inf] interval-subset?
[ convert-rem-to-and? ] [ drop f ] if ;
: fixnum-shift-fast? ( node -- ? )
dup fixnum-shift-fast-pos?
[ drop t ] [ fixnum-shift-fast-neg? ] if ;
: convert-mod-to-and ( #call -- node )
dup
dup node-in-d second node-literal 1-
[ nip bitand ] curry f splice-quot ;
\ fixnum-shift {
\ mod [
{
[ dup fixnum-shift-fast? ]
[ [ fixnum-shift-fast ] f splice-quot ]
{
[ dup convert-mod-to-and? ]
[ convert-mod-to-and ]
}
} define-optimizers
] each-derived-op
\ rem {
{
[ dup convert-rem-to-and? ]
[ convert-mod-to-and ]
}
} define-optimizers
: fixnumify-bitand? ( #call -- ? )
dup node-in-d second node-interval fixnum fits? ;
: fixnumify-bitand ( #call -- node )
[ [ >fixnum ] bi@ fixnum-bitand ] f splice-quot ;
\ bitand {
{
[ dup fixnumify-bitand? ]
[ fixnumify-bitand ]
}
} define-optimizers

13
core/optimizer/math/partial/partial-tests.factor Normal file
View File

@ -0,0 +1,13 @@
IN: optimizer.math.partial.tests
USING: optimizer.math.partial tools.test math kernel
sequences ;
[ t ] [ \ + integer fixnum math-both-known? ] unit-test
[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
[ t ] [ \ + integer bignum math-both-known? ] unit-test
[ t ] [ \ + float fixnum math-both-known? ] unit-test
[ f ] [ \ + real fixnum math-both-known? ] unit-test
[ f ] [ \ + object number math-both-known? ] unit-test
[ 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

172
core/optimizer/math/partial/partial.factor Normal file
View File

@ -0,0 +1,172 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private math math.private words
sequences parser namespaces assocs quotations arrays
generic generic.math hashtables effects ;
IN: optimizer.math.partial
! 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 ;
: fixnum-integer-op ( a b fix-word big-word -- c )
pick tag 0 eq? [
drop execute
] [
>r drop >r fixnum>bignum r> r> execute
] if ; inline
: integer-fixnum-op ( a b fix-word big-word -- c )
>r pick tag 0 eq? [
r> drop execute
] [
drop fixnum>bignum r> execute
] if ; inline
: integer-integer-op ( a b fix-word big-word -- c )
pick tag 0 eq? [
integer-fixnum-op
] [
>r drop over tag 0 eq? [
>r fixnum>bignum r> r> execute
] [
r> execute
] if
] if ; inline
<<
: integer-op-combinator ( triple -- word )
[
[ second word-name % "-" % ]
[ third word-name % "-op" % ]
bi
] "" make in get lookup ;
: integer-op-word ( triple fix-word big-word -- word )
[
drop
word-name "fast" tail? >r
[ "-" % ] [ word-name % ] interleave
r> [ "-fast" % ] when
] "" make in get create ;
: integer-op-quot ( word fix-word big-word -- quot )
rot integer-op-combinator 1quotation 2curry ;
: define-integer-op-word ( word fix-word big-word -- )
[
[ integer-op-word ] [ integer-op-quot ] 3bi
2 1 <effect> define-declared
]
[
[ integer-op-word ] [ 2drop ] 3bi
"derived-from" set-word-prop
] 3bi ;
: define-integer-op-words ( words fix-word big-word -- )
[ define-integer-op-word ] 2curry each ;
: integer-op-triples ( word -- triples )
{
{ fixnum integer }
{ integer fixnum }
{ integer integer }
} swap [ prefix ] curry map ;
: define-integer-ops ( word fix-word big-word -- )
>r >r integer-op-triples r> r>
[ define-integer-op-words ]
[ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
3bi ;
: define-math-ops ( op -- )
{ fixnum bignum float }
[ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
[ nip ] assoc-subset
[ word-def peek ] assoc-map % ;
SYMBOL: math-ops
[
\ + define-math-ops
\ - define-math-ops
\ * define-math-ops
\ shift define-math-ops
\ mod define-math-ops
\ /i define-math-ops
\ bitand define-math-ops
\ bitor define-math-ops
\ bitxor define-math-ops
\ < define-math-ops
\ <= define-math-ops
\ > define-math-ops
\ >= define-math-ops
\ number= define-math-ops
\ + \ fixnum+ \ bignum+ define-integer-ops
\ - \ fixnum- \ bignum- define-integer-ops
\ * \ fixnum* \ bignum* define-integer-ops
\ shift \ fixnum-shift \ bignum-shift define-integer-ops
\ mod \ fixnum-mod \ bignum-mod define-integer-ops
\ /i \ fixnum/i \ bignum/i define-integer-ops
\ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
\ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
\ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
\ < \ fixnum< \ bignum< define-integer-ops
\ <= \ fixnum<= \ bignum<= define-integer-ops
\ > \ fixnum> \ bignum> define-integer-ops
\ >= \ fixnum>= \ bignum>= define-integer-ops
\ number= \ eq? \ bignum= define-integer-ops
] { } make >hashtable math-ops set-global
SYMBOL: fast-math-ops
[
{ { + fixnum fixnum } fixnum+fast } ,
{ { - fixnum fixnum } fixnum-fast } ,
{ { * fixnum fixnum } fixnum*fast } ,
{ { shift fixnum fixnum } fixnum-shift-fast } ,
\ + \ fixnum+fast \ bignum+ define-integer-ops
\ - \ fixnum-fast \ bignum- define-integer-ops
\ * \ fixnum*fast \ bignum* define-integer-ops
\ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
] { } make >hashtable fast-math-ops set-global
>>
: math-op ( word left right -- word' ? )
3array math-ops get at* ;
: math-method* ( word left right -- quot )
3dup math-op
[ >r 3drop r> 1quotation ] [ drop math-method ] if ;
: math-both-known? ( word left right -- ? )
3dup math-op
[ 2drop 2drop t ]
[ drop math-class-max swap specific-method >boolean ] if ;
: (derived-ops) ( word assoc -- words )
swap [ rot first eq? nip ] curry assoc-subset values ;
: derived-ops ( word -- words )
[ 1array ]
[ math-ops get (derived-ops) ]
bi append ;
: fast-derived-ops ( word -- words )
fast-math-ops get (derived-ops) ;
: all-derived-ops ( word -- words )
[ derived-ops ] [ fast-derived-ops ] bi append ;
: each-derived-op ( word quot -- )
>r derived-ops r> each ; inline

43
core/optimizer/optimizer-tests.factor
View File

@ -14,40 +14,6 @@ IN: optimizer.tests
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
] unit-test
! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test
[ string ] [
\ string
[ integer string array reversed sbuf
slice vector quotation ]
sort-classes min-class
] unit-test
[ fixnum ] [
\ fixnum
[ fixnum integer object ]
sort-classes min-class
] unit-test
[ integer ] [
\ fixnum
[ integer float object ]
sort-classes min-class
] unit-test
[ object ] [
\ word
[ integer float object ]
sort-classes min-class
] unit-test
[ reversed ] [
\ reversed
[ integer reversed slice ]
sort-classes min-class
] unit-test
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
@ -374,3 +340,12 @@ HINTS: recursive-inline-hang-3 array ;
USE: sequences.private
[ ] [ { (3append) } compile ] unit-test
! Wow
: counter-example ( a b c d -- a' b' c' d' )
dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline
: counter-example' ( -- a' b' c' d' )
1 2 3.0 3 counter-example ;
[ 2 4 6.0 0 ] [ counter-example' ] unit-test

11
core/optimizer/optimizer.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math optimizer.control
optimizer.inlining inference.class ;
optimizer.collect optimizer.inlining inference.class ;
IN: optimizer
: optimize-1 ( node -- newnode ? )
@ -10,10 +10,13 @@ IN: optimizer
H{ } clone class-substitutions set
H{ } clone literal-substitutions set
H{ } clone value-substitutions set
dup compute-def-use
collect-label-infos
compute-def-use
kill-values
dup detect-loops
dup infer-classes
detect-loops
infer-classes
optimizer-changed off
optimize-nodes
optimizer-changed get

43
extra/benchmark/recursive/recursive.factor
View File

@ -1,38 +1,37 @@
USING: math kernel hints prettyprint io combinators ;
IN: benchmark.recursive
USING: math kernel hints prettyprint io ;
: fib ( m -- n )
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
dup 2 < [ drop 1 ] [ [ 1 - fib ] [ 2 - fib ] bi + ] if ;
inline
: ack ( m n -- x )
over zero? [
nip 1+
] [
dup zero? [
drop 1- 1 ack
] [
dupd 1- ack >r 1- r> ack
] if
] if ;
{
{ [ over zero? ] [ nip 1+ ] }
{ [ dup zero? ] [ drop 1- 1 ack ] }
[ [ drop 1- ] [ 1- ack ] 2bi ack ]
} cond ; inline
: tak ( x y z -- t )
2over swap < [
[ rot 1- -rot tak ] 3keep
[ -rot 1- -rot tak ] 3keep
1- -rot tak
tak
] [
2over <= [
2nip
] if ;
] [
[ rot 1- -rot tak ]
[ -rot 1- -rot tak ]
[ 1- -rot tak ]
3tri
tak
] if ; inline
: recursive ( n -- )
3 over ack . flush
dup 27.0 + fib . flush
1-
dup 3 * over 2 * rot tak . flush
[ 3 swap ack . flush ]
[ 27.0 + fib . flush ]
[ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
3 fib . flush
3.0 2.0 1.0 tak . flush ;
HINTS: recursive fixnum ;
: recursive-main 11 recursive ;
MAIN: recursive-main

11
extra/math/functions/functions-docs.factor
View File

@ -7,6 +7,9 @@ ARTICLE: "integer-functions" "Integer functions"
{ $subsection gcd }
{ $subsection log2 }
{ $subsection next-power-of-2 }
"Modular exponentiation:"
{ $subsection ^mod }
{ $subsection mod-inv }
"Tests:"
{ $subsection power-of-2? }
{ $subsection even? }
@ -33,7 +36,9 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions"
{ $subsection ceiling }
{ $subsection floor }
{ $subsection truncate }
{ $subsection round } ;
{ $subsection round }
"Inexact comparison:"
{ $subsection ~ } ;
ARTICLE: "power-functions" "Powers and logarithms"
"Squares:"
@ -107,10 +112,6 @@ HELP: >rect
{ $values { "z" number } { "x" real } { "y" real } }
{ $description "Extracts the real and imaginary components of a complex number." } ;
HELP: power-of-2?
{ $values { "n" integer } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
HELP: align
{ $values { "m" integer } { "w" "a power of 2" } { "n" "an integer multiple of " { $snippet "w" } } }
{ $description "Outputs the least multiple of " { $snippet "w" } " greater than " { $snippet "m" } "." }

3
extra/math/functions/functions-tests.factor
View File

@ -81,9 +81,6 @@ IN: math.functions.tests
[ 1/8 ] [ 2 -3 ^ ] unit-test
[ t ] [ 1 100 shift 2 100 ^ = ] unit-test
[ t ] [ 256 power-of-2? ] unit-test
[ f ] [ 123 power-of-2? ] unit-test
[ 1 ] [ 7/8 ceiling ] unit-test
[ 2 ] [ 3/2 ceiling ] unit-test
[ 0 ] [ -7/8 ceiling ] unit-test

3
extra/math/functions/functions.factor
View File

@ -102,9 +102,6 @@ M: real absq sq ;
[ ~abs ]
} cond ;
: power-of-2? ( n -- ? )
dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable
: >rect ( z -- x y ) dup real-part swap imaginary-part ; inline
: conjugate ( z -- z* ) >rect neg rect> ; inline

24
extra/project-euler/150/150.factor
View File

@ -1,15 +1,21 @@
! Copyright (c) 2008 Eric Mertens
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences locals ;
USING: kernel math sequences sequences.private locals hints ;
IN: project-euler.150
<PRIVATE
! sequence helper functions
: partial-sums ( seq -- seq )
: partial-sums ( seq -- sums )
0 [ + ] accumulate swap suffix ; inline
: (partial-sum-infimum) ( inf sum elt -- inf sum )
+ [ min ] keep ; inline
: partial-sum-infimum ( seq -- seq )
0 0 rot [ (partial-sum-infimum) ] each drop ; inline
: generate ( n quot -- seq )
[ drop ] swap compose map ; inline
@ -20,10 +26,10 @@ IN: project-euler.150
! triangle generator functions
: next ( t -- new-t s )
615949 * 797807 + 1 20 shift mod dup 1 19 shift - ; inline
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
PRIVATE>
@ -32,13 +38,15 @@ PRIVATE>
m [| x |
x 1+ [| y |
m x - [| z |
x z + table nth
[ y z + 1+ swap nth ]
[ y swap nth ] bi -
] map partial-sums infimum
x z + table nth-unsafe
[ y z + 1+ swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
] map partial-sum-infimum
] map-infimum
] map-infimum
] ;
HINTS: (euler150) fixnum ;
: euler150 ( -- n )
1000 (euler150) ;

19
vm/data_gc.c
View File

@ -122,7 +122,7 @@ void clear_cards(CELL from, CELL to)
void set_data_heap(F_DATA_HEAP *data_heap_)
{
data_heap = data_heap_;
nursery = &data_heap->generations[NURSERY];
nursery = data_heap->generations[NURSERY];
init_cards_offset();
clear_cards(NURSERY,TENURED);
}
@ -231,7 +231,7 @@ DEFINE_PRIMITIVE(data_room)
for(gen = 0; gen < data_heap->gen_count; gen++)
{
F_ZONE *z = &data_heap->generations[gen];
F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
}
@ -583,7 +583,7 @@ CELL collect_next(CELL scan)
INLINE void reset_generation(CELL i)
{
F_ZONE *z = &data_heap->generations[i];
F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
z->here = z->start;
if(secure_gc)
memset((void*)z->start,69,z->size);
@ -608,7 +608,7 @@ void begin_gc(CELL requested_bytes)
old_data_heap = data_heap;
set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
newspace = &data_heap->generations[collecting_gen];
newspace = &data_heap->generations[TENURED];
}
else if(collecting_accumulation_gen_p())
{
@ -783,6 +783,11 @@ void gc(void)
garbage_collection(TENURED,false,0);
}
void minor_gc(void)
{
garbage_collection(NURSERY,false,0);
}
DEFINE_PRIMITIVE(gc)
{
gc();
@ -794,12 +799,6 @@ DEFINE_PRIMITIVE(gc_time)
box_unsigned_8(gc_time);
}
void simple_gc(void)
{
if(nursery->here + ALLOT_BUFFER_ZONE > nursery->end)
garbage_collection(NURSERY,false,0);
}
DEFINE_PRIMITIVE(become)
{
F_ARRAY *new_objects = untag_array(dpop());

15
vm/data_gc.h
View File

@ -20,6 +20,7 @@ DECLARE_PRIMITIVE(next_object);
DECLARE_PRIMITIVE(end_scan);
void gc(void);
DLLEXPORT void minor_gc(void);
/* generational copying GC divides memory into zones */
typedef struct {
@ -125,7 +126,7 @@ void collect_cards(void);
F_ZONE *newspace;
/* new objects are allocated here */
DLLEXPORT F_ZONE *nursery;
DLLEXPORT F_ZONE nursery;
INLINE bool in_zone(F_ZONE *z, CELL pointer)
{
@ -200,7 +201,7 @@ INLINE bool should_copy(CELL untagged)
else if(HAVE_AGING_P && collecting_gen == AGING)
return !in_zone(&data_heap->generations[TENURED],untagged);
else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
return in_zone(&data_heap->generations[NURSERY],untagged);
return in_zone(&nursery,untagged);
else
{
critical_error("Bug in should_copy",untagged);
@ -315,13 +316,15 @@ INLINE void* allot_object(CELL type, CELL a)
{
CELL *object;
if(HAVE_NURSERY_P && nursery->size - ALLOT_BUFFER_ZONE > a)
if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a)
{
/* If there is insufficient room, collect the nursery */
if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end)
if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end)
garbage_collection(NURSERY,false,0);
object = allot_zone(nursery,a);
CELL h = nursery.here;
nursery.here = h + align8(a);
object = (void*)h;
}
/* If the object is bigger than the nursery, allocate it in
tenured space */
@ -360,8 +363,6 @@ INLINE void* allot_object(CELL type, CELL a)
CELL collect_next(CELL scan);
DLLEXPORT void simple_gc(void);
DECLARE_PRIMITIVE(gc);
DECLARE_PRIMITIVE(gc_time);
DECLARE_PRIMITIVE(become);

6
vm/debug.c
View File

@ -227,7 +227,11 @@ void dump_zone(F_ZONE *z)
void dump_generations(void)
{
int i;
for(i = 0; i < data_heap->gen_count; i++)
printf("Nursery: ");
dump_zone(&nursery);
for(i = 1; i < data_heap->gen_count; i++)
{
printf("Generation %d: ",i);
dump_zone(&data_heap->generations[i]);

2
vm/errors.c
View File

@ -96,7 +96,7 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack)
general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
else if(in_page(addr, rs_bot, rs_size, 0))
general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
else if(in_page(addr, nursery->end, 0, 0))
else if(in_page(addr, nursery.end, 0, 0))
critical_error("allot_object() missed GC check",0);
else if(in_page(addr, gc_locals_region->start, 0, -1))
critical_error("gc locals underflow",0);

7
vm/ffi_test.c
View File

@ -260,3 +260,10 @@ int ffi_test_37(int (*f)(int, int, int))
fflush(stdout);
return global_var;
}
unsigned long long ffi_test_38(unsigned long long x, unsigned long long y)
{
return x * y;
}

4
vm/ffi_test.h
View File

@ -61,3 +61,7 @@ DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y);
struct test_struct_12 { int a; double x; };
DLLEXPORT double ffi_test_36(struct test_struct_12 x);
DLLEXPORT int ffi_test_37(int (*f)(int, int, int));
DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y);

2
vm/os-macosx-ppc.h
View File

@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov */
#include <ucontext.h>
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2)
#define MACH_EXC_STATE_TYPE ppc_exception_state_t

2
vm/os-macosx-x86.32.h
View File

@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov */
#include <ucontext.h>
#define MACH_EXC_STATE_TYPE i386_exception_state_t
#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT

2
vm/os-macosx-x86.64.h
View File

@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov and Daniel Ehrenberg */
#include <ucontext.h>
#define MACH_EXC_STATE_TYPE x86_exception_state64_t
#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64
#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT