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

core/alien/compiler/compiler-tests.factor

@@ -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 ;

core/classes/algebra/algebra-tests.factor

@@ -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 ;
 

core/classes/algebra/algebra.factor

@@ -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? [
+    over [ classes-intersect? ] curry subset
-        2drop f
+    dup empty? [ 2drop f ] [
-    ] [
         tuck [ class< ] with all? [ peek ] [ drop f ] if
     ] if ;
 

core/cpu/architecture/architecture.factor

@@ -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 -- )

core/cpu/ppc/allot/allot.factor

@@ -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

core/cpu/x86/32/32.factor

@@ -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 ;
 

core/cpu/x86/64/64.factor

@@ -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 ;
 

core/cpu/x86/allot/allot.factor

@@ -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 ;
 

core/cpu/x86/architecture/architecture.factor

@@ -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

core/generator/registers/registers.factor

@@ -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 <=

core/generic/generic.factor

@@ -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 )

core/inference/backend/backend-docs.factor

@@ -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."

core/inference/backend/backend.factor

@@ -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 -- )
+: join-values ( #label -- )
-
+    calls>> [ node-in-d ] map meta-d get suffix
-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
     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
     ] [

core/inference/class/class-tests.factor

@@ -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

core/inference/class/class.factor

@@ -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>> ] bi@ eql? ]
-        [ literal-constraint-literal ] bi@ eql? >r
+        [ [ value>>   ] bi@ =    ]
-        [ literal-constraint-value ] bi@ = r> and
+        2bi and
-    ] [
+    ] [ 2drop f ] if ;
-        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 ;
+: `input node get in-d>> nth ;
-: `output node get node-out-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
+    [ interval>> ] [ value>> ] bi intersect-value-interval ;
-    swap interval-constraint-value intersect-value-interval ;
 
 : set-class-interval ( class value -- )
     over class? [
-        over "interval" word-prop [
+        >r "interval" word-prop r> over
-            >r "interval" word-prop r> set-value-interval*
+        [ set-value-interval* ] [ 2drop ] if
-        ] [ 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
+    [ class>> ] [ value>> ] bi intersect-value-class ;
-    swap class-constraint-value 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
+        [ >r class r> set-value-class* ]
-    2dup <literal-constraint> assume
+        [ >r literal-interval r> set-value-interval* ]
-    value-literals get set-at ;
+        [ <literal-constraint> assume ]
+        [ value-literals get set-at ]
+    } 2cleave ;
 
 M: literal-constraint apply-constraint
-    dup literal-constraint-literal
+    [ literal>> ] [ value>> ] bi set-value-literal* ;
-    swap literal-constraint-value 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*
+    dup value>> value-literal*
-    [ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
+    [ swap literal>> eql? ] [ 2drop f ] if ;
 
 M: class-constraint constraint-satisfied?
-    dup class-constraint-value value-class*
+    [ value>> value-class* ] [ class>> ] bi class< ;
-    swap class-constraint-class 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 )
+: extract-keys ( seq assoc -- newassoc )
-    dup length <hashtable> swap [
+    [ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
-        dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if
-    ] each nip f assoc-like ;
 
 : annotate-node ( node -- )
     #! Annotate the node with the currently-inferred set of
     #! value classes.
-    dup node-values
+    dup node-values {
-    value-intervals get over extract-keys pick set-node-intervals
+        [ value-intervals get extract-keys >>intervals ]
-    value-classes get over extract-keys pick set-node-classes
+        [ value-classes   get extract-keys >>classes   ]
-    value-literals get over extract-keys pick set-node-literals
+        [ value-literals  get extract-keys >>literals  ]
-    2drop ;
+        [ 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
+    [ compute-constraints ] keep
-    dup node-out-d swap output-classes
+    [ output-classes ] [ out-d>> ] bi
-    >r over intersect-classes
+    tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
-    r> swap intersect-intervals ;
 
 M: #push infer-classes-before
-    node-out-d
+    out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
-    [ [ 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 [
+        children>> length [ 0 `input literal, ] each
-            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
+    dup length 1 = [
-    null pad-all flip [ null [ class-or ] reduce ] map ;
+        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 ]
+    >r
-    (merge-intervals) r> set-intervals ;
+    [ 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
+    [ init-recursive-calls ]
-    #! entry to the recursive label.
+    [ [ 1array ] keep annotate-entry ] bi ;
-    [ 1array ] keep annotate-entry ;
+
+: 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 ]
+            [ nested-labels get push ]
-        [ infer-children ]
+            [ annotate-node ]
-        [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
+            [ infer-classes-before ]
-        [ node-child (infer-classes) ]
+            [ infer-label-loop ]
-    } cleave ;
+            [ 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 -- )
+: infer-classes ( node -- node )
-    f f f infer-classes-with ;
+    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
+    [ node-classes ] [ node-literals ] [ node-intervals ] tri
-    over node-literals
-    rot node-intervals
     infer-classes-with ;

core/inference/dataflow/dataflow.factor

@@ -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 ;
 

core/math/integers/integers-tests.factor

@@ -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

core/math/intervals/intervals.factor

@@ -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 ] }

core/math/math-docs.factor

@@ -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 >= }
+{ $subsection >= } ;
-"Inexact comparison:"
-{ $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" } "." }

core/math/math.factor

@@ -55,26 +55,26 @@ GENERIC: zero? ( x -- ? ) foldable
 
 M: object zero? drop f ;
 
-: 1+ ( x -- y ) 1 + ; foldable
+: 1+ ( x -- y ) 1 + ; inline
-: 1- ( x -- y ) 1 - ; foldable
+: 1- ( x -- y ) 1 - ; inline
-: 2/ ( x -- y ) -1 shift ; foldable
+: 2/ ( x -- y ) -1 shift ; inline
-: sq ( x -- y ) dup * ; foldable
+: sq ( x -- y ) dup * ; inline
-: neg ( x -- -x ) 0 swap - ; foldable
+: neg ( x -- -x ) 0 swap - ; inline
-: recip ( x -- y ) 1 swap / ; foldable
+: 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
+: max ( x y -- z ) [ > ] most ; inline
-: min ( x y -- z ) [ < ] most ; foldable
+: 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
 

core/optimizer/collect/collect.factor

@@ -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 ;
+

core/optimizer/control/control-tests.factor

@@ -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

core/optimizer/control/control.factor

@@ -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

core/optimizer/def-use/def-use-tests.factor

@@ -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? ;

core/optimizer/def-use/def-use.factor

@@ -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 -- )
+: compute-def-use ( node -- node )
-    H{ } clone def-use set [ node-def-use ] each-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 in-d>> uses-values ] 
-    dup node-out-d defs-values
+        [ dup in-r>> uses-values ] 
-    node-out-r defs-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 in-d>> ,
-        dup node-child node-out-d ,
+        dup node-child out-d>> ,
-        dup collect-recursion [ node-in-d , ] each
+        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* 
-    [
+    [ [ in-d>> empty? ] [ out-d>> empty? ] bi and ] prune-if ;
-        dup node-in-d empty? swap node-out-d empty? 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 ;

core/optimizer/inlining/inlining-tests.factor

@@ -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

core/optimizer/inlining/inlining.factor

@@ -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
+combinators classes classes.algebra generic.math
-optimizer.def-use optimizer.backend generic.standard
+optimizer.math.partial continuations optimizer.def-use
-optimizer.specializers optimizer.def-use optimizer.pattern-match
+optimizer.backend generic.standard optimizer.specializers
-generic.standard optimizer.control kernel.private ;
+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 -- ? )
+: inlining-math-method ( #call word -- quot/f )
-    math-class-max swap specific-method ;
+    swap node-input-classes
-
-: inline-math-method ( #call word -- node )
-    over node-input-classes
     [ first normalize-math-class ]
     [ second normalize-math-class ] bi
-    3dup math-both-known?
+    3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
-    [ math-method f splice-quot ]
+
-    [ 2drop 2drop t ] 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 [

core/optimizer/known-words/known-words.factor

@@ -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
 

core/optimizer/math/math.factor

@@ -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 } {
+\ mod {
-    { { number 1 } [ 2drop 0 ] }
+    { { integer 1 } [ 2drop 0 ] }
-} define-identities
+} 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 )
+: math-output-class ( node upgrades -- newclass )
-    #! if min is f, it means we just want to use the declared
+    >r
-    #! output class from the "infer-effect".
+    in-d>> null [ value-class* math-closure math-class-max ] reduce
-    dup [
+    dup r> at swap or ;
-        swap node-in-d
-        [ value-class* math-closure math-class-max ] each
-    ] [
-        2drop f
-    ] if ;
 
 : 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 )
+: math-output-class/interval-1 ( node word -- classes intervals )
-    pick >r
+    [ drop { } math-output-class 1array ]
-    >r over r>
+    [ math-output-interval-1 1array ] 2bi ;
-    math-output-interval-1
-    >r math-output-class r>
-    r> post-process ; inline
 
 {
-    { 1+ integer interval-1+ }
+    { bitnot interval-bitnot }
-    { 1- integer interval-1- }
+    { fixnum-bitnot interval-bitnot }
-    { neg integer interval-neg }
+    { bignum-bitnot interval-bitnot }
-    { 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 }
 } [
-    first3 [
+    [ math-output-class/interval-1 ] curry
-        math-output-class/interval-1
+    "output-classes" set-word-prop
-    ] 2curry "output-classes" set-word-prop
+] assoc-each
-] 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+ }
+    { + { { fixnum integer } } interval+ }
-    { - integer interval- }
+    { - { { fixnum integer } } interval- }
-    { * integer interval* }
+    { * { { fixnum integer } } interval* }
-    { / rational interval/ }
+    { / { { fixnum rational } { integer rational } } interval/ }
-    { /i integer interval/i }
+    { /i { { fixnum integer } } interval/i }
-
+    { shift { { fixnum integer } } interval-shift-safe }
-    { 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 }
 } [
     first3 [
-        math-output-class/interval-2
+        [
-    ] 2curry "output-classes" set-word-prop
+            math-output-class/interval-2
-] each
+        ] 2curry "output-classes" set-word-prop
-
+    ] 2curry each-derived-op
-{ 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
 ] each
 
 : real-value? ( value -- n ? )
@@ -235,22 +197,18 @@ generic.standard system ;
     r> post-process ; inline
 
 {
-    { mod fixnum mod-range }
+    { mod { } mod-range }
-    { fixnum-mod f mod-range }
+    { rem { { fixnum integer } } rem-range }
-    { bignum-mod f mod-range }
-    { float-mod f mod-range }
 
-    { rem integer rem-range }
+    { bitand { } bitand-range }
-
+    { bitor { } f }
-    { bitand fixnum bitand-range }
+    { bitxor { } f }
-    { fixnum-bitand f bitand-range }
-
-    { bitor fixnum f }
-    { bitxor fixnum 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
+    first3 [
-    [
+        [
-        [ comparison-constraints ] with-scope
+            [ comparison-constraints ] with-scope
-    ] 2curry "constraints" set-word-prop
+        ] 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
+    { fixnum-shift [ fixnum-shift-fast ] }
-    ! 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 ] }
 } [
     [
         [ 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 ,
+            dup [ dupd foldable-comparison? ] curry ,
-    ] { } make 1array define-optimizers
+            [ 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 -- ? )
+: coerced-to-fixnum? ( #call -- ? )
-    \ >fixnum consumed-by? ;
+    dup dup node-in-d [ node-class integer class< ] with all?
+    [ \ >fixnum consumed-by? ] [ drop f ] if ;
 
 {
-    { fixnum+ [ fixnum+fast ] }
+    { + [ [ >fixnum ] bi@ fixnum+fast ] }
-    { fixnum- [ fixnum-fast ] }
+    { - [ [ >fixnum ] bi@ fixnum-fast ] }
-    { fixnum* [ fixnum*fast ] }
+    { * [ [ >fixnum ] bi@ fixnum*fast ] }
 } [
-    [
+    >r derived-ops r> [
         [
-            dup remove-overflow-check?
+            [
-            over coereced-to-fixnum? or
+                dup remove-overflow-check?
-        ] ,
+                over coerced-to-fixnum? or
-        [ f splice-quot ] curry ,
+            ] ,
-    ] { } make 1array define-optimizers
+            [ f splice-quot ] curry ,
+        ] { } make 1array define-optimizers
+    ] curry each
 ] assoc-each
 
-: fixnum-shift-fast-pos? ( node -- ? )
+: convert-rem-to-and? ( #call -- ? )
-    #! Shifting 1 to the left won't overflow if the shift
+    dup node-in-d {
-    #! count is small enough
+        { [ 2dup first node-class integer class< not ] [ f ] }
-    dup dup node-in-d first node-literal 1 = [
+        { [ 2dup second node-literal integer? not ] [ f ] }
-        dup node-in-d second node-interval
+        { [ 2dup second node-literal power-of-2? not ] [ f ] }
-        0 cell-bits tag-bits get - 2 - [a,b] interval-subset?
+        [ t ]
-    ] [ drop f ] if ;
+    } cond 2nip ;
 
-: fixnum-shift-fast-neg? ( node -- ? )
+: convert-mod-to-and? ( #call -- ? )
-    #! Shifting any number to the right won't overflow if the
+    dup dup node-in-d first node-interval 0 [a,inf] interval-subset?
-    #! shift count is small enough
+    [ convert-rem-to-and? ] [ drop f ] if ;
-    dup node-in-d second node-interval
-    cell-bits 1- neg 0 [a,b] interval-subset? ;
 
-: fixnum-shift-fast? ( node -- ? )
+: convert-mod-to-and ( #call -- node )
-    dup fixnum-shift-fast-pos?
+    dup
-    [ drop t ] [ fixnum-shift-fast-neg? ] if ;
+    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

core/optimizer/math/partial/partial-tests.factor

@@ -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

core/optimizer/math/partial/partial.factor

@@ -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

core/optimizer/optimizer-tests.factor

@@ -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

core/optimizer/optimizer.factor

@@ -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
+        detect-loops
-        dup infer-classes
+        infer-classes
+
         optimizer-changed off
         optimize-nodes
         optimizer-changed get

extra/benchmark/recursive/recursive.factor

@@ -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+
+        { [ over zero? ] [ nip 1+ ] }
-    ] [
+        { [ dup zero? ] [ drop 1- 1 ack ] }
-        dup zero? [
+        [ [ drop 1- ] [ 1- ack ] 2bi ack ]
-            drop 1- 1 ack
+    } cond ; inline
-        ] [
-            dupd 1- ack >r 1- r> ack
-        ] if
-    ] if ;
 
 : tak ( x y z -- t )
-    2over swap < [
+    2over <= [
-        [ rot 1- -rot tak ] 3keep
-        [ -rot 1- -rot tak ] 3keep
-        1- -rot tak
-        tak
-    ] [
         2nip
-    ] if ;
+    ] [
+        [  rot 1- -rot tak ]
+        [ -rot 1- -rot tak ]
+        [      1- -rot tak ]
+        3tri
+        tak
+    ] if ; inline
 
 : recursive ( n -- )
-    3 over ack . flush
+    [ 3 swap ack . flush ]
-    dup 27.0 + fib . flush
+    [ 27.0 + fib . flush ]
-    1-
+    [ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
-    dup 3 * over 2 * rot tak . flush
     3 fib . flush
     3.0 2.0 1.0 tak . flush ;
 
+HINTS: recursive fixnum ;
+
 : recursive-main 11 recursive ;
 
 MAIN: recursive-main

extra/editors/vim/vim.factor

@@ -1,5 +1,5 @@
 USING: definitions io io.launcher kernel math math.parser
-namespaces parser prettyprint sequences editors ;
+namespaces parser prettyprint sequences editors accessors ;
 IN: editors.vim
 
 SYMBOL: vim-path
@@ -17,8 +17,9 @@ M: vim vim-command ( file line -- array )
 
 : vim-location ( file line -- )
     vim-command
-    vim-detach get-global
+    <process> swap >>command
-    [ run-detached ] [ run-process ] if drop ;
+    vim-detach get-global [ t >>detached ] when
+    try-process ;
 
 "vim" vim-path set-global
 [ vim-location ] edit-hook set-global

extra/io/launcher/launcher-docs.factor

@@ -113,6 +113,8 @@ HELP: try-process
 { $values { "desc" "a launch descriptor" } }
 { $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ;
 
+{ run-process try-process run-detached } related-words
+
 HELP: kill-process
 { $values { "process" process } }
 { $description "Kills a running process. Does nothing if the process has already exited." } ;
@@ -171,6 +173,7 @@ ARTICLE: "io.launcher.launch" "Launching processes"
 "Launching processes:"
 { $subsection run-process }
 { $subsection try-process }
+{ $subsection run-detached }
 "Redirecting standard input and output to a pipe:"
 { $subsection <process-stream> }
 { $subsection with-process-stream } ;

extra/io/launcher/launcher.factor

@@ -127,10 +127,7 @@ HOOK: run-process* io-backend ( process -- handle )
     run-detached
     dup detached>> [ dup wait-for-process drop ] unless ;
 
-TUPLE: process-failed code ;
+ERROR: process-failed code ;
-
-: process-failed ( code -- * )
-    \ process-failed boa throw ;
 
 : try-process ( desc -- )
     run-process wait-for-process dup zero?

extra/math/functions/functions-docs.factor

@@ -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" } "." }

extra/math/functions/functions-tests.factor

@@ -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

extra/math/functions/functions.factor

@@ -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

extra/newfx/newfx.factor

@@ -155,6 +155,23 @@ METHOD: as-mutate { object object assoc }       set-at ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: prefix-on ( elt seq -- seq ) swap prefix ;
+: suffix-on ( elt seq -- seq ) swap suffix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 1st 0 at ;
+: 2nd 1 at ;
+: 3rd 2 at ;
+: 4th 3 at ;
+: 5th 4 at ;
+: 6th 5 at ;
+: 7th 6 at ;
+: 8th 7 at ;
+: 9th 8 at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 ! A note about the 'mutate' qualifier. Other words also technically mutate
 ! their primary object. However, the 'mutate' qualifier is supposed to
 ! indicate that this is the main objective of the word, as a side effect.

extra/project-euler/150/150.factor

@@ -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
+                    x z + table nth-unsafe
-                    [ y z + 1+ swap nth ]
+                    [ y z + 1+ swap nth-unsafe ]
-                    [ y        swap nth ] bi -
+                    [ y        swap nth-unsafe ] bi -
-                ] map partial-sums infimum
+                ] map partial-sum-infimum
             ] map-infimum
         ] map-infimum
     ] ;
 
+HINTS: (euler150) fixnum ;
+
 : euler150 ( -- n )
     1000 (euler150) ;

extra/shell/parser/parser.factor

@@ -1,27 +1,43 @@
 
-USING: kernel arrays strings sequences sequences.deep peg peg.ebnf ;
+USING: kernel arrays strings sequences sequences.deep accessors peg peg.ebnf
+       newfx ;
 
 IN: shell.parser
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-TUPLE: incantation command stdin stdout background ;
+TUPLE: basic-expr         command  stdin stdout background ;
-
+TUPLE: pipeline-expr      commands stdin stdout background ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 TUPLE: single-quoted-expr expr ;
 TUPLE: double-quoted-expr expr ;
 TUPLE: back-quoted-expr   expr ;
 TUPLE: glob-expr          expr ;
-
+TUPLE: variable-expr      expr ;
-TUPLE: variable-expr expr ;
+TUPLE: factor-expr        expr ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: <single-quoted-expr> single-quoted-expr boa ;
+: ast>basic-expr ( ast -- obj ) first4 basic-expr boa ;
-: <double-quoted-expr> double-quoted-expr boa ;
+
-: <back-quoted-expr>   back-quoted-expr boa ;
+: ast>pipeline-expr ( ast -- obj )
-: <glob-expr>          glob-expr boa ;
+  pipeline-expr new
+    over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
+    over 2nd >>stdin
+    over 5th   >>stdout
+    swap 6th   >>background ;
+
+: ast>single-quoted-expr ( ast -- obj )
+  2nd >string single-quoted-expr boa ;
+
+: ast>double-quoted-expr ( ast -- obj )
+  2nd >string double-quoted-expr boa ;
+
+: ast>back-quoted-expr ( ast -- obj )
+  2nd >string back-quoted-expr boa ;
+
+: ast>glob-expr ( ast -- obj ) flatten concat glob-expr boa ;
+
+: ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -33,45 +49,43 @@ tab   = "\t"
 
 white = (space | tab)
 
-whitespace = (white)* => [[ drop ignore ]]
+_ = (white)* => [[ drop ignore ]]
 
-squote        = "'"
+sq = "'"
+dq = '"'
+bq = "`"
 
-single-quoted = squote (!(squote) .)* squote => [[ second >string <single-quoted-expr> ]]
+single-quoted = sq (!(sq) .)* sq => [[ ast>single-quoted-expr ]]
+double-quoted = dq (!(dq) .)* dq => [[ ast>double-quoted-expr ]]
+back-quoted   = bq (!(bq) .)* bq => [[ ast>back-quoted-expr   ]]
 
-dquote        = '"'
+variable = "$" other => [[ ast>variable-expr ]]
-
-double-quoted = dquote (!(dquote) .)* dquote => [[ second >string <double-quoted-expr> ]]
-
-bquote = "`"
-
-back-quoted = bquote (!(bquote) .)* bquote => [[ second >string <back-quoted-expr> ]]
-
-variable = "$" other => [[ second variable-expr boa ]]
 
 glob-char = ("*" | "?")
 
 non-glob-char = !(glob-char | white) .
 
-glob-beginning-string = (non-glob-char)* [[ >string ]]
+glob-beginning-string = (non-glob-char)* => [[ >string ]]
 
-glob-rest-string = (non-glob-char)+ [[ >string ]]
+glob-rest-string = (non-glob-char)+ => [[ >string ]]
 
-glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ flatten concat <glob-expr> ]]
+glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ ast>glob-expr ]]
 
-other = (!(white | "&" | ">" | ">>" | "<") .)+ => [[ >string ]]
+other = (!(white | "&" | ">" | ">>" | "<" | "|") .)+ => [[ >string ]]
 
 element = (single-quoted | double-quoted | back-quoted | variable | glob | other)
 
-to-file = ">" whitespace other => [[ second ]]
+command = (element _)+
 
-in-file = "<" whitespace other => [[ second ]]
+to-file = ">"  _ other => [[ second ]]
+in-file = "<"  _ other => [[ second ]]
+ap-file = ">>" _ other => [[ second ]]
 
-ap-file = ">>" whitespace other  => [[ second ]]
+basic = _ command _ (in-file)? _ (to-file | ap-file)? _ ("&")? => [[ ast>basic-expr ]]
 
-redirection = (in-file)? whitespace (to-file | ap-file)?
+pipeline = _ command _ (in-file)? _ "|" _ (command _ "|" _)* command _ (to-file | ap-file)? _ ("&")? => [[ ast>pipeline-expr ]]
 
-line = (element whitespace)+ (in-file)? whitespace (to-file | ap-file)? whitespace ("&")? => [[ first4 incantation boa ]]
+submission = (pipeline | basic)
 
 ;EBNF
 

extra/shell/shell.factor

@@ -49,22 +49,44 @@ METHOD: expand { object } ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: run-incantation ( incantation -- )
+: run-sword ( basic-expr -- ) command>> unclip "shell" lookup execute ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-foreground ( process -- )
+  [ try-process ] [ print-error drop ] recover ;
+
+: run-background ( process -- ) run-detached drop ;
+
+: run-basic-expr ( basic-expr -- )
   <process>
     over command>> expansion >>command
     over stdin>>             >>stdin
     over stdout>>            >>stdout
   swap background>>
-    [ run-detached drop ]
+    [ run-background ]
-    [ [ try-process ] [ print-error drop ] recover ]
+    [ run-foreground ]
   if ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: chant ( incantation -- )
+: basic-chant ( basic-expr -- )
   dup command>> first swords member-of?
-    [ command>> unclip "shell" lookup execute ]
+    [ run-sword ]
-    [ run-incantation ]
+    [ run-basic-expr ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pipeline-chant ( pipeline-chant -- )
+  drop "ix: pipelines not supported" print ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chant ( obj -- )
+  dup basic-expr?
+    [ basic-chant    ]
+    [ pipeline-chant ]
   if ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

vm/data_gc.c

@@ -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());

vm/data_gc.h

@@ -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);

vm/debug.c

@@ -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]);

vm/errors.c

@@ -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);

vm/ffi_test.c

@@ -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;
+}
+
+

vm/ffi_test.h

@@ -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);

vm/os-macosx-ppc.h

@@ -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

vm/os-macosx-x86.32.h

@@ -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

vm/os-macosx-x86.64.h

@@ -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