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

README.txt

@@ -55,10 +55,13 @@ For X11 support, you need recent development libraries for libc,
 Pango, X11, and OpenGL. On a Debian-derived Linux distribution
 (like Ubuntu), you can use the following line to grab everything:
 
-    sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev
+    sudo apt-get install libc6-dev libpango1.0-dev libx11-dev libgl1-mesa-dev
+
+Note that if you are using a proprietary OpenGL driver, you should
+probably leave out the last package in the list.
 
 If your DISPLAY environment variable is set, the UI will start
-automatically:
+automatically when you run Factor:
 
   ./factor
 

basis/alien/libraries/libraries.factor

@@ -30,4 +30,5 @@ M: library dispose dll>> [ dispose ] when* ;
     libraries get delete-at* [ dispose ] [ drop ] if ;
 
 : add-library ( name path abi -- )
-    <library> swap libraries get [ delete-at ] [ set-at ] 2bi ;
+    [ 2drop remove-library ]
+    [ <library> swap libraries get set-at ] 3bi ;

basis/bootstrap/compiler/compiler.factor

@@ -10,6 +10,10 @@ math.order quotations quotations.private assocs.private ;
 FROM: compiler => enable-optimizer ;
 IN: bootstrap.compiler
 
+"profile-compiler" get [
+    "bootstrap.compiler.timing" require
+] when
+
 ! Don't bring this in when deploying, since it will store a
 ! reference to 'eval' in a global variable
 "deploy-vocab" get "staging" get or [

basis/bootstrap/compiler/timing/timing.factor

@@ -0,0 +1,38 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors compiler.cfg.builder compiler.cfg.linear-scan
+compiler.cfg.liveness compiler.cfg.mr compiler.cfg.optimizer
+compiler.cfg.stacks.finalize compiler.cfg.stacks.global
+compiler.codegen compiler.tree.builder compiler.tree.optimizer
+kernel make sequences tools.annotations tools.crossref ;
+IN: bootstrap.compiler.timing
+
+: passes ( word -- seq )
+    def>> uses [ vocabulary>> "compiler." head? ] filter ;
+
+: high-level-passes ( -- seq ) \ optimize-tree passes ;
+
+: low-level-passes ( -- seq ) \ optimize-cfg passes ;
+
+: machine-passes ( -- seq ) \ build-mr passes ;
+
+: linear-scan-passes ( -- seq ) \ (linear-scan) passes ;
+
+: all-passes ( -- seq )
+    [
+        \ build-tree ,
+        \ optimize-tree ,
+        high-level-passes %
+        \ build-cfg ,
+        \ compute-global-sets ,
+        \ finalize-stack-shuffling ,
+        \ optimize-cfg ,
+        low-level-passes %
+        \ compute-live-sets ,
+        \ build-mr ,
+        machine-passes %
+        linear-scan-passes %
+        \ generate ,
+    ] { } make ;
+
+all-passes [ [ reset ] [ add-timing ] bi ] each

basis/compiler/cfg/gc-checks/gc-checks-tests.factor

@@ -0,0 +1,26 @@
+IN: compiler.cfg.gc-checks.tests
+USING: compiler.cfg.gc-checks compiler.cfg.debugger
+compiler.cfg.registers compiler.cfg.instructions compiler.cfg
+compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
+namespaces accessors sequences ;
+
+: test-gc-checks ( -- )
+    cfg new 0 get >>entry
+    compute-predecessors
+    insert-gc-checks
+    drop ;
+
+V{
+    T{ ##inc-d f 3 }
+    T{ ##replace f V int-regs 0 D 1 }
+} 0 test-bb
+
+V{
+    T{ ##box-float f V int-regs 0 V int-regs 1 }
+} 1 test-bb
+
+0 get 1 get 1vector >>successors drop
+
+[ ] [ test-gc-checks ] unit-test
+
+[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test

basis/compiler/cfg/gc-checks/gc-checks.factor

@@ -1,17 +1,27 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs
+USING: accessors kernel sequences assocs fry
-compiler.cfg.rpo compiler.cfg.instructions
+compiler.cfg.rpo
-compiler.cfg.hats ;
+compiler.cfg.hats
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.stacks.uninitialized ;
 IN: compiler.cfg.gc-checks
 
-: gc? ( bb -- ? )
+: insert-gc-check? ( bb -- ? )
     instructions>> [ ##allocation? ] any? ;
 
-: insert-gc-check ( basic-block -- )
+: blocks-with-gc ( cfg -- bbs )
-    dup gc? [
+    post-order [ insert-gc-check? ] filter ;
-        [ i i f \ ##gc new-insn prefix ] change-instructions drop
+
-    ] [ drop ] if ;
+: insert-gc-check ( bb -- )
+    dup '[
+        i i f _ uninitialized-locs \ ##gc new-insn
+        prefix
+    ] change-instructions drop ;
 
 : insert-gc-checks ( cfg -- cfg' )
-    dup [ insert-gc-check ] each-basic-block ;
+    dup blocks-with-gc [
+        over compute-uninitialized-sets
+        [ insert-gc-check ] each
+    ] unless-empty ;

basis/compiler/cfg/instructions/instructions.factor

@@ -190,7 +190,7 @@ INSN: ##fixnum-add < ##fixnum-overflow ;
 INSN: ##fixnum-sub < ##fixnum-overflow ;
 INSN: ##fixnum-mul < ##fixnum-overflow ;
 
-INSN: ##gc temp1 temp2 live-values ;
+INSN: ##gc temp1 temp2 live-values uninitialized-locs ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;
@@ -219,7 +219,7 @@ INSN: _fixnum-mul < _fixnum-overflow ;
 
 TUPLE: spill-slot n ; C: <spill-slot> spill-slot
 
-INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size ;
+INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size uninitialized-locs ;
 
 ! These instructions operate on machine registers and not
 ! virtual registers

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics
     slots.private:set-slot
     strings.private:string-nth
     strings.private:set-string-nth-fast
-    ! classes.tuple.private:<tuple-boa>
+    classes.tuple.private:<tuple-boa>
-    ! arrays:<array>
+    arrays:<array>
-    ! byte-arrays:<byte-array>
+    byte-arrays:<byte-array>
-    ! byte-arrays:(byte-array)
+    byte-arrays:(byte-array)
-    ! kernel:<wrapper>
+    kernel:<wrapper>
     alien.accessors:alien-unsigned-1
     alien.accessors:set-alien-unsigned-1
     alien.accessors:alien-signed-1
@@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics
     alien.accessors:set-alien-unsigned-2
     alien.accessors:alien-signed-2
     alien.accessors:set-alien-signed-2
-    ! alien.accessors:alien-cell
+    alien.accessors:alien-cell
     alien.accessors:set-alien-cell
 } [ t "intrinsic" set-word-prop ] each
 
@@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics
         alien.accessors:set-alien-float
         alien.accessors:alien-double
         alien.accessors:set-alien-double
-    } drop f [ t "intrinsic" set-word-prop ] each ;
+    } [ t "intrinsic" set-word-prop ] each ;
 
 : enable-fixnum-log2 ( -- )
     \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;

basis/compiler/cfg/linearization/linearization.factor

@@ -98,6 +98,7 @@ M: ##dispatch linearize-insn
 
 M: ##gc linearize-insn
     nip
+    {
         [ temp1>> ]
         [ temp2>> ]
         [
@@ -106,7 +107,9 @@ M: ##gc linearize-insn
             [ count-gc-roots ]
             [ gc-roots-size ]
             tri
-    ] tri
+        ]
+        [ uninitialized-locs>> ]
+    } cleave
     _gc ;
 
 : linearize-basic-blocks ( cfg -- insns )

basis/compiler/cfg/ssa/destruction/copies/copies.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs hashtables fry kernel make namespaces
+USING: accessors assocs hashtables fry kernel make namespaces sets
 sequences compiler.cfg.ssa.destruction.state compiler.cfg.parallel-copy ;
 IN: compiler.cfg.ssa.destruction.copies
 
@@ -9,7 +9,7 @@ ERROR: bad-copy ;
 : compute-copies ( assoc -- assoc' )
     dup assoc-size <hashtable> [
         '[
-            [
+            prune [
                 2dup eq? [ 2drop ] [
                     _ 2dup key?
                     [ bad-copy ] [ set-at ] if

basis/compiler/cfg/ssa/destruction/destruction.factor

@@ -29,7 +29,7 @@ SYMBOL: seen
 
 :: visit-renaming ( dst assoc src bb -- )
     src seen get key? [
-        src dst bb waiting-for push-at
+        src dst bb add-waiting
         src assoc delete-at
     ] [ src seen get conjoin ] if ;
 

basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor

@@ -46,7 +46,7 @@ SYMBOLS: phi-union unioned-blocks ;
     2nip processed-name ;
 
 :: trivial-interference ( bb src dst -- )
-    dst src bb waiting-for push-at
+    dst src bb add-waiting
     src used-by-another get push ;
 
 :: add-to-renaming-set ( bb src dst -- )

basis/compiler/cfg/ssa/destruction/state/state.factor

@@ -14,3 +14,5 @@ SYMBOLS: processed-names waiting used-by-another renaming-sets ;
 : processed-name ( vreg -- ) processed-names get conjoin ;
 
 : waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ;
+
+: add-waiting ( dst src bb -- ) waiting-for push-at ;

basis/compiler/cfg/stacks/global/global.factor

@@ -26,7 +26,7 @@ M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union
 ! which are going to be overwritten.
 BACKWARD-ANALYSIS: kill
 
-M: kill-analysis transfer-set drop replace-set assoc-union ;
+M: kill-analysis transfer-set drop kill-set assoc-union ;
 
 ! Main word
 : compute-global-sets ( cfg -- cfg' )

basis/compiler/cfg/stacks/local/local.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math namespaces sets make sequences
+USING: accessors assocs kernel math math.order namespaces sets make
+sequences combinators fry
 compiler.cfg
 compiler.cfg.hats
 compiler.cfg.instructions
@@ -12,14 +13,18 @@ IN: compiler.cfg.stacks.local
 ! Local stack analysis. We build local peek and replace sets for every basic
 ! block while constructing the CFG.
 
-SYMBOLS: peek-sets replace-sets ;
+SYMBOLS: peek-sets replace-sets kill-sets ;
 
 SYMBOL: locs>vregs
 
 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
 
-TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
+TUPLE: current-height
+{ d initial: 0 }
+{ r initial: 0 }
+{ emit-d initial: 0 }
+{ emit-r initial: 0 } ;
 
 SYMBOLS: local-peek-set local-replace-set replace-mapping ;
 
@@ -72,20 +77,32 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
         bi
     ] if ;
 
+: compute-local-kill-set ( -- assoc )
+    basic-block get current-height get
+    [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
+    [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ]
+    [ drop local-replace-set get at ] 2tri
+    [ append unique dup ] dip update ;
+
 : begin-local-analysis ( -- )
     H{ } clone local-peek-set set
     H{ } clone local-replace-set set
     H{ } clone replace-mapping set
-    current-height get 0 >>emit-d 0 >>emit-r drop
+    current-height get
-    current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
+    [ 0 >>emit-d 0 >>emit-r drop ]
+    [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
 
 : end-local-analysis ( -- )
     emit-changes
-    local-peek-set get basic-block get peek-sets get set-at
+    basic-block get {
-    local-replace-set get basic-block get replace-sets get set-at ;
+        [ [ local-peek-set get ] dip peek-sets get set-at ]
+        [ [ local-replace-set get ] dip replace-sets get set-at ]
+        [ [ compute-local-kill-set ] dip kill-sets get set-at ]
+    } cleave ;
 
 : clone-current-height ( -- )
     current-height [ clone ] change ;
 
 : peek-set ( bb -- assoc ) peek-sets get at ;
 : replace-set ( bb -- assoc ) replace-sets get at ;
+: kill-set ( bb -- assoc ) kill-sets get at ;

basis/compiler/cfg/stacks/stacks.factor

@@ -13,6 +13,7 @@ IN: compiler.cfg.stacks
     H{ } clone rs-heights set
     H{ } clone peek-sets set
     H{ } clone replace-sets set
+    H{ } clone kill-sets set
     current-height new current-height set ;
 
 : end-stack-analysis ( -- )

basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor

@@ -0,0 +1,61 @@
+IN: compiler.cfg.stacks.uninitialized.tests
+USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger
+compiler.cfg.registers compiler.cfg.instructions compiler.cfg
+compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
+namespaces accessors sequences ;
+
+: test-uninitialized ( -- )
+    cfg new 0 get >>entry
+    compute-predecessors
+    compute-uninitialized-sets ;
+
+V{
+    T{ ##inc-d f 3 }
+} 0 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##replace f V int-regs 0 D 1 }
+    T{ ##replace f V int-regs 0 D 2 }
+    T{ ##inc-r f 1 }
+} 1 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##inc-d f 1 }
+} 2 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 1vector >>successors drop
+
+[ ] [ test-uninitialized ] unit-test
+
+[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test
+[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test
+
+! When merging, if a location is uninitialized in one branch and
+! initialized in another, we have to consider it uninitialized,
+! since it cannot be safely read from by a ##peek, or traced by GC.
+
+V{ } 0 test-bb
+
+V{
+    T{ ##inc-d f 1 }
+} 1 test-bb
+
+V{
+    T{ ##call f namestack }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##return }
+} 3 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+1 get 3 get 1vector >>successors drop
+2 get 3 get 1vector >>successors drop
+
+[ ] [ test-uninitialized ] unit-test
+
+[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test

basis/compiler/cfg/stacks/uninitialized/uninitialized.factor

@@ -0,0 +1,76 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences byte-arrays namespaces accessors classes math
+math.order fry arrays combinators compiler.cfg.registers
+compiler.cfg.instructions compiler.cfg.dataflow-analysis ;
+IN: compiler.cfg.stacks.uninitialized
+
+! Uninitialized stack location analysis.
+
+! Consider the following sequence of instructions:
+! ##inc-d 2
+! _gc
+! ##replace ... D 0
+! ##replace ... D 1
+! The GC check runs before stack locations 0 and 1 have been initialized,
+! and it needs to zero them out so that GC doesn't try to trace them.
+
+<PRIVATE
+
+GENERIC: visit-insn ( insn -- )
+
+: handle-inc ( n symbol -- )
+    [
+        swap {
+            { [ dup 0 < ] [ neg short tail ] }
+            { [ dup 0 > ] [ <byte-array> prepend ] }
+        } cond
+    ] change ;
+
+M: ##inc-d visit-insn n>> ds-loc handle-inc ;
+
+M: ##inc-r visit-insn n>> rs-loc handle-inc ;
+
+ERROR: uninitialized-peek insn ;
+
+M: ##peek visit-insn
+    dup loc>> [ n>> ] [ class get ] bi ?nth 0 =
+    [ uninitialized-peek ] [ drop ] if ;
+
+M: ##replace visit-insn
+    loc>> [ n>> ] [ class get ] bi
+    2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ;
+
+M: insn visit-insn drop ;
+
+: prepare ( pair -- )
+    [ first2 [ [ clone ] [ B{ } ] if* ] bi@ ] [ B{ } B{ } ] if*
+    [ ds-loc set ] [ rs-loc set ] bi* ;
+
+: visit-block ( bb -- ) instructions>> [ visit-insn ] each ;
+
+: finish ( -- pair ) ds-loc get rs-loc get 2array ;
+
+: (join-sets) ( seq1 seq2 -- seq )
+    2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ min ] 2map ;
+
+: (uninitialized-locs) ( seq quot -- seq' )
+    [ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline
+
+PRIVATE>
+
+FORWARD-ANALYSIS: uninitialized
+
+M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
+    drop [ prepare ] dip visit-block finish ;
+
+M: uninitialized-analysis join-sets ( sets analysis -- pair )
+    drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
+
+: uninitialized-locs ( bb -- locs )
+    uninitialized-in dup [
+        first2
+        [ [ <ds-loc> ] (uninitialized-locs) ]
+        [ [ <rs-loc> ] (uninitialized-locs) ]
+        bi* append
+    ] when ;

basis/compiler/codegen/codegen.factor

@@ -4,7 +4,7 @@ USING: namespaces make math math.order math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
 combinators classes.algebra alien alien.c-types alien.structs
 alien.strings alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture classes
+continuations.private fry cpu.architecture classes locals
 source-files.errors
 compiler.errors
 compiler.alien
@@ -215,13 +215,44 @@ M: ##write-barrier generate-insn
     [ table>> ]
     tri %write-barrier ;
 
+! GC checks
+: wipe-locs ( locs temp -- )
+    '[
+        _
+        [ 0 %load-immediate ]
+        [ swap [ %replace ] with each ] bi
+    ] unless-empty ;
+
+GENERIC# save-gc-root 1 ( gc-root operand temp -- )
+
+M:: spill-slot save-gc-root ( gc-root operand temp -- )
+    temp operand n>> %reload-integer
+    gc-root temp %save-gc-root ;
+
+M: object save-gc-root drop %save-gc-root ;
+
+: save-gc-roots ( gc-roots temp -- ) '[ _ save-gc-root ] assoc-each ;
+
+GENERIC# load-gc-root 1 ( gc-root operand temp -- )
+
+M:: spill-slot load-gc-root ( gc-root operand temp -- )
+    gc-root temp %load-gc-root
+    temp operand n>> %spill-integer ;
+
+M: object load-gc-root drop %load-gc-root ;
+
+: load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ;
+
 M: _gc generate-insn
+    "no-gc" define-label
     {
-        [ temp1>> ]
+        [ [ "no-gc" get ] dip [ temp1>> ] [ temp2>> ] bi %check-nursery ]
-        [ temp2>> ]
+        [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
-        [ gc-roots>> ]
+        [ [ gc-roots>> ] [ temp1>> ] bi save-gc-roots ]
-        [ gc-root-count>> ]
+        [ gc-root-count>> %call-gc ]
-    } cleave %gc ;
+        [ [ gc-roots>> ] [ temp1>> ] bi load-gc-roots ]
+    } cleave
+    "no-gc" resolve-label ;
 
 M: _loop-entry generate-insn drop %loop-entry ;
 

basis/compiler/tests/codegen.factor

@@ -2,7 +2,7 @@ USING: generalizations accessors arrays compiler kernel kernel.private
 math hashtables.private math.private namespaces sequences tools.test
 namespaces.private slots.private sequences.private byte-arrays alien
 alien.accessors layouts words definitions compiler.units io
-combinators vectors grouping make alien.c-types ;
+combinators vectors grouping make alien.c-types combinators.short-circuit ;
 QUALIFIED: namespaces.private
 IN: compiler.tests.codegen
 
@@ -346,3 +346,16 @@ cell 4 = [
         over rot [ drop ] [ nip ] if
     ] compile-call
 ] unit-test
+
+! Coalesing bug reduced from sequence-parser:take-sequence
+: coalescing-bug-1 ( a b c d -- a b c d )
+    3dup {
+        [ 2drop 0 < ]
+        [ [ drop ] 2dip length > ]
+        [ drop > ]
+    } 3|| [ 3drop f ] [ slice boa ] if swap [ [ length ] bi@ ] 2keep ;
+
+[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } -10 3 "hello" coalescing-bug-1 ] unit-test
+[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 0 7 "hello" coalescing-bug-1 ] unit-test
+[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 3 2 "hello" coalescing-bug-1 ] unit-test
+[ 2 3 T{ slice f 1 3 "hello" } { 1 2 3 } ] [ { 1 2 3 } 1 3 "hello" coalescing-bug-1 ] unit-test

basis/cpu/architecture/architecture.factor

@@ -128,7 +128,12 @@ HOOK: %alien-global cpu ( dst symbol library -- )
 
 HOOK: %allot cpu ( dst size class temp -- )
 HOOK: %write-barrier cpu ( src card# table -- )
-HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- )
+
+! GC checks
+HOOK: %check-nursery cpu ( label temp1 temp2 -- )
+HOOK: %save-gc-root cpu ( gc-root register -- )
+HOOK: %load-gc-root cpu ( gc-root register -- )
+HOOK: %call-gc cpu ( gc-root-count -- )
 
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )

basis/cpu/ppc/ppc.factor

@@ -4,10 +4,10 @@ USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
 alien alien.accessors alien.c-types literals cpu.architecture
 cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
-compiler.cfg.instructions compiler.constants compiler.codegen
+compiler.cfg.instructions compiler.cfg.comparisons
 compiler.codegen.fixup compiler.cfg.intrinsics
 compiler.cfg.stack-frame compiler.cfg.build-stack-frame
-compiler.units ;
+compiler.units compiler.constants compiler.codegen ;
 FROM: cpu.ppc.assembler => B ;
 IN: cpu.ppc
 
@@ -76,8 +76,12 @@ HOOK: reserved-area-size os ( -- n )
 : xt-save ( n -- i ) 2 cells - ;
 
 ! Next, we have the spill area as well as the FFI parameter area.
-! They overlap, since basic blocks with FFI calls will never
+! It is safe for them to overlap, since basic blocks with FFI calls
-! spill.
+! will never spill -- indeed, basic blocks with FFI calls do not
+! use vregs at all, and the FFI call is a stack analysis sync point.
+! In the future this will change and the stack frame logic will
+! need to be untangled somewhat.
+
 : param@ ( n -- x ) reserved-area-size + ; inline
 
 : param-save-size ( -- n ) 8 cells ; foldable
@@ -85,32 +89,30 @@ HOOK: reserved-area-size os ( -- n )
 : local@ ( n -- x )
     reserved-area-size param-save-size + + ; inline
 
-: spill-integer-base ( -- n )
-    stack-frame get spill-counts>> double-float-regs swap at
-    double-float-regs reg-size * ;
-
 : spill-integer@ ( n -- offset )
-    cells spill-integer-base + param@ ;
+    spill-integer-offset local@ ;
 
 : spill-float@ ( n -- offset )
-    double-float-regs reg-size * param@ ;
+    spill-float-offset local@ ;
 
 ! Some FP intrinsics need a temporary scratch area in the stack
-! frame, 8 bytes in size
+! frame, 8 bytes in size. This is in the param-save area so it
+! does not overlap with spill slots.
 : scratch@ ( n -- offset )
     stack-frame get total-size>>
     factor-area-size -
     param-save-size -
     + ;
 
+! GC root area
+: gc-root@ ( n -- offset )
+    gc-root-offset local@ ;
+
 ! Finally we have the linkage area
 HOOK: lr-save os ( -- n )
 
 M: ppc stack-frame-size ( stack-frame -- i )
-    [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+    (stack-frame-size)
-    [ params>> ]
-    [ return>> ]
-    tri + +
     param-save-size +
     reserved-area-size +
     factor-area-size +
@@ -176,95 +178,28 @@ M: ppc %or      OR ;
 M: ppc %or-imm  ORI ;
 M: ppc %xor     XOR ;
 M: ppc %xor-imm XORI ;
+M: ppc %shl     SLW ;
 M: ppc %shl-imm swapd SLWI ;
+M: ppc %shr     SRW ;
 M: ppc %shr-imm swapd SRWI ;
+M: ppc %sar     SRAW ;
 M: ppc %sar-imm SRAWI ;
 M: ppc %not     NOT ;
 
-: %alien-invoke-tail ( func dll -- )
+:: overflow-template ( label dst src1 src2 insn -- )
-    [ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ;
-
-:: exchange-regs ( r1 r2 -- )
-    scratch-reg r1 MR
-    r1 r2 MR
-    r2 scratch-reg MR ;
-
-: ?MR ( r1 r2 -- ) 2dup = [ 2drop ] [ MR ] if ;
-
-:: move>args ( src1 src2 -- )
-    {
-        { [ src1 4 = ] [ 3 src2 ?MR 3 4 exchange-regs ] }
-        { [ src1 3 = ] [ 4 src2 ?MR ] }
-        { [ src2 3 = ] [ 4 src1 ?MR 3 4 exchange-regs ] }
-        { [ src2 4 = ] [ 3 src1 ?MR ] }
-        [ 3 src1 MR 4 src2 MR ]
-    } cond ;
-
-: clear-xer ( -- )
     0 0 LI
-    0 MTXER ; inline
+    0 MTXER
+    dst src2 src1 insn call
+    label BO ; inline
 
-:: overflow-template ( src1 src2 insn func -- )
+M: ppc %fixnum-add ( label dst src1 src2 -- )
-    "no-overflow" define-label
+    [ ADDO. ] overflow-template ;
-    clear-xer
-    scratch-reg src2 src1 insn call
-    scratch-reg ds-reg 0 STW
-    "no-overflow" get BNO
-    src1 src2 move>args
-    %prepare-alien-invoke
-    func f %alien-invoke
-    "no-overflow" resolve-label ; inline
 
-:: overflow-template-tail ( src1 src2 insn func -- )
+M: ppc %fixnum-sub ( label dst src1 src2 -- )
-    "overflow" define-label
+    [ SUBFO. ] overflow-template ;
-    clear-xer
-    scratch-reg src2 src1 insn call
-    "overflow" get BO
-    scratch-reg ds-reg 0 STW
-    BLR
-    "overflow" resolve-label
-    src1 src2 move>args
-    %prepare-alien-invoke
-    func f %alien-invoke-tail ; inline
 
-M: ppc %fixnum-add ( src1 src2 -- )
+M: ppc %fixnum-mul ( label dst src1 src2 -- )
-    [ ADDO. ] "overflow_fixnum_add" overflow-template ;
+    [ MULLWO. ] overflow-template ;
-
-M: ppc %fixnum-add-tail ( src1 src2 -- )
-    [ ADDO. ] "overflow_fixnum_add" overflow-template-tail ;
-
-M: ppc %fixnum-sub ( src1 src2 -- )
-    [ SUBFO. ] "overflow_fixnum_subtract" overflow-template ;
-
-M: ppc %fixnum-sub-tail ( src1 src2 -- )
-    [ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
-
-M:: ppc %fixnum-mul ( src1 src2 temp1 temp2 -- )
-    "no-overflow" define-label
-    clear-xer
-    temp1 src1 tag-bits get SRAWI
-    temp2 temp1 src2 MULLWO.
-    temp2 ds-reg 0 STW
-    "no-overflow" get BNO
-    src2 src2 tag-bits get SRAWI
-    temp1 src2 move>args
-    %prepare-alien-invoke
-    "overflow_fixnum_multiply" f %alien-invoke
-    "no-overflow" resolve-label ;
-
-M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
-    "overflow" define-label
-    clear-xer
-    temp1 src1 tag-bits get SRAWI
-    temp2 temp1 src2 MULLWO.
-    "overflow" get BO
-    temp2 ds-reg 0 STW
-    BLR
-    "overflow" resolve-label
-    src2 src2 tag-bits get SRAWI
-    temp1 src2 move>args
-    %prepare-alien-invoke
-    "overflow_fixnum_multiply" f %alien-invoke-tail ;
 
 : bignum@ ( n -- offset ) cells bignum tag-number - ; inline
 
@@ -462,19 +397,27 @@ M:: ppc %write-barrier ( src card# table -- )
     src card# deck-bits SRWI
     table scratch-reg card# STBX ;
 
-M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- )
+M:: ppc %check-nursery ( label temp1 temp2 -- )
-    "end" define-label
     temp2 load-zone-ptr
     temp1 temp2 cell LWZ
     temp2 temp2 3 cells LWZ
-    temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
+    ! add ALLOT_BUFFER_ZONE to here
-    temp1 0 temp2 CMP ! is here >= end?
+    temp1 temp1 1024 ADDI
-    "end" get BLE
+    ! is here >= end?
+    temp1 0 temp2 CMP
+    label BLE ;
+
+M:: ppc %save-gc-root ( gc-root register -- )
+    register 1 gc-root gc-root@ STW ;
+
+M:: ppc %load-gc-root ( gc-root register -- )
+    register 1 gc-root gc-root@ LWZ ;
+
+M:: ppc %call-gc ( gc-root-count -- )
     %prepare-alien-invoke
-    0 3 LI
+    3 1 gc-root-base local@ ADDI
-    0 4 LI
+    gc-root-count 4 LI
-    "inline_gc" f %alien-invoke
+    "inline_gc" f %alien-invoke ;
-    "end" resolve-label ;
 
 M: ppc %prologue ( n -- )
     0 11 LOAD32 rc-absolute-ppc-2/2 rel-this

basis/cpu/x86/64/unix/bootstrap.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel namespaces system
-cpu.x86.assembler layouts vocabs parser ;
+cpu.x86.assembler cpu.x86.assembler.operands layouts vocabs parser ;
 IN: bootstrap.x86
 
 : stack-frame-size ( -- n ) 4 bootstrap-cells ;

basis/cpu/x86/64/winnt/winnt.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel layouts system math alien.c-types sequences
-compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
+compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86
+cpu.x86.assembler.operands ;
 IN: cpu.x86.64.winnt
 
 M: int-regs param-regs drop { RCX RDX R8 R9 } ;

basis/cpu/x86/assembler/assembler-tests.factor

@@ -71,6 +71,7 @@ IN: cpu.x86.assembler.tests
 
 ! sse shift instructions
 [ { HEX: 66 HEX: 0f HEX: 71 HEX: d0 HEX: 05 } ] [ [ XMM0 5 PSRLW ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: d1 HEX: c1 } ] [ [ XMM0 XMM1 PSRLW ] { } make ] unit-test
 
 ! sse comparison instructions 
 [ { HEX: 66 HEX: 0f HEX: c2 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 CMPLEPD ] { } make ] unit-test

basis/cpu/x86/assembler/assembler.factor

@@ -583,24 +583,57 @@ ALIAS: PINSRQ PINSRD
 : MAXPD      ( dest src -- ) HEX: 5f HEX: 66 2-operand-rm-sse ;
 : MAXSD      ( dest src -- ) HEX: 5f HEX: f2 2-operand-rm-sse ;
 : MAXSS      ( dest src -- ) HEX: 5f HEX: f3 2-operand-rm-sse ;
+: PUNPCKLBW  ( dest src -- ) HEX: 60 HEX: 66 2-operand-rm-sse ;
+: PUNPCKLWD  ( dest src -- ) HEX: 61 HEX: 66 2-operand-rm-sse ;
+: PUNPCKLDQ  ( dest src -- ) HEX: 62 HEX: 66 2-operand-rm-sse ;
+: PACKSSWB   ( dest src -- ) HEX: 63 HEX: 66 2-operand-rm-sse ;
+: PCMPGTB    ( dest src -- ) HEX: 64 HEX: 66 2-operand-rm-sse ;
+: PCMPGTW    ( dest src -- ) HEX: 65 HEX: 66 2-operand-rm-sse ;
+: PCMPGTD    ( dest src -- ) HEX: 66 HEX: 66 2-operand-rm-sse ;
+: PACKUSWB   ( dest src -- ) HEX: 67 HEX: 66 2-operand-rm-sse ;
+: PUNPCKHBW  ( dest src -- ) HEX: 68 HEX: 66 2-operand-rm-sse ;
+: PUNPCKHWD  ( dest src -- ) HEX: 69 HEX: 66 2-operand-rm-sse ;
+: PUNPCKHDQ  ( dest src -- ) HEX: 6a HEX: 66 2-operand-rm-sse ;
+: PACKSSDW   ( dest src -- ) HEX: 6b HEX: 66 2-operand-rm-sse ;
 : PUNPCKLQDQ ( dest src -- ) HEX: 6c HEX: 66 2-operand-rm-sse ;
 : PUNPCKHQDQ ( dest src -- ) HEX: 6d HEX: 66 2-operand-rm-sse ;
 
+: MOVD       ( dest src -- ) { HEX: 6e HEX: 7e } HEX: 66 2-operand-rm-mr-sse ;
 : MOVDQA     ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ;
 : MOVDQU     ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ;
 
 : PSHUFD     ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-rm-sse ;
 : PSHUFLW    ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ;
 : PSHUFHW    ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ;
-: PSRLW      ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ;
+
-: PSRAW      ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ;
+: (PSRLW-imm) ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ;
-: PSLLW      ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ;
+: (PSRAW-imm) ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ;
-: PSRLD      ( dest imm -- ) BIN: 010 HEX: 72 HEX: 66 2-operand-sse-shift ;
+: (PSLLW-imm) ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ;
-: PSRAD      ( dest imm -- ) BIN: 100 HEX: 72 HEX: 66 2-operand-sse-shift ;
+: (PSRLD-imm) ( dest imm -- ) BIN: 010 HEX: 72 HEX: 66 2-operand-sse-shift ;
-: PSLLD      ( dest imm -- ) BIN: 110 HEX: 72 HEX: 66 2-operand-sse-shift ;
+: (PSRAD-imm) ( dest imm -- ) BIN: 100 HEX: 72 HEX: 66 2-operand-sse-shift ;
-: PSRLQ      ( dest imm -- ) BIN: 010 HEX: 73 HEX: 66 2-operand-sse-shift ;
+: (PSLLD-imm) ( dest imm -- ) BIN: 110 HEX: 72 HEX: 66 2-operand-sse-shift ;
+: (PSRLQ-imm) ( dest imm -- ) BIN: 010 HEX: 73 HEX: 66 2-operand-sse-shift ;
+: (PSLLQ-imm) ( dest imm -- ) BIN: 110 HEX: 73 HEX: 66 2-operand-sse-shift ;
+
+: (PSRLW-reg) ( dest src -- ) HEX: d1 HEX: 66 2-operand-rm-sse ;
+: (PSRLD-reg) ( dest src -- ) HEX: d2 HEX: 66 2-operand-rm-sse ;
+: (PSRLQ-reg) ( dest src -- ) HEX: d3 HEX: 66 2-operand-rm-sse ;
+: (PSRAW-reg) ( dest src -- ) HEX: e1 HEX: 66 2-operand-rm-sse ;
+: (PSRAD-reg) ( dest src -- ) HEX: e2 HEX: 66 2-operand-rm-sse ;
+: (PSLLW-reg) ( dest src -- ) HEX: f1 HEX: 66 2-operand-rm-sse ;
+: (PSLLD-reg) ( dest src -- ) HEX: f2 HEX: 66 2-operand-rm-sse ;
+: (PSLLQ-reg) ( dest src -- ) HEX: f3 HEX: 66 2-operand-rm-sse ;
+
+: PSRLW ( dest src -- ) dup integer? [ (PSRLW-imm) ] [ (PSRLW-reg) ] if ;
+: PSRAW ( dest src -- ) dup integer? [ (PSRAW-imm) ] [ (PSRAW-reg) ] if ;
+: PSLLW ( dest src -- ) dup integer? [ (PSLLW-imm) ] [ (PSLLW-reg) ] if ;
+: PSRLD ( dest src -- ) dup integer? [ (PSRLD-imm) ] [ (PSRLD-reg) ] if ;
+: PSRAD ( dest src -- ) dup integer? [ (PSRAD-imm) ] [ (PSRAD-reg) ] if ;
+: PSLLD ( dest src -- ) dup integer? [ (PSLLD-imm) ] [ (PSLLD-reg) ] if ;
+: PSRLQ ( dest src -- ) dup integer? [ (PSRLQ-imm) ] [ (PSRLQ-reg) ] if ;
+: PSLLQ ( dest src -- ) dup integer? [ (PSLLQ-imm) ] [ (PSLLQ-reg) ] if ;
+
 : PSRLDQ     ( dest imm -- ) BIN: 011 HEX: 73 HEX: 66 2-operand-sse-shift ;
-: PSLLQ      ( dest imm -- ) BIN: 110 HEX: 73 HEX: 66 2-operand-sse-shift ;
 : PSLLDQ     ( dest imm -- ) BIN: 111 HEX: 73 HEX: 66 2-operand-sse-shift ;
 
 : PCMPEQB    ( dest src -- ) HEX: 74 HEX: 66 2-operand-rm-sse ;
@@ -611,11 +644,14 @@ ALIAS: PINSRQ PINSRD
 : HSUBPD     ( dest src -- ) HEX: 7d HEX: 66 2-operand-rm-sse ;
 : HSUBPS     ( dest src -- ) HEX: 7d HEX: f2 2-operand-rm-sse ;
 
+: FXSAVE     ( dest -- ) { BIN: 000 f { HEX: 0f HEX: ae } } 1-operand ;
+: FXRSTOR    ( src -- )  { BIN: 001 f { HEX: 0f HEX: ae } } 1-operand ;
 : LDMXCSR    ( src -- )  { BIN: 010 f { HEX: 0f HEX: ae } } 1-operand ;
 : STMXCSR    ( dest -- ) { BIN: 011 f { HEX: 0f HEX: ae } } 1-operand ;
 : LFENCE     ( -- ) HEX: 0f , HEX: ae , OCT: 350 , ;
 : MFENCE     ( -- ) HEX: 0f , HEX: ae , OCT: 360 , ;
 : SFENCE     ( -- ) HEX: 0f , HEX: ae , OCT: 370 , ;
+: CLFLUSH    ( dest -- ) { BIN: 111 f { HEX: 0f HEX: ae } } 1-operand ;
 
 : POPCNT     ( dest src -- ) HEX: b8 HEX: f3 2-operand-rm-sse ;
 
@@ -664,26 +700,46 @@ ALIAS: PINSRQ PINSRD
 : ADDSUBPD   ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ;
 : ADDSUBPS   ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ;
 : PADDQ      ( dest src -- ) HEX: d4 HEX: 66 2-operand-rm-sse ;
+: PMULLW     ( dest src -- ) HEX: d5 HEX: 66 2-operand-rm-sse ;
+: PMOVMSKB   ( dest src -- ) HEX: d7 HEX: 66 2-operand-rm-sse ;
+: PSUBUSB    ( dest src -- ) HEX: d8 HEX: 66 2-operand-rm-sse ;
+: PSUBUSW    ( dest src -- ) HEX: d9 HEX: 66 2-operand-rm-sse ;
 : PMINUB     ( dest src -- ) HEX: da HEX: 66 2-operand-rm-sse ;
+: PAND       ( dest src -- ) HEX: db HEX: 66 2-operand-rm-sse ;
+: PADDUSB    ( dest src -- ) HEX: dc HEX: 66 2-operand-rm-sse ;
+: PADDUSW    ( dest src -- ) HEX: dd HEX: 66 2-operand-rm-sse ;
 : PMAXUB     ( dest src -- ) HEX: de HEX: 66 2-operand-rm-sse ;
+: PANDN      ( dest src -- ) HEX: df HEX: 66 2-operand-rm-sse ;
 : PAVGB      ( dest src -- ) HEX: e0 HEX: 66 2-operand-rm-sse ;
 : PAVGW      ( dest src -- ) HEX: e3 HEX: 66 2-operand-rm-sse ;
 : PMULHUW    ( dest src -- ) HEX: e4 HEX: 66 2-operand-rm-sse ;
+: PMULHW     ( dest src -- ) HEX: e5 HEX: 66 2-operand-rm-sse ;
 : CVTTPD2DQ  ( dest src -- ) HEX: e6 HEX: 66 2-operand-rm-sse ;
 : CVTPD2DQ   ( dest src -- ) HEX: e6 HEX: f2 2-operand-rm-sse ;
 : CVTDQ2PD   ( dest src -- ) HEX: e6 HEX: f3 2-operand-rm-sse ;
 
 : MOVNTDQ    ( dest src -- ) HEX: e7 HEX: 66 2-operand-mr-sse ;
 
+: PSUBSB     ( dest src -- ) HEX: e8 HEX: 66 2-operand-rm-sse ;
+: PSUBSW     ( dest src -- ) HEX: e9 HEX: 66 2-operand-rm-sse ;
 : PMINSW     ( dest src -- ) HEX: ea HEX: 66 2-operand-rm-sse ;
+: POR        ( dest src -- ) HEX: eb HEX: 66 2-operand-rm-sse ;
+: PADDSB     ( dest src -- ) HEX: ec HEX: 66 2-operand-rm-sse ;
+: PADDSW     ( dest src -- ) HEX: ed HEX: 66 2-operand-rm-sse ;
 : PMAXSW     ( dest src -- ) HEX: ee HEX: 66 2-operand-rm-sse ;
+: PXOR       ( dest src -- ) HEX: ef HEX: 66 2-operand-rm-sse ;
 : LDDQU      ( dest src -- ) HEX: f0 HEX: f2 2-operand-rm-sse ;
 : PMULUDQ    ( dest src -- ) HEX: f4 HEX: 66 2-operand-rm-sse ;
+: PMADDWD    ( dest src -- ) HEX: f5 HEX: 66 2-operand-rm-sse ;
 : PSADBW     ( dest src -- ) HEX: f6 HEX: 66 2-operand-rm-sse ;
-
 : MASKMOVDQU ( dest src -- ) HEX: f7 HEX: 66 2-operand-rm-sse ;
-
+: PSUBB      ( dest src -- ) HEX: f8 HEX: 66 2-operand-rm-sse ;
+: PSUBW      ( dest src -- ) HEX: f9 HEX: 66 2-operand-rm-sse ;
+: PSUBD      ( dest src -- ) HEX: fa HEX: 66 2-operand-rm-sse ;
 : PSUBQ      ( dest src -- ) HEX: fb HEX: 66 2-operand-rm-sse ;
+: PADDB      ( dest src -- ) HEX: fc HEX: 66 2-operand-rm-sse ;
+: PADDW      ( dest src -- ) HEX: fd HEX: 66 2-operand-rm-sse ;
+: PADDD      ( dest src -- ) HEX: fe HEX: 66 2-operand-rm-sse ;
 
 ! x86-64 branch prediction hints
 

basis/cpu/x86/x86.factor

@@ -281,7 +281,7 @@ M: x86.32 has-small-reg?
         { 32 [ drop t ] }
     } case ;
 
-M: x86.64 has-small-reg? drop t ;
+M: x86.64 has-small-reg? 2drop t ;
 
 : small-reg-that-isn't ( exclude -- reg' )
     [ have-byte-regs ] dip
@@ -435,38 +435,19 @@ M:: x86 %write-barrier ( src card# table -- )
     table table [] MOV
     table card# [+] card-mark <byte> MOV ;
 
-:: check-nursery ( temp1 temp2 -- )
+M:: x86 %check-nursery ( label temp1 temp2 -- )
     temp1 load-zone-ptr
     temp2 temp1 cell [+] MOV
     temp2 1024 ADD
     temp1 temp1 3 cells [+] MOV
-    temp2 temp1 CMP ;
+    temp2 temp1 CMP
+    label JLE ;
 
-GENERIC# save-gc-root 1 ( gc-root operand temp -- )
+M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
 
-M:: spill-slot save-gc-root ( gc-root spill-slot temp -- )
+M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
-    temp spill-slot n>> spill-integer@ MOV
-    gc-root gc-root@ temp MOV ;
 
-M:: word save-gc-root ( gc-root register temp -- )
+M:: x86 %call-gc ( gc-root-count -- )
-    gc-root gc-root@ register MOV ;
-
-: save-gc-roots ( gc-roots temp -- )
-    '[ _ save-gc-root ] assoc-each ;
-
-GENERIC# load-gc-root 1 ( gc-root operand temp -- )
-
-M:: spill-slot load-gc-root ( gc-root spill-slot temp -- )
-    temp gc-root gc-root@ MOV
-    spill-slot n>> spill-integer@ temp MOV ;
-
-M:: word load-gc-root ( gc-root register temp -- )
-    register gc-root gc-root@ MOV ;
-
-: load-gc-roots ( gc-roots temp -- )
-    '[ _ load-gc-root ] assoc-each ;
-
-:: call-gc ( gc-root-count -- )
     ! Pass pointer to start of GC roots as first parameter
     param-reg-1 gc-root-base param@ LEA
     ! Pass number of roots as second parameter
@@ -475,15 +456,6 @@ M:: word load-gc-root ( gc-root register temp -- )
     %prepare-alien-invoke
     "inline_gc" f %alien-invoke ;
 
-M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- )
-    "end" define-label
-    temp1 temp2 check-nursery
-    "end" get JLE
-    gc-roots temp1 save-gc-roots
-    gc-root-count call-gc
-    gc-roots temp1 load-gc-roots
-    "end" resolve-label ;
-
 M: x86 %alien-global
     [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
 

core/classes/classes-docs.factor

@@ -35,6 +35,7 @@ $nl
 "You can ask a class for its superclass:"
 { $subsection superclass }
 { $subsection superclasses }
+{ $subsection subclass-of? }
 "Class predicates can be used to test instances directly:"
 { $subsection "class-predicates" }
 "There is a universal class which all objects are an instance of, and an empty class with no instances:"
@@ -102,7 +103,21 @@ HELP: superclasses
     }
 } ;
 
-{ superclass superclasses } related-words
+HELP: subclass-of?
+{ $values
+    { "class" class }
+    { "superclass" class }
+    { "?" boolean }
+}
+{ $description "Outputs a boolean value indicating whether " { $snippet "class" } " is at any level a subclass of " { $snippet "superclass" } "." }
+{ $examples 
+    { $example "USING: classes classes.tuple prettyprint words ;"
+               "tuple-class \\ class subclass-of? ."
+               "t"
+    }
+} ;
+
+{ superclass superclasses subclass-of? } related-words
 
 HELP: members
 { $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }

core/classes/classes.factor

@@ -59,6 +59,9 @@ M: predicate reset-word
 : superclasses ( class -- supers )
     [ superclass ] follow reverse ;
 
+: subclass-of? ( class superclass -- ? )
+    swap superclasses member? ;
+
 : members ( class -- seq )
     #! Output f for non-classes to work with algebra code
     dup class? [ "members" word-prop ] [ drop f ] if ;

core/io/pathnames/pathnames-docs.factor

@@ -23,6 +23,24 @@ HELP: file-name
     { $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
 } ;
 
+HELP: file-extension
+{ $values { "path" "a pathname string" } { "extension" string } }
+{ $description "Outputs the extension of " { $snippet "path" } ", or " { $link f } " if the filename has no extension." }
+{ $examples
+    { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-extension ." "f" }
+    { $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-extension ." "\"vbs\"" }
+} ;
+
+HELP: file-stem
+{ $values { "path" "a pathname string" } { "stem" string } }
+{ $description "Outputs the " { $link file-name } " of " { $snippet "filename" } " with the file extension removed, if any." }
+{ $examples
+    { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-stem ." "\"gcc\"" }
+    { $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-stem ." "\"gui\"" }
+} ;
+
+{ file-name file-stem file-extension } related-words
+
 HELP: path-components
 { $values { "path" "a pathnames string" } { "seq" sequence } }
 { $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ;
@@ -86,6 +104,8 @@ ARTICLE: "io.pathnames" "Pathname manipulation"
 "Pathname manipulation:"
 { $subsection parent-directory }
 { $subsection file-name }
+{ $subsection file-stem }
+{ $subsection file-extension }
 { $subsection last-path-separator }
 { $subsection path-components }
 { $subsection prepend-path }

core/io/pathnames/pathnames.factor

@@ -118,7 +118,10 @@ PRIVATE>
         ] if
     ] unless ;
 
-: file-extension ( filename -- extension )
+: file-stem ( path -- stem )
+    file-name "." split1-last drop ;
+
+: file-extension ( path -- extension )
     file-name "." split1-last nip ;
 
 : path-components ( path -- seq )

core/slots/slots.factor

@@ -26,8 +26,10 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
     [ drop define ]
     3bi ;
 
-: reader-quot ( slot-spec -- quot )
+GENERIC# reader-quot 1 ( class slot-spec -- quot )
-    [
+
+M: object reader-quot 
+    nip [
         dup offset>> ,
         \ slot ,
         dup class>> object bootstrap-word eq?
@@ -51,8 +53,12 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
 : define-reader ( class slot-spec -- )
     [ nip name>> define-reader-generic ]
     [
-        [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
+        {
-        define-typecheck
+            [ drop ]
+            [ nip name>> reader-word ]
+            [ reader-quot ]
+            [ nip reader-props ]
+        } 2cleave define-typecheck
     ] 2bi ;
 
 : writer-word ( name -- word )
@@ -83,8 +89,10 @@ ERROR: bad-slot-value value class ;
 : writer-quot/fixnum ( slot-spec -- )
     [ [ >fixnum ] dip ] % writer-quot/check ;
 
-: writer-quot ( slot-spec -- quot )
+GENERIC# writer-quot 1 ( class slot-spec -- quot )
-    [
+
+M: object writer-quot
+    nip [
         {
             { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] }
             { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] }
@@ -101,8 +109,12 @@ ERROR: bad-slot-value value class ;
 
 : define-writer ( class slot-spec -- )
     [ nip name>> define-writer-generic ] [
-        [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
+        {
-        define-typecheck
+            [ drop ]
+            [ nip name>> writer-word ]
+            [ writer-quot ]
+            [ nip writer-props ]
+        } 2cleave define-typecheck
     ] 2bi ;
 
 : setter-word ( name -- word )

extra/alien/marshall/syntax/syntax-docs.factor

@@ -18,6 +18,7 @@ HELP: CM-FUNCTION:
     "C-LIBRARY: exlib"
     ""
     "C-INCLUDE: <stdio.h>"
+    "C-INCLUDE: <stdlib.h>"
     "CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
     "    *x = a + b;"
     "    *y = a - b;"

extra/benchmark/pidigits/pidigits.factor

@@ -54,6 +54,6 @@ IN: benchmark.pidigits
     [ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ;
 
 : pidigits-main ( -- )
-    10000 pidigits ;
+    2000 pidigits ;
 
 MAIN: pidigits-main

extra/classes/tuple/change-tracking/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/classes/tuple/change-tracking/change-tracking-tests.factor

@@ -0,0 +1,10 @@
+USING: classes.tuple.change-tracking tools.test strings accessors kernel continuations ;
+IN: classes.tuple.change-tracking.tests
+
+TUPLE: resource < change-tracking-tuple
+    { pathname string } ;
+
+: <resource> ( pathname -- resource ) f swap resource boa ;
+
+[ t ] [ "foo" <resource> "bar" >>pathname changed?>> ] unit-test
+[ f ] [ "foo" <resource> [ 123 >>pathname ] [ drop ] recover changed?>> ] unit-test

extra/classes/tuple/change-tracking/change-tracking.factor

@@ -0,0 +1,23 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors classes classes.tuple fry kernel sequences slots ;
+IN: classes.tuple.change-tracking
+
+TUPLE: change-tracking-tuple
+    { changed? boolean } ;
+
+PREDICATE: change-tracking-tuple-class < tuple-class
+    change-tracking-tuple subclass-of? ;
+
+: changed? ( tuple -- changed? ) changed?>> ; inline
+: clear-changed ( tuple -- tuple ) f >>changed? ; inline
+
+: filter-changed ( sequence -- sequence' ) [ changed? ] filter ; inline
+
+<PRIVATE
+
+M: change-tracking-tuple-class writer-quot ( class slot-spec -- )
+    [ call-next-method ]
+    [ name>> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ;
+
+PRIVATE>
+

extra/classes/tuple/change-tracking/summary.txt

@@ -0,0 +1 @@
+Tuple classes that keep track of when they've been modified

extra/gpu/demos/bunny/bunny.factor

@@ -221,7 +221,7 @@ BEFORE: bunny-world begin-world
     bunny-uniforms boa ;
 
 : draw-bunny ( world -- )
-    T{ depth-state { comparison cmp-less } } set-gpu-state*
+    T{ depth-state { comparison cmp-less } } set-gpu-state
     
     [
         sobel>> framebuffer>> {
@@ -247,7 +247,7 @@ BEFORE: bunny-world begin-world
     sobel-uniforms boa ;
 
 : draw-sobel ( world -- )
-    T{ depth-state { comparison f } } set-gpu-state*
+    T{ depth-state { comparison f } } set-gpu-state
 
     sobel>> {
         { "primitive-mode" [ drop triangle-strip-mode ] }
@@ -260,7 +260,7 @@ BEFORE: bunny-world begin-world
     [ draw-bunny ] [ draw-sobel ] bi ;
 
 : draw-loading ( world -- )
-    T{ depth-state { comparison f } } set-gpu-state*
+    T{ depth-state { comparison f } } set-gpu-state
 
     loading>> {
         { "primitive-mode" [ drop triangle-strip-mode ] }

extra/gpu/demos/bunny/sobel.f.glsl

@@ -37,7 +37,7 @@ border_factor(vec2 texcoord)
 void
 main()
 {
-    gl_FragColor = /*vec4(border_factor(texcoord));*/ mix(
+    gl_FragColor = mix(
         texture2D(color_texture, texcoord),
         line_color,
         border_factor(texcoord)

extra/gpu/render/render.factor

@@ -8,7 +8,7 @@ gpu.textures gpu.textures.private half-floats images kernel
 lexer locals math math.order math.parser namespaces opengl
 opengl.gl parser quotations sequences slots sorting
 specialized-arrays.alien specialized-arrays.float specialized-arrays.int
-specialized-arrays.uint strings tr ui.gadgets.worlds variants
+specialized-arrays.uint strings ui.gadgets.worlds variants
 vocabs.parser words ;
 IN: gpu.render
 
@@ -338,8 +338,6 @@ DEFER: [bind-uniform-tuple]
     texture-unit' 
     value>>-quot { value-cleave 2cleave } append ;
 
-TR: hyphens>underscores "-" "_" ;
-
 :: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot )
     prefix uniform name>> append hyphens>underscores :> name
     uniform uniform-type>> :> type

extra/gpu/shaders/shaders.factor

@@ -8,7 +8,7 @@ io.encodings.ascii io.files io.pathnames kernel lexer literals
 locals math math.parser memoize multiline namespaces opengl
 opengl.gl opengl.shaders parser quotations sequences
 specialized-arrays.alien specialized-arrays.int splitting
-strings ui.gadgets.worlds variants vectors vocabs vocabs.loader
+strings tr ui.gadgets.worlds variants vectors vocabs vocabs.loader
 vocabs.parser words words.constant ;
 IN: gpu.shaders
 
@@ -65,6 +65,8 @@ MEMO: output-index ( program-instance output-name -- index )
 
 <PRIVATE
 
+TR: hyphens>underscores "-" "_" ;
+
 : gl-vertex-type ( component-type -- gl-type )
     {
         { ubyte-components          [ GL_UNSIGNED_BYTE  ] }
@@ -125,7 +127,7 @@ MEMO: output-index ( program-instance output-name -- index )
     } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
 
 :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
-    vertex-attribute name>>                 :> name
+    vertex-attribute name>> hyphens>underscores :> name
     vertex-attribute component-type>>           :> type
     type gl-vertex-type                         :> gl-type
     vertex-attribute dim>>                      :> dim

extra/gpu/textures/textures-docs.factor

@@ -1,5 +1,5 @@
 ! (c)2009 Joe Groff bsd license
-USING: byte-arrays classes gpu.buffers help.markup help.syntax
+USING: alien byte-arrays classes gpu.buffers help.markup help.syntax
 images kernel math ;
 IN: gpu.textures
 
@@ -228,7 +228,11 @@ HELP: texture-cube-map
 { texture-cube-map <texture-cube-map> } related-words
 
 HELP: texture-data
-{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } ". In addition to providing a " { $snippet "ptr" } " to CPU memory or a GPU " { $link buffer-ptr } ", the " { $link texture-data } " object also specifies the " { $link component-order } " and " { $link component-type } " of the referenced data." }
+{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } "."
+{ $list
+{ "The " { $snippet "ptr" } " slot references either CPU memory (as a " { $link byte-array } " or " { $link alien } ") or a GPU " { $link buffer-ptr } " that contains the image data." }
+{ "The " { $snippet "component-order" } " and " { $snippet "component-type" } " slots determine the " { $link component-order } " and " { $link component-type } " of the referenced data." }
+} }
 { $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
 
 { texture-data <texture-data> } related-words
@@ -254,15 +258,15 @@ HELP: texture-filter
 { $class-description { $snippet "texture-filter" } " values are used in a " { $link texture-parameters } " tuple to determine how a texture should be sampled between pixels or between levels of detail. " { $link filter-linear } " selects linear filtering, while " { $link filter-nearest } " selects nearest-neighbor sampling." } ;
 
 HELP: texture-parameters
-{ $class-description "When a " { $link texture } " is created, the following " { $snippet "texture-parameter" } "s are set to control how the texture is sampled:"
+{ $class-description "A " { $snippet "texture-parameters" } " tuple is supplied when constructing a " { $link texture } " to control the wrapping, filtering, and level-of-detail handling of the texture. These tuples have the following slots:"
 { $list
 { "The " { $snippet "wrap" } " slot determines how texture coordinates outside the 0.0 to 1.0 range are mapped to the texture image. The slot either contains a single " { $link texture-wrap } " value, which will apply to all three axes, or a sequence of up to three values, which will apply to the S, T, and R axes, respectively." }
-{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former controlling filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." }
+{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among the sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." }
 { "The " { $snippet "mag-filter" } " analogously determines how the texture image is filtered when sampled above its highest level of detail." }
 { "The " { $snippet "min-lod" } " and " { $snippet "max-lod" } " slots contain integer values that will clamp the range of levels of detail that will be sampled from the texture." }
 { "The " { $snippet "lod-bias" } " slot contains an integer value that will offset the levels of detail that would normally be sampled from the texture." }
 { "The " { $snippet "base-level" } " slot contains an integer value that identifies the highest level of detail for the image, typically zero." }
-{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithm of the dimensions of the highest level of detail image." }
+{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithms of the dimensions of the highest level of detail image." }
 } } ;
 
 { texture-parameters set-texture-parameters } related-words

extra/gpu/textures/textures.factor

@@ -26,14 +26,14 @@ TUPLE: cube-map-face
     { axis cube-map-axis read-only } ;
 C: <cube-map-face> cube-map-face
 
-UNION: texture-data-target
-    texture-1d texture-2d texture-3d cube-map-face ;
 UNION: texture-1d-data-target
     texture-1d ;
 UNION: texture-2d-data-target
     texture-2d texture-rectangle texture-1d-array cube-map-face ;
 UNION: texture-3d-data-target
     texture-3d texture-2d-array ;
+UNION: texture-data-target
+    texture-1d-data-target texture-2d-data-target texture-3d-data-target ;
 
 M: texture dispose
     [ [ delete-texture ] when* f ] change-handle drop ;

vm/image.cpp

@@ -53,10 +53,8 @@ cell code_relocation_base;
 
 static void load_code_heap(FILE *file, image_header *h, vm_parameters *p)
 {
-	cell good_size = h->code_size + (1 << 19);
+	if(h->code_size > p->code_size)
-
+		fatal_error("Code heap too small to fit image",h->code_size);
-	if(good_size > p->code_size)
-		p->code_size = good_size;
 
 	init_code_heap(p->code_size);