diff --git a/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib b/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib index 1096a1224a..1d9f641c11 100644 --- a/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib +++ b/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib @@ -3,15 +3,13 @@ IBFramework Version - 629 + 677 IBOldestOS 5 IBOpenObjects - - 305 - + IBSystem Version - 9G55 + 9J61 targetFramework IBCocoaFramework diff --git a/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib b/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib index c30c9e4bfd..1659393f2e 100644 Binary files a/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib and b/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib differ diff --git a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib index bf3d2a6560..34be3452ee 100644 --- a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib +++ b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/classes.nib @@ -1,17 +1,32 @@ -{ - IBClasses = ( - { - ACTIONS = { - newFactorWorkspace = id; - runFactorFile = id; - saveFactorImage = id; - saveFactorImageAs = id; - showFactorHelp = id; - }; - CLASS = FirstResponder; - LANGUAGE = ObjC; - SUPERCLASS = NSObject; - } - ); - IBVersion = 1; -} \ No newline at end of file + + + + + IBClasses + + + ACTIONS + + newFactorWorkspace + id + runFactorFile + id + saveFactorImage + id + saveFactorImageAs + id + showFactorHelp + id + + CLASS + FirstResponder + LANGUAGE + ObjC + SUPERCLASS + NSObject + + + IBVersion + 1 + + diff --git a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib index 3a18202826..86277eb8a8 100644 --- a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib +++ b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/info.nib @@ -1,21 +1,18 @@ - + - IBDocumentLocation - 1266 155 525 491 0 0 2560 1578 - IBEditorPositions - - 29 - 326 905 270 44 0 0 2560 1578 - IBFramework Version - 439.0 + 677 + IBOldestOS + 5 IBOpenObjects - 29 + 293 IBSystem Version - 8R218 + 9J61 + targetFramework + IBCocoaFramework diff --git a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib index 34abd139a6..9929114395 100644 Binary files a/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib and b/Factor.app/Contents/Resources/English.lproj/MiniFactor.nib/keyedobjects.nib differ diff --git a/basis/cairo/cairo.factor b/basis/cairo/cairo.factor index 3a41f0bcf9..074798a1b2 100755 --- a/basis/cairo/cairo.factor +++ b/basis/cairo/cairo.factor @@ -31,7 +31,8 @@ ERROR: cairo-error message ; &cairo_destroy @ ] make-memory-bitmap - BGRA >>component-order ; inline + BGRA >>component-order + ubyte-components >>component-type ; inline : dummy-cairo ( -- cr ) #! Sometimes we want a dummy context; eg with Pango, we want diff --git a/basis/cocoa/windows/windows-docs.factor b/basis/cocoa/windows/windows-docs.factor index 39bd631b19..690fe9b5aa 100644 --- a/basis/cocoa/windows/windows-docs.factor +++ b/basis/cocoa/windows/windows-docs.factor @@ -2,11 +2,11 @@ USING: help.markup help.syntax ; IN: cocoa.windows HELP: -{ $values { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } } +{ $values { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "class" "an Objective-C class" } { "window" "an " { $snippet "NSWindow" } } } { $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions." } ; HELP: -{ $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } } +{ $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "window" "an " { $snippet "NSWindow" } } } { $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions, containing the given view." } ; ARTICLE: "cocoa-window-utils" "Cocoa window utilities" diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index ea918a7424..e55f42e774 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -40,16 +40,23 @@ ERROR: already-spilled ; 2dup key? [ already-spilled ] [ set-at ] if ; : insert-spill ( live-interval -- ) - [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ; + { + [ reg>> ] + [ vreg>> reg-class>> ] + [ spill-to>> ] + [ end>> ] + } cleave f swap \ _spill boa , ; : handle-spill ( live-interval -- ) dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ; : insert-copy ( live-interval -- ) - [ split-next>> reg>> ] - [ reg>> ] - [ vreg>> reg-class>> ] - tri _copy ; + { + [ split-next>> reg>> ] + [ reg>> ] + [ vreg>> reg-class>> ] + [ end>> ] + } cleave f swap \ _copy boa , ; : handle-copy ( live-interval -- ) dup [ spill-to>> not ] [ split-next>> ] bi and @@ -68,7 +75,12 @@ ERROR: already-reloaded ; 2dup key? [ delete-at ] [ already-reloaded ] if ; : insert-reload ( live-interval -- ) - [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ; + { + [ reg>> ] + [ vreg>> reg-class>> ] + [ reload-from>> ] + [ end>> ] + } cleave f swap \ _reload boa , ; : handle-reload ( live-interval -- ) dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ; @@ -102,7 +114,9 @@ M: vreg-insn assign-registers-in-insn >>regs drop ; : compute-live-registers ( insn -- regs ) - active-intervals register-mapping ; + [ active-intervals ] [ temp-vregs ] bi + '[ vreg>> _ memq? not ] filter + register-mapping ; : compute-live-spill-slots ( -- spill-slots ) spill-slots get values [ values ] map concat @@ -139,6 +153,6 @@ M: insn assign-registers-in-insn drop ; ] V{ } make ] change-instructions drop ; -: assign-registers ( rpo live-intervals -- ) - init-assignment +: assign-registers ( live-intervals rpo -- ) + [ init-assignment ] dip [ assign-registers-in-block ] each ; diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor index dad87b62ae..401241722f 100644 --- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences sets arrays math strings fry -prettyprint compiler.cfg.linear-scan.live-intervals -compiler.cfg.linear-scan.allocation ; +namespaces prettyprint compiler.cfg.linear-scan.live-intervals +compiler.cfg.linear-scan.allocation compiler.cfg ; IN: compiler.cfg.linear-scan.debugger : check-assigned ( live-intervals -- ) @@ -34,3 +34,6 @@ IN: compiler.cfg.linear-scan.debugger : live-intervals. ( seq -- ) [ interval-picture ] map simple-table. ; + +: test-bb ( insns n -- ) + [ swap >>number swap >>instructions ] keep set ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index b43294818b..1f8112a893 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -10,6 +10,8 @@ compiler.cfg.registers compiler.cfg.liveness compiler.cfg.predecessors compiler.cfg.rpo +compiler.cfg.linearization +compiler.cfg.debugger compiler.cfg.linear-scan compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation @@ -410,7 +412,7 @@ SYMBOL: max-uses [ ] [ 10 20 2 400 random-test ] unit-test [ ] [ 10 20 4 300 random-test ] unit-test -USING: math.private compiler.cfg.debugger ; +USING: math.private ; [ ] [ [ float+ float>fixnum 3 fixnum*fast ] @@ -1417,194 +1419,149 @@ USING: math.private compiler.cfg.debugger ; ! Bug in live spill slots calculation -T{ basic-block - { id 205651 } - { number 0 } - { instructions V{ T{ ##prologue } T{ ##branch } } } -} 0 set +V{ T{ ##prologue } T{ ##branch } } 0 test-bb -T{ basic-block - { id 205652 } - { number 1 } - { instructions - V{ - T{ ##peek - { dst V int-regs 703128 } - { loc D 1 } - } - T{ ##peek - { dst V int-regs 703129 } - { loc D 0 } - } - T{ ##copy - { dst V int-regs 703134 } - { src V int-regs 703128 } - } - T{ ##copy - { dst V int-regs 703135 } - { src V int-regs 703129 } - } - T{ ##compare-imm-branch - { src1 V int-regs 703128 } - { src2 5 } - { cc cc/= } - } - } - } -} 1 set +V{ + T{ ##peek + { dst V int-regs 703128 } + { loc D 1 } + } + T{ ##peek + { dst V int-regs 703129 } + { loc D 0 } + } + T{ ##copy + { dst V int-regs 703134 } + { src V int-regs 703128 } + } + T{ ##copy + { dst V int-regs 703135 } + { src V int-regs 703129 } + } + T{ ##compare-imm-branch + { src1 V int-regs 703128 } + { src2 5 } + { cc cc/= } + } +} 1 test-bb -T{ basic-block - { id 205653 } - { number 2 } - { instructions - V{ - T{ ##copy - { dst V int-regs 703134 } - { src V int-regs 703129 } - } - T{ ##copy - { dst V int-regs 703135 } - { src V int-regs 703128 } - } - T{ ##branch } - } - } -} 2 set +V{ + T{ ##copy + { dst V int-regs 703134 } + { src V int-regs 703129 } + } + T{ ##copy + { dst V int-regs 703135 } + { src V int-regs 703128 } + } + T{ ##branch } +} 2 test-bb -T{ basic-block - { id 205655 } - { number 3 } - { instructions - V{ - T{ ##replace - { src V int-regs 703134 } - { loc D 0 } - } - T{ ##replace - { src V int-regs 703135 } - { loc D 1 } - } - T{ ##epilogue } - T{ ##return } - } - } -} 3 set +V{ + T{ ##replace + { src V int-regs 703134 } + { loc D 0 } + } + T{ ##replace + { src V int-regs 703135 } + { loc D 1 } + } + T{ ##epilogue } + T{ ##return } +} 3 test-bb 1 get 1vector 0 get (>>successors) 2 get 3 get V{ } 2sequence 1 get (>>successors) 3 get 1vector 2 get (>>successors) +SYMBOL: linear-scan-result + :: test-linear-scan-on-cfg ( regs -- ) [ ] [ cfg new 0 get >>entry compute-predecessors compute-liveness - reverse-post-order + dup reverse-post-order { { int-regs regs } } (linear-scan) + flatten-cfg 1array mr. ] unit-test ; -{ 1 2 } test-linear-scan-on-cfg +! This test has a critical edge -- do we care about these? + +! { 1 2 } test-linear-scan-on-cfg ! Bug in inactive interval handling ! [ rot dup [ -rot ] when ] -T{ basic-block - { id 201486 } - { number 0 } - { instructions V{ T{ ##prologue } T{ ##branch } } } -} 0 set +V{ T{ ##prologue } T{ ##branch } } 0 test-bb -T{ basic-block - { id 201487 } - { number 1 } - { instructions - V{ - T{ ##peek - { dst V int-regs 689473 } - { loc D 2 } - } - T{ ##peek - { dst V int-regs 689474 } - { loc D 1 } - } - T{ ##peek - { dst V int-regs 689475 } - { loc D 0 } - } - T{ ##compare-imm-branch - { src1 V int-regs 689473 } - { src2 5 } - { cc cc/= } - } - } - } -} 1 set +V{ + T{ ##peek + { dst V int-regs 689473 } + { loc D 2 } + } + T{ ##peek + { dst V int-regs 689474 } + { loc D 1 } + } + T{ ##peek + { dst V int-regs 689475 } + { loc D 0 } + } + T{ ##compare-imm-branch + { src1 V int-regs 689473 } + { src2 5 } + { cc cc/= } + } +} 1 test-bb -T{ basic-block - { id 201488 } - { number 2 } - { instructions - V{ - T{ ##copy - { dst V int-regs 689481 } - { src V int-regs 689475 } - } - T{ ##copy - { dst V int-regs 689482 } - { src V int-regs 689474 } - } - T{ ##copy - { dst V int-regs 689483 } - { src V int-regs 689473 } - } - T{ ##branch } - } - } -} 2 set +V{ + T{ ##copy + { dst V int-regs 689481 } + { src V int-regs 689475 } + } + T{ ##copy + { dst V int-regs 689482 } + { src V int-regs 689474 } + } + T{ ##copy + { dst V int-regs 689483 } + { src V int-regs 689473 } + } + T{ ##branch } +} 2 test-bb -T{ basic-block - { id 201489 } - { number 3 } - { instructions - V{ - T{ ##copy - { dst V int-regs 689481 } - { src V int-regs 689473 } - } - T{ ##copy - { dst V int-regs 689482 } - { src V int-regs 689475 } - } - T{ ##copy - { dst V int-regs 689483 } - { src V int-regs 689474 } - } - T{ ##branch } - } - } -} 3 set +V{ + T{ ##copy + { dst V int-regs 689481 } + { src V int-regs 689473 } + } + T{ ##copy + { dst V int-regs 689482 } + { src V int-regs 689475 } + } + T{ ##copy + { dst V int-regs 689483 } + { src V int-regs 689474 } + } + T{ ##branch } +} 3 test-bb -T{ basic-block - { id 201490 } - { number 4 } - { instructions - V{ - T{ ##replace - { src V int-regs 689481 } - { loc D 0 } - } - T{ ##replace - { src V int-regs 689482 } - { loc D 1 } - } - T{ ##replace - { src V int-regs 689483 } - { loc D 2 } - } - T{ ##epilogue } - T{ ##return } - } - } -} 4 set +V{ + T{ ##replace + { src V int-regs 689481 } + { loc D 0 } + } + T{ ##replace + { src V int-regs 689482 } + { loc D 1 } + } + T{ ##replace + { src V int-regs 689483 } + { loc D 2 } + } + T{ ##epilogue } + T{ ##return } +} 4 test-bb : test-diamond ( -- ) 1 get 1vector 0 get (>>successors) @@ -1625,102 +1582,78 @@ T{ basic-block { instructions V{ T{ ##prologue } T{ ##branch } } } } 0 set -T{ basic-block - { id 201538 } - { number 1 } - { instructions - V{ - T{ ##peek - { dst V int-regs 689600 } - { loc D 1 } - } - T{ ##peek - { dst V int-regs 689601 } - { loc D 0 } - } - T{ ##compare-imm-branch - { src1 V int-regs 689600 } - { src2 5 } - { cc cc/= } - } - } - } -} 1 set +V{ + T{ ##peek + { dst V int-regs 689600 } + { loc D 1 } + } + T{ ##peek + { dst V int-regs 689601 } + { loc D 0 } + } + T{ ##compare-imm-branch + { src1 V int-regs 689600 } + { src2 5 } + { cc cc/= } + } +} 1 test-bb -T{ basic-block - { id 201539 } - { number 2 } - { instructions - V{ - T{ ##peek - { dst V int-regs 689604 } - { loc D 2 } - } - T{ ##copy - { dst V int-regs 689607 } - { src V int-regs 689604 } - } - T{ ##copy - { dst V int-regs 689608 } - { src V int-regs 689600 } - } - T{ ##copy - { dst V int-regs 689610 } - { src V int-regs 689601 } - } - T{ ##branch } - } - } -} 2 set +V{ + T{ ##peek + { dst V int-regs 689604 } + { loc D 2 } + } + T{ ##copy + { dst V int-regs 689607 } + { src V int-regs 689604 } + } + T{ ##copy + { dst V int-regs 689608 } + { src V int-regs 689600 } + } + T{ ##copy + { dst V int-regs 689610 } + { src V int-regs 689601 } + } + T{ ##branch } +} 2 test-bb -T{ basic-block - { id 201540 } - { number 3 } - { instructions - V{ - T{ ##peek - { dst V int-regs 689609 } - { loc D 2 } - } - T{ ##copy - { dst V int-regs 689607 } - { src V int-regs 689600 } - } - T{ ##copy - { dst V int-regs 689608 } - { src V int-regs 689601 } - } - T{ ##copy - { dst V int-regs 689610 } - { src V int-regs 689609 } - } - T{ ##branch } - } - } -} 3 set +V{ + T{ ##peek + { dst V int-regs 689609 } + { loc D 2 } + } + T{ ##copy + { dst V int-regs 689607 } + { src V int-regs 689600 } + } + T{ ##copy + { dst V int-regs 689608 } + { src V int-regs 689601 } + } + T{ ##copy + { dst V int-regs 689610 } + { src V int-regs 689609 } + } + T{ ##branch } +} 3 test-bb -T{ basic-block - { id 201541 } - { number 4 } - { instructions - V{ - T{ ##replace - { src V int-regs 689607 } - { loc D 0 } - } - T{ ##replace - { src V int-regs 689608 } - { loc D 1 } - } - T{ ##replace - { src V int-regs 689610 } - { loc D 2 } - } - T{ ##epilogue } - T{ ##return } - } - } -} 4 set +V{ + T{ ##replace + { src V int-regs 689607 } + { loc D 0 } + } + T{ ##replace + { src V int-regs 689608 } + { loc D 1 } + } + T{ ##replace + { src V int-regs 689610 } + { loc D 2 } + } + T{ ##epilogue } + T{ ##return } +} 4 test-bb test-diamond @@ -1729,76 +1662,130 @@ test-diamond ! compute-live-registers was inaccurate since it didn't take ! lifetime holes into account -T{ basic-block - { id 0 } - { number 0 } - { instructions V{ T{ ##prologue } T{ ##branch } } } -} 0 set +V{ T{ ##prologue } T{ ##branch } } 0 test-bb -T{ basic-block - { id 1 } - { instructions - V{ - T{ ##peek - { dst V int-regs 0 } - { loc D 0 } - } - T{ ##compare-imm-branch - { src1 V int-regs 0 } - { src2 5 } - { cc cc/= } - } - } - } -} 1 set +V{ + T{ ##peek + { dst V int-regs 0 } + { loc D 0 } + } + T{ ##compare-imm-branch + { src1 V int-regs 0 } + { src2 5 } + { cc cc/= } + } +} 1 test-bb -T{ basic-block - { id 2 } - { instructions - V{ - T{ ##peek - { dst V int-regs 1 } - { loc D 1 } - } - T{ ##copy - { dst V int-regs 2 } - { src V int-regs 1 } - } - T{ ##branch } - } - } -} 2 set +V{ + T{ ##peek + { dst V int-regs 1 } + { loc D 1 } + } + T{ ##copy + { dst V int-regs 2 } + { src V int-regs 1 } + } + T{ ##branch } +} 2 test-bb -T{ basic-block - { id 3 } - { instructions - V{ - T{ ##peek - { dst V int-regs 3 } - { loc D 2 } - } - T{ ##copy - { dst V int-regs 2 } - { src V int-regs 3 } - } - T{ ##branch } - } - } -} 3 set +V{ + T{ ##peek + { dst V int-regs 3 } + { loc D 2 } + } + T{ ##copy + { dst V int-regs 2 } + { src V int-regs 3 } + } + T{ ##branch } +} 3 test-bb -T{ basic-block - { id 4 } - { instructions - V{ - T{ ##replace - { src V int-regs 2 } - { loc D 0 } - } - T{ ##return } - } - } -} 4 set +V{ + T{ ##replace + { src V int-regs 2 } + { loc D 0 } + } + T{ ##return } +} 4 test-bb test-diamond -{ 1 2 3 4 } test-linear-scan-on-cfg \ No newline at end of file +{ 1 2 3 4 } test-linear-scan-on-cfg + +! Inactive interval handling: splitting active interval +! if it fits in lifetime hole only partially + +V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb + +V{ + T{ ##peek f V int-regs 2 R 0 } + T{ ##compare-imm-branch f V int-regs 2 5 cc= } +} 1 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 2 test-bb + + +V{ + T{ ##peek f V int-regs 1 D 1 } + T{ ##peek f V int-regs 0 D 0 } + T{ ##replace f V int-regs 1 D 2 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace f V int-regs 3 R 2 } + T{ ##replace f V int-regs 0 D 0 } + T{ ##return } +} 4 test-bb + +test-diamond + +{ 1 2 } test-linear-scan-on-cfg + +USING: classes ; + +[ ] [ + 1 get instructions>> first regs>> V int-regs 0 swap at + 2 get instructions>> first regs>> V int-regs 1 swap at assert= +] unit-test + +[ _copy ] [ 3 get instructions>> second class ] unit-test + +! Resolve pass; make sure the spilling is done correctly +V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb + +V{ + T{ ##peek f V int-regs 2 R 0 } + T{ ##compare-imm-branch f V int-regs 2 5 cc= } +} 1 test-bb + +V{ + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace f V int-regs 3 R 1 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##peek f V int-regs 0 D 0 } + T{ ##replace f V int-regs 1 D 2 } + T{ ##replace f V int-regs 0 D 2 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace f V int-regs 3 R 2 } + T{ ##return } +} 4 test-bb + +test-diamond + +{ 1 2 } test-linear-scan-on-cfg + +[ _spill ] [ 2 get instructions>> first class ] unit-test + +[ _spill ] [ 3 get instructions>> second class ] unit-test + +[ _reload ] [ 4 get instructions>> first class ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 3a0a7f8770..2d3ad41b22 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces make +USING: kernel accessors namespaces make locals cpu.architecture compiler.cfg compiler.cfg.rpo @@ -9,7 +9,8 @@ compiler.cfg.linear-scan.numbering compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state -compiler.cfg.linear-scan.assignment ; +compiler.cfg.linear-scan.assignment +compiler.cfg.linear-scan.resolve ; IN: compiler.cfg.linear-scan ! References: @@ -26,12 +27,11 @@ IN: compiler.cfg.linear-scan ! by Omri Traub, Glenn Holloway, Michael D. Smith ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435 -: (linear-scan) ( rpo machine-registers -- ) - [ - dup number-instructions - dup compute-live-intervals - ] dip - allocate-registers assign-registers ; +:: (linear-scan) ( rpo machine-registers -- ) + rpo number-instructions + rpo compute-live-intervals machine-registers allocate-registers + rpo assign-registers + rpo resolve-data-flow ; : linear-scan ( cfg -- cfg' ) [ diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor new file mode 100644 index 0000000000..3e98d6c9f0 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -0,0 +1,65 @@ +USING: accessors arrays compiler.cfg compiler.cfg.instructions +compiler.cfg.linear-scan.debugger +compiler.cfg.linear-scan.live-intervals +compiler.cfg.linear-scan.numbering +compiler.cfg.linear-scan.resolve compiler.cfg.predecessors +compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel +namespaces tools.test vectors ; +IN: compiler.cfg.linear-scan.resolve.tests + +[ { 1 2 3 4 5 6 } ] [ + { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array +] unit-test + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##replace f V int-regs 0 D 1 } + T{ ##return } +} 1 test-bb + +1 get 1vector 0 get (>>successors) + +cfg new 0 get >>entry +compute-predecessors +dup reverse-post-order number-instructions +drop + +CONSTANT: test-live-interval-1 +T{ live-interval + { start 0 } + { end 6 } + { uses V{ 0 6 } } + { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } } + { spill-to 0 } + { vreg V int-regs 0 } +} + +[ f ] [ + 0 get test-live-interval-1 spill-to +] unit-test + +[ 0 ] [ + 1 get test-live-interval-1 spill-to +] unit-test + +CONSTANT: test-live-interval-2 +T{ live-interval + { start 0 } + { end 6 } + { uses V{ 0 6 } } + { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } } + { reload-from 0 } + { vreg V int-regs 0 } +} + +[ 0 ] [ + 0 get test-live-interval-2 reload-from +] unit-test + +[ f ] [ + 1 get test-live-interval-2 reload-from +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index df2dbb1198..55a2eab41b 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -1,34 +1,118 @@ ! Copyright (C) 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math namespaces sequences -compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness ; +classes.tuple classes.parser parser fry words make arrays +locals combinators compiler.cfg.linear-scan.live-intervals +compiler.cfg.liveness compiler.cfg.instructions ; IN: compiler.cfg.linear-scan.resolve -: add-mapping ( from to -- ) - 2drop - ; +<< + +TUPLE: operation from to reg-class ; + +SYNTAX: OPERATION: + CREATE-CLASS dup save-location + [ operation { } define-tuple-class ] + [ + [ scan-word scan-word ] keep + '[ + [ [ _ execute ] [ _ execute ] bi* ] + [ vreg>> reg-class>> ] + bi _ boa , + ] (( from to -- )) define-declared + ] bi ; + +>> + +: reload-from ( bb live-interval -- n/f ) + 2dup [ block-from ] [ start>> ] bi* = + [ nip reload-from>> ] [ 2drop f ] if ; + +: spill-to ( bb live-interval -- n/f ) + 2dup [ block-to ] [ end>> ] bi* = + [ nip spill-to>> ] [ 2drop f ] if ; + +OPERATION: memory->memory spill-to>> reload-from>> +OPERATION: register->memory reg>> reload-from>> +OPERATION: memory->register spill-to>> reg>> +OPERATION: register->register reg>> reg>> + +:: add-mapping ( bb1 bb2 li1 li2 -- ) + bb2 li2 reload-from [ + bb1 li1 spill-to + [ li1 li2 memory->memory ] + [ li1 li2 register->memory ] if + ] [ + bb1 li1 spill-to + [ li1 li2 memory->register ] + [ li1 li2 register->register ] if + ] if ; : resolve-value-data-flow ( bb to vreg -- ) + [ 2dup ] dip live-intervals get at [ [ block-to ] dip child-interval-at ] [ [ block-from ] dip child-interval-at ] - bi-curry bi* 2dup = [ 2drop ] [ - add-mapping + bi-curry bi* 2dup eq? [ 2drop 2drop ] [ add-mapping ] if ; + +: compute-mappings ( bb to -- mappings ) + [ + dup live-in keys + [ resolve-value-data-flow ] with with each + ] { } make ; + +GENERIC: >insn ( operation -- ) + +M: memory->memory >insn + [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ; + +M: register->memory >insn + [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ; + +M: memory->register >insn + [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ; + +M: register->register >insn + [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; + +: mapping-instructions ( mappings -- insns ) + [ [ >insn ] each ] { } make ; + +: fork? ( from to -- ? ) + [ successors>> length 1 >= ] + [ predecessors>> length 1 = ] bi* and ; inline + +: insert-position/fork ( from to -- before after ) + nip instructions>> [ >array ] [ dup delete-all ] bi swap ; + +: join? ( from to -- ? ) + [ successors>> length 1 = ] + [ predecessors>> length 1 >= ] bi* and ; inline + +: insert-position/join ( from to -- before after ) + drop instructions>> dup pop 1array ; + +: insert-position ( bb to -- before after ) + { + { [ 2dup fork? ] [ insert-position/fork ] } + { [ 2dup join? ] [ insert-position/join ] } + } cond ; + +: 3append-here ( seq2 seq1 seq3 -- ) + #! Mutate seq1 + swap '[ _ push-all ] bi@ ; + +: perform-mappings ( mappings bb to -- ) + pick empty? [ 3drop ] [ + [ mapping-instructions ] 2dip + insert-position 3append-here ] if ; -: resolve-mappings ( bb to -- ) - 2drop - ; - : resolve-edge-data-flow ( bb to -- ) - [ dup live-in [ resolve-value-data-flow ] with with each ] - [ resolve-mappings ] - 2bi ; + [ compute-mappings ] [ perform-mappings ] 2bi ; : resolve-block-data-flow ( bb -- ) - dup successors>> [ - resolve-edge-data-flow - ] with each ; + dup successors>> [ resolve-edge-data-flow ] with each ; : resolve-data-flow ( rpo -- ) [ resolve-block-data-flow ] each ; \ No newline at end of file diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index 6612a43dca..a7bec04798 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -140,4 +140,5 @@ PRIVATE> : make-bitmap-image ( dim quot -- image ) '[ &CGContextRelease @ ] make-memory-bitmap - ARGB >>component-order ; inline + ARGB >>component-order + ubyte-components >>component-type ; inline diff --git a/basis/images/bitmap/loading/loading.factor b/basis/images/bitmap/loading/loading.factor index b0bd501f09..31975fa3f0 100644 --- a/basis/images/bitmap/loading/loading.factor +++ b/basis/images/bitmap/loading/loading.factor @@ -370,5 +370,5 @@ M: bitmap-image load-image* ( path bitmap-image -- bitmap ) [ loading-bitmap>bytes >>bitmap ] [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ] [ header>> height>> 0 < not >>upside-down? ] - [ bitmap>component-order >>component-order ] + [ bitmap>component-order >>component-order ubyte-components >>component-type ] } cleave ; diff --git a/basis/images/images-tests.factor b/basis/images/images-tests.factor index 8918dcb38c..ff49834a65 100644 --- a/basis/images/images-tests.factor +++ b/basis/images/images-tests.factor @@ -3,7 +3,7 @@ USING: images tools.test kernel accessors ; IN: images.tests -[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA f B{ +[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA ubyte-components f B{ 0 0 0 0 0 0 0 0 0 0 0 0 @@ -19,7 +19,7 @@ IN: images.tests 57 57 57 255 0 0 0 0 0 0 0 0 -} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA f B{ +} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA ubyte-components f B{ 0 0 0 0 0 0 0 0 0 0 0 0 diff --git a/basis/images/images.factor b/basis/images/images.factor index 4c76b85459..f74233c515 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -3,12 +3,58 @@ USING: combinators kernel accessors sequences math arrays ; IN: images -SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR -R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; +SINGLETONS: + L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR + ubyte-components ushort-components + half-components float-components + byte-integer-components ubyte-integer-components + short-integer-components ushort-integer-components + int-integer-components uint-integer-components ; -UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ; +UNION: component-order + L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; -: bytes-per-pixel ( component-order -- n ) +UNION: component-type + ubyte-components ushort-components + half-components float-components + byte-integer-components ubyte-integer-components + short-integer-components ushort-integer-components + int-integer-components uint-integer-components ; + +UNION: unnormalized-integer-components + byte-integer-components ubyte-integer-components + short-integer-components ushort-integer-components + int-integer-components uint-integer-components ; + +UNION: alpha-channel BGRA RGBA ABGR ARGB ; + +TUPLE: image dim component-order component-type upside-down? bitmap ; + +: ( -- image ) image new ; inline + +: has-alpha? ( image -- ? ) component-order>> alpha-channel? ; + +GENERIC: load-image* ( path class -- image ) + +DEFER: bytes-per-pixel + + ( -- image ) image new ; inline - -: has-alpha? ( image -- ? ) component-order>> alpha-channel? ; - -GENERIC: load-image* ( path class -- image ) - -> first * + ] - [ component-order>> bytes-per-pixel [ * dup ] keep + ] + [ bytes-per-pixel [ * dup ] keep + ] [ bitmap>> ] tri ; : set-subseq ( new-value from to victim -- ) @@ -48,6 +80,10 @@ GENERIC: load-image* ( path class -- image ) PRIVATE> +: bytes-per-pixel ( image -- n ) + [ component-order>> component-count ] + [ component-type>> bytes-per-component ] bi * ; + : pixel-at ( x y image -- pixel ) pixel@ subseq ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index f61254c3cf..ca3ea8d2b4 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -298,6 +298,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; : setup-bitmap ( image -- ) dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim BGR >>component-order + ubyte-components >>component-type f >>upside-down? dup dim>> first2 * 3 * 0 >>bitmap drop ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index bb470d8dd8..2469a6a72c 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -85,7 +85,7 @@ ERROR: unimplemented-color-type image ; [ ] dip { [ png-image-bytes >>bitmap ] [ [ width>> ] [ height>> ] bi 2array >>dim ] - [ drop RGB >>component-order ] + [ drop RGB >>component-order ubyte-components >>component-type ] } cleave ; : decode-indexed-color ( loading-png -- loading-png ) diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor index fc463731b3..cd6754550d 100755 --- a/basis/images/processing/processing.factor +++ b/basis/images/processing/processing.factor @@ -17,7 +17,7 @@ IN: images.processing over matrix-dim >>dim swap flip flatten [ 128 * 128 + 0 max 255 min >fixnum ] map - >byte-array >>bitmap L >>component-order ; + >byte-array >>bitmap L >>component-order ubyte-components >>component-type ; :: matrix-zoom ( m f -- m' ) m matrix-dim f v*n coord-matrix diff --git a/basis/images/tesselation/tesselation-tests.factor b/basis/images/tesselation/tesselation-tests.factor index 2ac8e37ae7..9db58649a0 100644 --- a/basis/images/tesselation/tesselation-tests.factor +++ b/basis/images/tesselation/tesselation-tests.factor @@ -10,12 +10,12 @@ IN: images.tesselation [ { { - T{ image f { 2 2 } L f B{ 1 2 5 6 } } - T{ image f { 2 2 } L f B{ 3 4 7 8 } } + T{ image f { 2 2 } L ubyte-components f B{ 1 2 5 6 } } + T{ image f { 2 2 } L ubyte-components f B{ 3 4 7 8 } } } { - T{ image f { 2 2 } L f B{ 9 10 13 14 } } - T{ image f { 2 2 } L f B{ 11 12 15 16 } } + T{ image f { 2 2 } L ubyte-components f B{ 9 10 13 14 } } + T{ image f { 2 2 } L ubyte-components f B{ 11 12 15 16 } } } } ] [ @@ -23,18 +23,19 @@ IN: images.tesselation 1 16 [a,b] >byte-array >>bitmap { 4 4 } >>dim L >>component-order + ubyte-components >>component-type { 2 2 } tesselate ] unit-test [ { { - T{ image f { 2 2 } L f B{ 1 2 4 5 } } - T{ image f { 1 2 } L f B{ 3 6 } } + T{ image f { 2 2 } L ubyte-components f B{ 1 2 4 5 } } + T{ image f { 1 2 } L ubyte-components f B{ 3 6 } } } { - T{ image f { 2 1 } L f B{ 7 8 } } - T{ image f { 1 1 } L f B{ 9 } } + T{ image f { 2 1 } L ubyte-components f B{ 7 8 } } + T{ image f { 1 1 } L ubyte-components f B{ 9 } } } } ] [ @@ -42,5 +43,6 @@ IN: images.tesselation 1 9 [a,b] >byte-array >>bitmap { 3 3 } >>dim L >>component-order + ubyte-components >>component-type { 2 2 } tesselate -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/images/tesselation/tesselation.factor b/basis/images/tesselation/tesselation.factor index cbdf396b48..d01bad61ea 100644 --- a/basis/images/tesselation/tesselation.factor +++ b/basis/images/tesselation/tesselation.factor @@ -19,7 +19,7 @@ IN: images.tesselation '[ _ tesselate-columns ] map ; : tile-width ( tile-bitmap original-image -- width ) - [ first length ] [ component-order>> bytes-per-pixel ] bi* /i ; + [ first length ] [ bytes-per-pixel ] bi* /i ; : ( tile-bitmap original-image -- tile-image ) clone @@ -28,8 +28,8 @@ IN: images.tesselation [ [ over tile-width ] [ length ] bi 2array >>dim ] bi ; :: tesselate ( image tess-dim -- image-grid ) - image component-order>> bytes-per-pixel :> bpp + image bytes-per-pixel :> bpp image dim>> { bpp 1 } v* :> image-dim' tess-dim { bpp 1 } v* :> tess-dim' image bitmap>> image-dim' tess-dim' tesselate-bitmap - [ [ image ] map ] map ; \ No newline at end of file + [ [ image ] map ] map ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index e00b05f2e7..7e12b03c13 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -484,15 +484,15 @@ ERROR: unknown-component-order ifd ; [ unknown-component-order ] } case >>bitmap ; -: ifd-component-order ( ifd -- byte-order ) +: ifd-component-order ( ifd -- component-order component-type ) bits-per-sample find-tag { - { { 32 32 32 32 } [ R32G32B32A32 ] } - { { 32 32 32 } [ R32G32B32 ] } - { { 16 16 16 16 } [ R16G16B16A16 ] } - { { 16 16 16 } [ R16G16B16 ] } - { { 8 8 8 8 } [ RGBA ] } - { { 8 8 8 } [ RGB ] } - { 8 [ LA ] } + { { 32 32 32 32 } [ RGBA float-components ] } + { { 32 32 32 } [ RGB float-components ] } + { { 16 16 16 16 } [ RGBA ushort-components ] } + { { 16 16 16 } [ RGB ushort-components ] } + { { 8 8 8 8 } [ RGBA ubyte-components ] } + { { 8 8 8 } [ RGB ubyte-components ] } + { 8 [ LA ubyte-components ] } [ unknown-component-order ] } case ; @@ -507,7 +507,7 @@ ERROR: unknown-component-order ifd ; : ifd>image ( ifd -- image ) [ ] dip { [ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ] - [ ifd-component-order >>component-order ] + [ ifd-component-order [ >>component-order ] [ >>component-type ] bi* ] [ bitmap>> >>bitmap ] } cleave ; diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index be457dcd00..fb3b10354b 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -356,10 +356,6 @@ CONSTANT: GL_DITHER HEX: 0BD0 CONSTANT: GL_RGB HEX: 1907 CONSTANT: GL_RGBA HEX: 1908 -! GL_BGRA_ext: http://www.opengl.org/registry/specs/EXT/bgra.txt -CONSTANT: GL_BGR_EXT HEX: 80E0 -CONSTANT: GL_BGRA_EXT HEX: 80E1 - ! Implementation limits CONSTANT: GL_MAX_LIST_NESTING HEX: 0B31 CONSTANT: GL_MAX_ATTRIB_STACK_DEPTH HEX: 0D35 @@ -1801,6 +1797,12 @@ CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT HEX: 8D56 CONSTANT: GL_MAX_SAMPLES_EXT HEX: 8D57 +! GL_ARB_half_float_pixel, GL_ARB_half_float_vertex + + +CONSTANT: GL_HALF_FLOAT_ARB HEX: 140B + + ! GL_ARB_texture_float diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 2eabbd478b..c2fa02ac5e 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -4,7 +4,7 @@ USING: accessors assocs cache colors.constants destructors kernel opengl opengl.gl opengl.capabilities combinators images images.tesselation grouping specialized-arrays.float sequences math math.vectors math.matrices generalizations fry arrays namespaces -system ; +system locals ; IN: opengl.textures SYMBOL: non-power-of-2-textures? @@ -22,16 +22,46 @@ SYMBOL: non-power-of-2-textures? : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ; -GENERIC: component-order>format ( component-order -- format type ) +GENERIC: component-type>type ( component-type -- internal-format type ) +GENERIC: component-order>format ( type component-order -- type format ) +GENERIC: component-order>integer-format ( type component-order -- type format ) -M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ; -M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ; -M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ; -M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ; -M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; -M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; -M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ; -M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ; +ERROR: unsupported-component-order component-order ; + +M: ubyte-components component-type>type drop GL_RGBA8 GL_UNSIGNED_BYTE ; +M: ushort-components component-type>type drop GL_RGBA16 GL_UNSIGNED_SHORT ; +M: half-components component-type>type drop GL_RGBA16F_ARB GL_HALF_FLOAT_ARB ; +M: float-components component-type>type drop GL_RGBA32F_ARB GL_FLOAT ; +M: byte-integer-components component-type>type drop GL_RGBA8I_EXT GL_BYTE ; +M: short-integer-components component-type>type drop GL_RGBA16I_EXT GL_SHORT ; +M: int-integer-components component-type>type drop GL_RGBA32I_EXT GL_INT ; +M: ubyte-integer-components component-type>type drop GL_RGBA8I_EXT GL_UNSIGNED_BYTE ; +M: ushort-integer-components component-type>type drop GL_RGBA16I_EXT GL_UNSIGNED_SHORT ; +M: uint-integer-components component-type>type drop GL_RGBA32I_EXT GL_UNSIGNED_INT ; + +M: RGB component-order>format drop GL_RGB ; +M: BGR component-order>format drop GL_BGR ; +M: RGBA component-order>format drop GL_RGBA ; +M: ARGB component-order>format + swap GL_UNSIGNED_BYTE = + [ drop GL_UNSIGNED_INT_8_8_8_8_REV GL_BGRA ] + [ unsupported-component-order ] if ; +M: BGRA component-order>format drop GL_BGRA ; +M: BGRX component-order>format drop GL_BGRA ; +M: LA component-order>format drop GL_LUMINANCE_ALPHA ; +M: L component-order>format drop GL_LUMINANCE ; + +M: object component-order>format unsupported-component-order ; + +M: RGB component-order>integer-format drop GL_RGB_INTEGER_EXT ; +M: BGR component-order>integer-format drop GL_BGR_INTEGER_EXT ; +M: RGBA component-order>integer-format drop GL_RGBA_INTEGER_EXT ; +M: BGRA component-order>integer-format drop GL_BGRA_INTEGER_EXT ; +M: BGRX component-order>integer-format drop GL_BGRA_INTEGER_EXT ; +M: LA component-order>integer-format drop GL_LUMINANCE_ALPHA_INTEGER_EXT ; +M: L component-order>integer-format drop GL_LUMINANCE_INTEGER_EXT ; + +M: object component-order>integer-format unsupported-component-order ; SLOT: display-list @@ -50,18 +80,25 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed [ dup 1 = [ next-power-of-2 ] unless ] map ] unless ; -: tex-image ( image bitmap -- ) +: image-format ( image -- internal-format format type ) + dup component-type>> + [ nip component-type>type ] [ - [ GL_TEXTURE_2D 0 GL_RGBA ] dip - [ dim>> adjust-texture-dim first2 0 ] - [ component-order>> component-order>format ] bi - ] dip - glTexImage2D ; + unnormalized-integer-components? + [ component-order>> component-order>integer-format ] + [ component-order>> component-order>format ] if + ] 2bi swap ; + +:: tex-image ( image bitmap -- ) + image image-format :> type :> format :> internal-format + GL_TEXTURE_2D 0 internal-format + image dim>> adjust-texture-dim first2 0 + format type bitmap glTexImage2D ; : tex-sub-image ( image -- ) [ GL_TEXTURE_2D 0 0 0 ] dip [ dim>> first2 ] - [ component-order>> component-order>format ] + [ image-format [ drop ] 2dip ] [ bitmap>> ] tri glTexSubImage2D ; diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 7d18482bff..afdaccc896 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -74,7 +74,7 @@ $nl "Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:" { $heading "Input quotation declaration" } "Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:" -{ $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } +{ $example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } "The following is correct:" { $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" } "The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter." diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index a9568d4f75..a7b9fd3801 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types arrays assocs cocoa kernel math -cocoa.messages cocoa.subclassing cocoa.classes cocoa.views -cocoa.application cocoa.pasteboard cocoa.types cocoa.windows sequences -ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds -ui.gestures core-foundation.strings core-graphics core-graphics.types -threads combinators math.rectangles ; +USING: accessors alien alien.c-types alien.strings arrays assocs +cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes +cocoa.views cocoa.application cocoa.pasteboard cocoa.types +cocoa.windows sequences io.encodings.ascii ui ui.private ui.gadgets +ui.gadgets.private ui.gadgets.worlds ui.gestures +core-foundation.strings core-graphics core-graphics.types threads +combinators math.rectangles ; IN: ui.backend.cocoa.views : send-mouse-moved ( view event -- ) @@ -121,6 +122,25 @@ CONSTANT: key-codes [ drop dim>> first2 ] 2bi ; +CONSTANT: selector>action H{ + { "undo:" undo-action } + { "redo:" redo-action } + { "cut:" cut-action } + { "copy:" copy-action } + { "paste:" paste-action } + { "delete:" delete-action } + { "selectAll:" select-all-action } + { "newDocument:" new-action } + { "openDocument:" open-action } + { "saveDocument:" save-action } + { "saveDocumentAs:" save-as-action } + { "revertDocumentToSaved:" revert-action } +} + +: validate-action ( world selector -- ? validated? ) + selector>action at + [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ; + CLASS: { { +superclass+ "NSOpenGLView" } { +name+ "FactorView" } @@ -197,6 +217,14 @@ CLASS: { [ nip send-key-up-event ] } +{ "validateUserInterfaceItem:" "char" { "id" "SEL" "id" } + [ + nip -> action + 2dup [ window ] [ ascii alien>string ] bi* validate-action + [ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if + ] +} + { "undo:" "id" { "id" "SEL" "id" } [ nip undo-action send-action$ ] } @@ -225,6 +253,26 @@ CLASS: { [ nip select-all-action send-action$ ] } +{ "newDocument:" "id" { "id" "SEL" "id" } + [ nip new-action send-action$ ] +} + +{ "openDocument:" "id" { "id" "SEL" "id" } + [ nip open-action send-action$ ] +} + +{ "saveDocument:" "id" { "id" "SEL" "id" } + [ nip save-action send-action$ ] +} + +{ "saveDocumentAs:" "id" { "id" "SEL" "id" } + [ nip save-as-action send-action$ ] +} + +{ "revertDocumentToSaved:" "id" { "id" "SEL" "id" } + [ nip revert-action send-action$ ] +} + ! Multi-touch gestures: this is undocumented. ! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html { "magnifyWithEvent:" "void" { "id" "SEL" "id" } diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor index ebffb0bfbc..1e5a8df1dd 100644 --- a/basis/ui/gestures/gestures-docs.factor +++ b/basis/ui/gestures/gestures-docs.factor @@ -13,9 +13,20 @@ $nl "Outputs " { $link f } " if the gesture was handled, and " { $link t } " if the gesture should be passed on to the gadget's parent." $nl "The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class." } -{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ; +{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } ". If you define a method on " { $snippet "handle-gesture" } ", you should also override " { $link handles-gesture? } "." } ; -{ propagate-gesture handle-gesture set-gestures } related-words +HELP: handles-gesture? +{ $values { "gesture" "a gesture" } { "gadget" "the receiver of the gesture" } { "?" "a boolean" } } +{ $contract "Returns a true value if " { $snippet "gadget" } " would handle " { $snippet "gesture" } " in its " { $link handle-gesture } " method." +$nl +"The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class and returns true if a handler is present for " { $snippet "gesture" } "." } +{ $notes "This word is used in Factor's MacOS X UI to validate menu items." } ; + +HELP: parents-handle-gesture? +{ $values { "gesture" "a gesture" } { "gadget" "the receiver of the gesture" } { "?" "a boolean" } } +{ $contract "Returns a true value if " { $snippet "gadget" } " or any of its ancestors would handle " { $snippet "gesture" } " in its " { $link handle-gesture } " method." } ; + +{ propagate-gesture handle-gesture handles-gesture? set-gestures } related-words HELP: propagate-gesture { $values { "gesture" "a gesture" } { "gadget" gadget } } @@ -86,6 +97,30 @@ HELP: select-all-action { $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." } { $examples { $code "select-all-action" } } ; +HELP: new-action +{ $class-description "Gesture sent when the " { $emphasis "new" } " standard window system action is invoked." } +{ $examples { $code "new-action" } } ; + +HELP: open-action +{ $class-description "Gesture sent when the " { $emphasis "open" } " standard window system action is invoked." } +{ $examples { $code "open-action" } } ; + +HELP: save-action +{ $class-description "Gesture sent when the " { $emphasis "save" } " standard window system action is invoked." } +{ $examples { $code "save-action" } } ; + +HELP: save-as-action +{ $class-description "Gesture sent when the " { $emphasis "save as" } " standard window system action is invoked." } +{ $examples { $code "save-as-action" } } ; + +HELP: revert-action +{ $class-description "Gesture sent when the " { $emphasis "revert" } " standard window system action is invoked." } +{ $examples { $code "revert-action" } } ; + +HELP: close-action +{ $class-description "Gesture sent when the " { $emphasis "close" } " standard window system action is invoked." } +{ $examples { $code "close-action" } } ; + HELP: C+ { $description "Control key modifier." } ; @@ -350,21 +385,34 @@ $nl { $subsection zoom-out-action } ; ARTICLE: "action-gestures" "Action gestures" -"Action gestures exist to keep keyboard shortcuts for common clipboard operations consistent." +"Action gestures exist to keep keyboard shortcuts for common application operations consistent." +{ $subsection undo-action } +{ $subsection redo-action } { $subsection cut-action } { $subsection copy-action } { $subsection paste-action } { $subsection delete-action } { $subsection select-all-action } +{ $subsection new-action } +{ $subsection open-action } +{ $subsection save-action } +{ $subsection save-as-action } +{ $subsection revert-action } +{ $subsection close-action } "The following keyboard gestures, if not handled directly, send action gestures:" { $table { { $strong "Keyboard gesture" } { $strong "Action gesture" } } { { $snippet "T{ key-down f { C+ } \"z\" }" } { $snippet "undo-action" } } - { { $snippet "T{ key-down f { C+ } \"Z\" }" } { $snippet "redo-action" } } + { { $snippet "T{ key-down f { C+ } \"y\" }" } { $snippet "redo-action" } } { { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "cut-action" } } { { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "copy-action" } } { { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "paste-action" } } { { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "select-all-action" } } + { { $snippet "T{ key-down f { C+ } \"n\" }" } { $snippet "new-action" } } + { { $snippet "T{ key-down f { C+ } \"o\" }" } { $snippet "open-action" } } + { { $snippet "T{ key-down f { C+ } \"s\" }" } { $snippet "save-action" } } + { { $snippet "T{ key-down f { C+ } \"S\" }" } { $snippet "save-as-action" } } + { { $snippet "T{ key-down f { C+ } \"w\" }" } { $snippet "close-action" } } } "Action gestures should be used in place of the above keyboard gestures if possible. For example, on Mac OS X, the standard " { $strong "Edit" } " menu items send action gestures." ; diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 073b2d5e26..26eb45c8d0 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -7,13 +7,24 @@ sets columns fry deques ui.gadgets ui.gadgets.private ascii combinators.short-circuit ; IN: ui.gestures +: get-gesture-handler ( gesture gadget -- quot ) + class superclasses [ "gestures" word-prop ] map assoc-stack ; + GENERIC: handle-gesture ( gesture gadget -- ? ) M: object handle-gesture [ nip ] - [ class superclasses [ "gestures" word-prop ] map assoc-stack ] 2bi + [ get-gesture-handler ] 2bi dup [ call( gadget -- ) f ] [ 2drop t ] if ; +GENERIC: handles-gesture? ( gesture gadget -- ? ) + +M: object handles-gesture? ( gesture gadget -- ? ) + get-gesture-handler >boolean ; + +: parents-handle-gesture? ( gesture gadget -- ? ) + [ handles-gesture? not ] with each-parent not ; + : set-gestures ( class hash -- ) "gestures" set-word-prop ; : gesture-queue ( -- deque ) \ gesture-queue get ; @@ -82,23 +93,32 @@ undo-action redo-action cut-action copy-action paste-action delete-action select-all-action left-action right-action up-action down-action -zoom-in-action zoom-out-action ; +zoom-in-action zoom-out-action +new-action open-action save-action save-as-action +revert-action close-action ; UNION: action undo-action redo-action cut-action copy-action paste-action delete-action select-all-action left-action right-action up-action down-action -zoom-in-action zoom-out-action ; +zoom-in-action zoom-out-action +new-action open-action save-action save-as-action +revert-action close-action ; CONSTANT: action-gestures { { "z" undo-action } - { "Z" redo-action } + { "y" redo-action } { "x" cut-action } { "c" copy-action } { "v" paste-action } { "a" select-all-action } + { "n" new-action } + { "o" open-action } + { "s" save-action } + { "S" save-as-action } + { "w" close-action } } ! Modifiers diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index b381c4e677..43dd22cde7 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -81,6 +81,10 @@ HELP: with-ui HELP: beep { $description "Plays the system beep sound." } ; +HELP: topmost-window +{ $values { "world" world } } +{ $description "Returns the " { $link world } " representing the currently focused window." } ; + ARTICLE: "ui-glossary" "UI glossary" { $table { "color" { "an instance of " { $link color } } } diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 37ec4f35b1..db05465986 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -224,6 +224,9 @@ PRIVATE> : raise-window ( gadget -- ) find-world raise-window* ; +: topmost-window ( -- world ) + windows get last second ; + HOOK: close-window ui-backend ( gadget -- ) M: object close-window diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index 6fadcf7679..7e218fa79c 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -2,13 +2,16 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors fry io io.binary io.encodings.string io.encodings.utf8 kernel math namespaces sequences serialize arrays calendar io.encodings ; +FROM: kernel.private => declare ; +FROM: io.encodings.private => (read-until) ; + IN: bson.reader ( exemplar -- state ) @@ -17,25 +20,25 @@ TUPLE: state clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi V{ } clone [ T_Object "" element boa swap push ] keep >>element ; -PREDICATE: bson-eoo < integer T_EOO = ; PREDICATE: bson-not-eoo < integer T_EOO > ; +PREDICATE: bson-eoo < integer T_EOO = ; -PREDICATE: bson-double < integer T_Double = ; -PREDICATE: bson-integer < integer T_Integer = ; PREDICATE: bson-string < integer T_String = ; PREDICATE: bson-object < integer T_Object = ; +PREDICATE: bson-oid < integer T_OID = ; PREDICATE: bson-array < integer T_Array = ; +PREDICATE: bson-integer < integer T_Integer = ; +PREDICATE: bson-double < integer T_Double = ; +PREDICATE: bson-date < integer T_Date = ; PREDICATE: bson-binary < integer T_Binary = ; +PREDICATE: bson-boolean < integer T_Boolean = ; PREDICATE: bson-regexp < integer T_Regexp = ; +PREDICATE: bson-null < integer T_NULL = ; +PREDICATE: bson-ref < integer T_DBRef = ; PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ; PREDICATE: bson-binary-function < integer T_Binary_Function = ; PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ; PREDICATE: bson-binary-custom < integer T_Binary_Custom = ; -PREDICATE: bson-oid < integer T_OID = ; -PREDICATE: bson-boolean < integer T_Boolean = ; -PREDICATE: bson-date < integer T_Date = ; -PREDICATE: bson-null < integer T_NULL = ; -PREDICATE: bson-ref < integer T_DBRef = ; GENERIC: element-read ( type -- cont? ) GENERIC: element-data-read ( type -- object ) @@ -47,27 +50,27 @@ GENERIC: element-binary-read ( length type -- object ) : get-state ( -- state ) state get ; inline -: count-bytes ( count -- ) - [ get-state ] dip '[ _ + ] change-read drop ; inline - : read-int32 ( -- int32 ) - 4 [ read byte-array>number ] [ count-bytes ] bi ; inline + 4 read byte-array>number ; inline : read-longlong ( -- longlong ) - 8 [ read byte-array>number ] [ count-bytes ] bi ; inline + 8 read byte-array>number ; inline : read-double ( -- double ) - 8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline + 8 read byte-array>number bits>double ; inline : read-byte-raw ( -- byte-raw ) - 1 [ read ] [ count-bytes ] bi ; inline + 1 read ; inline : read-byte ( -- byte ) read-byte-raw first ; inline +: utf8-read-until ( seps stream encoding -- string/f sep/f ) + [ { utf8 } declare decode-char dup [ dup rot member? ] [ 2drop f t ] if ] + 3curry (read-until) ; + : read-cstring ( -- string ) - input-stream get utf8 - "\0" swap stream-read-until drop ; inline + "\0" input-stream get utf8 utf8-read-until drop ; inline : read-sized-string ( length -- string ) drop read-cstring ; inline @@ -141,13 +144,13 @@ M: bson-not-eoo element-read ( type -- cont? ) M: bson-object element-data-read ( type -- object ) (object-data-read) ; -M: bson-array element-data-read ( type -- object ) - (object-data-read) ; - M: bson-string element-data-read ( type -- object ) drop read-int32 read-sized-string ; +M: bson-array element-data-read ( type -- object ) + (object-data-read) ; + M: bson-integer element-data-read ( type -- object ) drop read-int32 ; @@ -191,7 +194,7 @@ PRIVATE> USE: tools.continuations -: stream>assoc ( exemplar -- assoc bytes-read ) +: stream>assoc ( exemplar -- assoc ) dup state [ read-int32 >>size read-elements ] with-variable - [ result>> ] [ read>> ] bi ; + result>> ; diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor index 682257558f..5d850929ab 100644 --- a/extra/bson/writer/writer.factor +++ b/extra/bson/writer/writer.factor @@ -6,25 +6,24 @@ io.encodings.utf8 io.streams.byte-array kernel math math.parser namespaces quotations sequences sequences.private serialize strings words combinators.short-circuit literals ; +FROM: io.encodings.utf8.private => char>utf8 ; +FROM: kernel.private => declare ; + IN: bson.writer [ shared-buffer set ] keep ] unless* ; inline - -: >le-stream ( x n -- ) - swap - '[ _ swap nth-byte 0 B{ 0 } - [ set-nth-unsafe ] keep write ] each ; inline - + [ BV{ } clone [ shared-buffer set ] keep ] unless* + { byte-vector } declare ; inline + PRIVATE> : reset-buffer ( buffer -- ) @@ -33,40 +32,38 @@ PRIVATE> : ensure-buffer ( -- ) (buffer) drop ; inline -: with-buffer ( quot -- byte-vector ) +: with-buffer ( quot: ( -- ) -- byte-vector ) [ (buffer) [ reset-buffer ] keep dup ] dip - with-output-stream* dup encoder? [ stream>> ] when ; inline + with-output-stream* ; inline : with-length ( quot: ( -- ) -- bytes-written start-index ) - [ (buffer) [ length ] keep ] dip call - length swap [ - ] keep ; inline + [ (buffer) [ length ] keep ] dip + call length swap [ - ] keep ; inline + +: (with-length-prefix) ( quot: ( -- ) length-quot: ( bytes-written -- length ) -- ) + [ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap + [ call ] dip (buffer) copy ; inline : with-length-prefix ( quot: ( -- ) -- ) - [ B{ 0 0 0 0 } write ] prepose with-length - [ INT32-SIZE >le ] dip (buffer) - '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ] - [ INT32-SIZE ] dip each-integer ; inline - + [ INT32-SIZE >le ] (with-length-prefix) ; inline + : with-length-prefix-excl ( quot: ( -- ) -- ) - [ B{ 0 0 0 0 } write ] prepose with-length - [ INT32-SIZE - INT32-SIZE >le ] dip (buffer) - '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ] - [ INT32-SIZE ] dip each-integer ; inline + [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline stream-write ; inline +: write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline -: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline -: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline -: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline +: write-byte ( byte -- ) CHAR-SIZE >le write ; inline +: write-int32 ( int -- ) INT32-SIZE >le write ; inline +: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline : write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline -: write-longlong ( object -- ) INT64-SIZE >le-stream ; inline +: write-longlong ( object -- ) INT64-SIZE >le write ; inline : write-eoo ( -- ) T_EOO write-byte ; inline : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline : write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline +M: string bson-write ( obj -- ) + '[ _ write-cstring ] with-length-prefix-excl ; + M: f bson-write ( f -- ) drop 0 write-byte ; M: t bson-write ( t -- ) drop 1 write-byte ; -M: string bson-write ( obj -- ) - '[ _ write-cstring ] with-length-prefix-excl ; - M: integer bson-write ( num -- ) write-int32 ; @@ -153,8 +149,8 @@ PRIVATE> [ '[ _ bson-write ] with-buffer ] with-scope ; inline : assoc>stream ( assoc -- ) - bson-write ; inline + { assoc } declare bson-write ; inline : mdb-special-value? ( value -- ? ) { [ timestamp? ] [ quotation? ] [ mdbregexp? ] - [ oid? ] [ byte-array? ] } 1|| ; \ No newline at end of file + [ oid? ] [ byte-array? ] } 1|| ; inline \ No newline at end of file diff --git a/extra/images/normalization/normalization.factor b/extra/images/normalization/normalization.factor index dcdf39a53e..0f4877055a 100755 --- a/extra/images/normalization/normalization.factor +++ b/extra/images/normalization/normalization.factor @@ -3,7 +3,8 @@ USING: kernel accessors grouping sequences combinators math specialized-arrays.direct.uint byte-arrays fry specialized-arrays.direct.ushort specialized-arrays.uint -specialized-arrays.ushort specialized-arrays.float images ; +specialized-arrays.ushort specialized-arrays.float images +half-floats ; IN: images.normalization [ 255 suffix ] map concat ; -: normalize-floats ( byte-array -- byte-array ) - byte-array>float-array [ 255.0 * >integer ] B{ } map-as ; +: normalize-floats ( float-array -- byte-array ) + [ 255.0 * >integer ] B{ } map-as ; +GENERIC: normalize-component-type* ( image component-type -- image ) GENERIC: normalize-component-order* ( image component-order -- image ) : normalize-component-order ( image -- image ) + dup component-type>> '[ _ normalize-component-type* ] change-bitmap dup component-order>> '[ _ normalize-component-order* ] change-bitmap ; -M: RGBA normalize-component-order* drop ; +M: float-components normalize-component-type* + drop byte-array>float-array normalize-floats ; +M: half-components normalize-component-type* + drop byte-array>half-array normalize-floats ; -M: R32G32B32A32 normalize-component-order* - drop normalize-floats ; - -M: R32G32B32 normalize-component-order* - drop normalize-floats add-dummy-alpha ; - -: RGB16>8 ( bitmap -- bitmap' ) +: ushorts>ubytes ( bitmap -- bitmap' ) byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline -M: R16G16B16A16 normalize-component-order* - drop RGB16>8 ; +M: ushort-components normalize-component-type* + drop ushorts>ubytes ; -M: R16G16B16 normalize-component-order* - drop RGB16>8 add-dummy-alpha ; +M: ubyte-components normalize-component-type* + drop ; + +M: RGBA normalize-component-order* drop ; : BGR>RGB ( bitmap -- pixels ) 3 [ ] map B{ } join ; inline diff --git a/extra/io/serial/unix/linux/linux.factor b/extra/io/serial/unix/linux/linux.factor index 4d1878d2a9..b0cac09b5f 100644 --- a/extra/io/serial/unix/linux/linux.factor +++ b/extra/io/serial/unix/linux/linux.factor @@ -95,23 +95,23 @@ CONSTANT: PENDIN OCT: 0040000 CONSTANT: IEXTEN OCT: 0100000 M: linux lookup-baud ( n -- n ) - dup H{ - { 0 OCT: 0000000 } - { 50 OCT: 0000001 } - { 75 OCT: 0000002 } - { 110 OCT: 0000003 } - { 134 OCT: 0000004 } - { 150 OCT: 0000005 } - { 200 OCT: 0000006 } - { 300 OCT: 0000007 } - { 600 OCT: 0000010 } - { 1200 OCT: 0000011 } - { 1800 OCT: 0000012 } - { 2400 OCT: 0000013 } - { 4800 OCT: 0000014 } - { 9600 OCT: 0000015 } - { 19200 OCT: 0000016 } - { 38400 OCT: 0000017 } + H{ + { 0 OCT: 0000000 } + { 50 OCT: 0000001 } + { 75 OCT: 0000002 } + { 110 OCT: 0000003 } + { 134 OCT: 0000004 } + { 150 OCT: 0000005 } + { 200 OCT: 0000006 } + { 300 OCT: 0000007 } + { 600 OCT: 0000010 } + { 1200 OCT: 0000011 } + { 1800 OCT: 0000012 } + { 2400 OCT: 0000013 } + { 4800 OCT: 0000014 } + { 9600 OCT: 0000015 } + { 19200 OCT: 0000016 } + { 38400 OCT: 0000017 } { 57600 OCT: 0010001 } { 115200 OCT: 0010002 } { 230400 OCT: 0010003 } diff --git a/extra/mongodb/benchmark/benchmark.factor b/extra/mongodb/benchmark/benchmark.factor index a977224d66..5204846d03 100644 --- a/extra/mongodb/benchmark/benchmark.factor +++ b/extra/mongodb/benchmark/benchmark.factor @@ -2,6 +2,7 @@ USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-a sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary accessors words mongodb.driver strings math.parser bson.writer ; FROM: mongodb.driver => find ; +FROM: memory => gc ; IN: mongodb.benchmark @@ -175,7 +176,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) [ 0 ] dip call( i -- doc ) assoc>bv - '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; + '[ trial-size [ _ binary [ H{ } stream>assoc drop ] with-byte-reader ] times ] ; : check-for-key ( assoc key -- ) CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; @@ -246,7 +247,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) ) '[ _ swap _ '[ [ [ _ execute( -- quot ) ] dip - [ execute( -- ) ] each _ execute( quot -- quot ) benchmark ] with-result ] each + [ execute( -- ) ] each _ execute( quot -- quot ) gc benchmark ] with-result ] each print-separator ] ; : run-serialization-bench ( doc-word-seq feat-seq -- ) diff --git a/extra/mongodb/mmm/authors.txt b/extra/mongodb/mmm/authors.txt deleted file mode 100644 index 5df962bfe0..0000000000 --- a/extra/mongodb/mmm/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Sascha Matzke diff --git a/extra/mongodb/mmm/mmm.factor b/extra/mongodb/mmm/mmm.factor deleted file mode 100644 index 8e56143664..0000000000 --- a/extra/mongodb/mmm/mmm.factor +++ /dev/null @@ -1,101 +0,0 @@ -USING: accessors fry io io.encodings.binary io.servers.connection -io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting -namespaces prettyprint tools.walker calendar calendar.format bson.writer.private -json.writer mongodb.operations.private mongodb.operations ; - -IN: mongodb.mmm - -SYMBOLS: mmm-port mmm-server-ip mmm-server-port mmm-server mmm-dump-output mmm-t-srv ; - -GENERIC: dump-message ( message -- ) - -: check-options ( -- ) - mmm-port get [ 27040 mmm-port set ] unless - mmm-server-ip get [ "127.0.0.1" mmm-server-ip set ] unless - mmm-server-port get [ 27017 mmm-server-port set ] unless - mmm-server-ip get mmm-server-port get mmm-server set ; - -: read-msg-binary ( -- ) - read-int32 - [ write-int32 ] keep - 4 - read write ; - -: read-request-header ( -- msg-stub ) - mdb-msg new - read-int32 MSG-HEADER-SIZE - >>length - read-int32 >>req-id - read-int32 >>resp-id - read-int32 >>opcode ; - -: read-request ( -- msg-stub binary ) - binary [ read-msg-binary ] with-byte-writer - [ binary [ read-request-header ] with-byte-reader ] keep ; ! msg-stub binary - -: dump-request ( msg-stub binary -- ) - [ mmm-dump-output get ] 2dip - '[ _ drop _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ; - -: read-reply ( -- binary ) - binary [ read-msg-binary ] with-byte-writer ; - -: forward-request-read-reply ( msg-stub binary -- binary ) - [ mmm-server get binary ] 2dip - '[ _ opcode>> _ write flush - OP_Query = - [ read-reply ] - [ f ] if ] with-client ; - -: dump-reply ( binary -- ) - [ mmm-dump-output get ] dip - '[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ; - -: message-prefix ( message -- prefix message ) - [ now timestamp>http-string ] dip - [ class name>> ] keep - [ "%s: %s" sprintf ] dip ; inline - -M: mdb-query-msg dump-message ( message -- ) - message-prefix - [ collection>> ] keep - query>> >json - "%s -> %s: %s \n" printf ; - -M: mdb-insert-msg dump-message ( message -- ) - message-prefix - [ collection>> ] keep - objects>> >json - "%s -> %s : %s \n" printf ; - -M: mdb-reply-msg dump-message ( message -- ) - message-prefix - [ cursor>> ] keep - [ start#>> ] keep - [ returned#>> ] keep - objects>> >json - "%s -> cursor: %d, start: %d, returned#: %d, -> %s \n" printf ; - -M: mdb-msg dump-message ( message -- ) - message-prefix drop "%s \n" printf ; - -: forward-reply ( binary -- ) - write flush ; - -: handle-mmm-connection ( -- ) - read-request - [ dump-request ] 2keep - forward-request-read-reply - [ dump-reply ] keep - forward-reply ; - -: start-mmm-server ( -- ) - output-stream get mmm-dump-output set - binary [ mmm-t-srv set ] keep - "127.0.0.1" mmm-port get >>insecure - [ handle-mmm-connection ] >>handler - start-server* ; - -: run-mmm ( -- ) - check-options - start-mmm-server ; - -MAIN: run-mmm diff --git a/extra/mongodb/mmm/summary.txt b/extra/mongodb/mmm/summary.txt deleted file mode 100644 index 0670873053..0000000000 --- a/extra/mongodb/mmm/summary.txt +++ /dev/null @@ -1 +0,0 @@ -mongo-message-monitor - a small proxy to introspect messages send to MongoDB diff --git a/extra/mongodb/operations/operations.factor b/extra/mongodb/operations/operations.factor index 001e8443e4..d4ee789523 100644 --- a/extra/mongodb/operations/operations.factor +++ b/extra/mongodb/operations/operations.factor @@ -64,61 +64,13 @@ GENERIC: (read-message) ( message opcode -- message ) [ opcode>> ] keep [ >>opcode ] dip flags>> >>flags ; -M: mdb-query-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-query-msg new ] dip copy-header - read-cstring >>collection - read-int32 >>skip# - read-int32 >>return# - H{ } stream>assoc change-bytes-read >>query - dup length>> bytes-read> > - [ H{ } stream>assoc change-bytes-read >>returnfields ] when ; - -M: mdb-insert-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-insert-msg new ] dip copy-header - read-cstring >>collection - V{ } clone >>objects - [ '[ _ length>> bytes-read> > ] ] keep tuck - '[ H{ } stream>assoc change-bytes-read _ objects>> push ] - while ; - -M: mdb-delete-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-delete-msg new ] dip copy-header - read-cstring >>collection - H{ } stream>assoc change-bytes-read >>selector ; - -M: mdb-getmore-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-getmore-msg new ] dip copy-header - read-cstring >>collection - read-int32 >>return# - read-longlong >>cursor ; - -M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-killcursors-msg new ] dip copy-header - read-int32 >>cursors# - V{ } clone >>cursors - [ [ cursors#>> ] keep - '[ read-longlong _ cursors>> push ] times ] keep ; - -M: mdb-update-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-update-msg new ] dip copy-header - read-cstring >>collection - read-int32 >>upsert? - H{ } stream>assoc change-bytes-read >>selector - H{ } stream>assoc change-bytes-read >>object ; - M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) drop [ ] dip copy-header read-longlong >>cursor read-int32 >>start# read-int32 [ >>returned# ] keep - [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ; + [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ; : read-header ( message -- message ) read-int32 >>length diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index 3de4147835..975019bfd1 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -64,7 +64,8 @@ HINTS: hashes { byte-array fixnum fixnum fixnum } ; image new swap >>dim swap >>bitmap - L >>component-order ; + L >>component-order + ubyte-components >>component-type ; :: perlin-noise-unsafe ( table point -- value ) point unit-cube :> cube diff --git a/extra/terrain/generation/generation.factor b/extra/terrain/generation/generation.factor index 72221d7b0e..661ea88de6 100644 --- a/extra/terrain/generation/generation.factor +++ b/extra/terrain/generation/generation.factor @@ -36,6 +36,7 @@ TUPLE: segment image ; swap >>bitmap RGBA >>component-order + ubyte-components >>component-type terrain-segment-size >>dim ; : terrain-segment ( terrain at -- image ) diff --git a/extra/tokyo/alien/tctdb/tctdb.factor b/extra/tokyo/alien/tctdb/tctdb.factor index bb65acb2f6..e43ed9c765 100755 --- a/extra/tokyo/alien/tctdb/tctdb.factor +++ b/extra/tokyo/alien/tctdb/tctdb.factor @@ -76,7 +76,7 @@ FUNCTION: void tctdbdel ( TCTDB* tdb ) ; FUNCTION: int tctdbecode ( TCTDB* tdb ) ; FUNCTION: bool tctdbsetmutex ( TCTDB* tdb ) ; FUNCTION: bool tctdbtune ( TCTDB* tdb, longlong bnum, char apow, char fpow, uchar opts ) ; -FUNCTION: bool tctdbsetcache ( TCTDB* tdb, int32_t rcnum, int32_t lcnum, int32_t ncnum ) ; +FUNCTION: bool tctdbsetcache ( TCTDB* tdb, int rcnum, int lcnum, int ncnum ) ; FUNCTION: bool tctdbsetxmsiz ( TCTDB* tdb, longlong xmsiz ) ; FUNCTION: bool tctdbopen ( TCTDB* tdb, char* path, int omode ) ; FUNCTION: bool tctdbclose ( TCTDB* tdb ) ;